{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}

import           Data.Bits
import           Data.Proxy
--import           Data.Ratio   (denominator, numerator)
import           GHC.TypeLits
import           Text.Printf  (PrintfArg, printf)

-- FiniteFields
--https://stackoverflow.com/questions/39823408/prime-finite-field-z-pz-in-haskell-with-operator-overloading
newtype FieldElement (p :: Nat) = FieldElement Integer deriving Eq

instance KnownNat n => Num (FieldElement n) where
  FieldElement x + FieldElement y = fromInteger $ x + y
  FieldElement x * FieldElement y = fromInteger $ x * y
  abs x = x
  signum _ = 1
  negate (FieldElement x) = fromInteger $ negate x
  fromInteger a = FieldElement (mod a n) where n = natVal (Proxy :: Proxy n)

instance KnownNat n => Fractional (FieldElement n) where
  recip a = a ^ (n - 2) where n = natVal (Proxy :: Proxy n)
  fromRational r = error "cant transform" -- fromInteger (numerator r) / fromInteger (denominator r)

instance KnownNat n => Show (FieldElement n) where
  show (FieldElement a) | n == (2 ^ 256 - 2 ^ 32 - 977) = printf "0x%064x" a
                        | otherwise = "FieldElement_" ++ show n ++ " " ++ show a
    where n = natVal (Proxy :: Proxy n)


assert :: Bool -> Bool
assert False = error "WRONG"
assert x     = x

aa =
  let a = FieldElement 2 :: FieldElement 31
      b = FieldElement 15
  in  (a + b == FieldElement 17, a /= b, a - b == FieldElement 18)

bb =
  let a = FieldElement 19 :: FieldElement 31
      b = FieldElement 24
  in  a * b

-- Elliptic curve
data ECPoint a
  = Infinity
  | ECPoint
      { x :: a
      , y :: a
      , a :: a
      , b :: a
      }
  deriving (Eq)


instance {-# OVERLAPPABLE #-} (PrintfArg a, Num a) => Show (ECPoint a) where
  show Infinity = "ECPoint(Infinity)"
  show p        =  printf "ECPoint(%f, %f)_%f_%f" (x p) (y p) (a p) (b p)

instance {-# OVERLAPPING  #-} KnownNat n => Show (ECPoint (FieldElement n)) where
  show Infinity = "ECPoint(Infinity)"
  show p
    | n == (2 ^ 256 - 2 ^ 32 - 977) = "S256Point" ++ points
    | otherwise  = "ECPoint_" ++ show n ++ points ++ params
   where
    n      = natVal (Proxy :: Proxy n)
    points = "(" ++ si (x p) ++ ", " ++ si (y p) ++ ")"
    params = "a_" ++ si (a p) ++ "|b_" ++ si (b p)
    si (FieldElement r) | n == (2 ^ 256 - 2 ^ 32 - 977) = printf "0x%064x" r
                        | otherwise                     = show r

validECPoint :: (Eq a, Num a) => ECPoint a -> Bool
validECPoint Infinity          = True
validECPoint (ECPoint x y a b) = y ^ 2 == x ^ 3 + a * x + b

add :: (Eq a, Fractional a) => ECPoint a -> ECPoint a -> ECPoint a
add Infinity p        = p
add p        Infinity = p
add p q
  | a p /= a q || b p /= b q = error "point not on same curve"
  | x p == x q && y p /= y q = Infinity
  | x p /= x q               = new_point $ (y q - y p) / (x q - x p)
  | x p == x q && y p == 0   = Infinity
  | p == q                   = new_point $ (3 * x p ^ 2 + a p) / (2 * y p)
  | otherwise                = error "Unexpected case of points"
 where
  new_point slope =
    let new_x = slope ^ 2 - x p - x q
        new_y = slope * (x p - new_x) - y p
    in  ECPoint new_x new_y (a p) (b p)


binaryExpansion :: (Eq a, Fractional a) => Integer -> ECPoint a -> ECPoint a -> ECPoint a
binaryExpansion m value result | m == 0    = result
                               | otherwise = binaryExpansion (m `shiftR` 1) (add value value) accumulator
      where
        accumulator = if m .&. 1 == 1 then add result value else result

scalarProduct :: (Eq a, Fractional a) => Integer -> ECPoint a -> ECPoint a
scalarProduct m ec = binaryExpansion m ec Infinity

instance (Eq a, Fractional a) => Semigroup (ECPoint a) where
  (<>) = add

instance (Eq a, Fractional a) => Monoid (ECPoint a) where
  mempty = Infinity

tre = FieldElement 3 :: FieldElement 31
cc =
  let a = ECPoint tre (-7) 5 7
      b = ECPoint 18 77 5 7
      c = ECPoint (-1) (-1) 5 7
  in  ( validECPoint a
      , validECPoint b
      , validECPoint c
      , a /= b
      , a == a
      , add Infinity          a
      , add a                 (ECPoint 3 7 5 7)
      , add (ECPoint 3 7 5 7) c
      , add c                 c
      )

dd =
  let a     = FieldElement 0 :: FieldElement 223
      b     = FieldElement 7
      x     = FieldElement 192
      y     = FieldElement 105
  in ECPoint x y a b
ee = ECPoint 192 105 (FieldElement 0 :: FieldElement 223) 7
ff = ECPoint 192 105 0 7 :: ECPoint (FieldElement 223)

aPoint = ECPoint 192 105 0 7 :: ECPoint (FieldElement 223)
total = add aPoint $ add aPoint $ add aPoint $ add aPoint aPoint

totalfold=foldr add Infinity $ replicate 5 aPoint
totalmconcat = mconcat  $ replicate 5 aPoint

type S256Field = FieldElement (2 ^ 256- 2^ 32 - 977)
type S256Point = ECPoint S256Field
s256point :: S256Field -> S256Field -> S256Point
s256point x y = ECPoint x y 0 7
li :: S256Field
li = 12
ll :: ECPoint ( FieldElement 31)
ll = Infinity
ri= ECPoint 3 7 5 7 :: S256Point


ncons = 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141
gcons = s256point 0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798 0x483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8