{-# OPTIONS -fno-warn-orphans #-}

module Data.Curve.Binary
  ( module Data.Curve
  , Point(..)
  -- * Binary curves
  , BCurve(..)
  , BPoint
  -- ** Binary affine curves
  , BACurve(..)
  , BAPoint
  -- ** Binary projective curves
  , BPCurve(..)
  , BPPoint
  ) where

import Protolude

import Data.Field.Galois as F (GaloisField, PrimeField, frob, quad)
import GHC.Natural (Natural)
import Text.PrettyPrint.Leijen.Text (Pretty(..))

import Data.Curve

-------------------------------------------------------------------------------
-- Binary form
-------------------------------------------------------------------------------

-- | Binary points.
type BPoint = Point 'Binary

-- | Binary curves.
class (GaloisField q, PrimeField r, Curve 'Binary c e q r) => BCurve c e q r where
  {-# MINIMAL a_, b_, h_, p_, r_ #-}
  a_ :: BPoint c e q r -> q       -- ^ Coefficient @A@.
  b_ :: BPoint c e q r -> q       -- ^ Coefficient @B@.
  h_ :: BPoint c e q r -> Natural -- ^ Curve cofactor.
  p_ :: BPoint c e q r -> Natural -- ^ Curve polynomial.
  r_ :: BPoint c e q r -> Natural -- ^ Curve order.

-------------------------------------------------------------------------------
-- Affine coordinates
-------------------------------------------------------------------------------

-- | Binary affine points.
type BAPoint = BPoint 'Affine

-- | Binary affine curves @y^2 + xy = x^3 + Ax^2 + B@.
class BCurve 'Affine e q r => BACurve e q r where
  {-# MINIMAL gA_ #-}
  gA_ :: BAPoint e q r -- ^ Curve generator.

-- Binary affine curves are elliptic curves.
instance BACurve e q r => Curve 'Binary 'Affine e q r where

  data instance Point 'Binary 'Affine e q r = A q q -- ^ Affine point.
                                            | O     -- ^ Infinite point.
    deriving (Eq, Generic, NFData, Read, Show)

  add p O       = p
  add O q       = q
  add (A x1 y1) (A x2 y2)
    | xx == 0   = O
    | otherwise = A x3 y3
    where
      a  = a_ (witness :: BAPoint e q r)
      xx = x1 + x2
      yy = y1 + y2
      l  = yy / xx
      x3 = l * (l + 1) + xx + a
      y3 = l * (x1 + x3) + x3 + y1
  {-# INLINABLE add #-}

  char = const 2
  {-# INLINABLE char #-}

  cof = h_
  {-# INLINABLE cof #-}

  dbl O         = O
  dbl (A x y)
    | x == 0    = O
    | otherwise = A x' y'
    where
      a  = a_ (witness :: BAPoint e q r)
      l  = x + y / x
      l' = l + 1
      x' = l * l' + a
      y' = x * x + l' * x'
  {-# INLINABLE dbl #-}

  def O       = True
  def (A x y) = ((x + a) * x + y) * x + b + y * y == 0
    where
      a = a_ (witness :: BAPoint e q r)
      b = b_ (witness :: BAPoint e q r)
  {-# INLINABLE def #-}

  disc _ = b_ (witness :: BAPoint e q r)
  {-# INLINABLE disc #-}

  frob O       = O
  frob (A x y) = A (F.frob x) (F.frob y)
  {-# INLINABLE frob #-}

  fromA = identity
  {-# INLINABLE fromA #-}

  gen = gA_
  {-# INLINABLE gen #-}

  id = O
  {-# INLINABLE id #-}

  inv O       = O
  inv (A x y) = A x (x + y)
  {-# INLINABLE inv #-}

  order = r_
  {-# INLINABLE order #-}

  point x y = let p = A x y in if def p then Just p else Nothing
  {-# INLINABLE point #-}

  pointX x = A x <$> yX (witness :: BAPoint e q r) x
  {-# INLINABLE pointX #-}

  toA = identity
  {-# INLINABLE toA #-}

  yX _ x = quad 1 x ((x + a) * x * x + b)
    where
      a = a_ (witness :: BAPoint e q r)
      b = b_ (witness :: BAPoint e q r)
  {-# INLINABLE yX #-}

-- Binary affine points are pretty.
instance BACurve e q r => Pretty (BAPoint e q r) where

  pretty (A x y) = pretty (x, y)
  pretty O       = "O"

-------------------------------------------------------------------------------
-- Projective coordinates
-------------------------------------------------------------------------------

-- | Binary projective points.
type BPPoint = BPoint 'Projective

-- | Binary projective curves @y^2z + xyz = x^3 + Ax^2z + Bz@.
class BCurve 'Projective e q r => BPCurve e q r where
  {-# MINIMAL gP_ #-}
  gP_ :: BPPoint e q r -- ^ Curve generator.

-- Binary projective curves are elliptic curves.
instance BPCurve e q r => Curve 'Binary 'Projective e q r where

  data instance Point 'Binary 'Projective e q r = P q q q -- ^ Projective point.
    deriving (Generic, NFData, Read, Show)

  -- Addition formula add-2008-bl
  add  p           (P  _  _  0) = p
  add (P  _  _  0)  q           = q
  add (P x1 y1 z1) (P x2 y2 z2) = P x3 y3 z3
    where
      a'   = a_ (witness :: BPPoint e q r)
      y1z2 = y1 * z2
      x1z2 = x1 * z2
      a    = y1z2 + z1 * y2
      b    = x1z2 + z1 * x2
      ab   = a + b
      c    = b * b
      d    = z1 * z2
      e    = b * c
      f    = (a * ab + a' * c) * d + e
      x3   = b * f
      y3   = c * (a * x1z2 + b * y1z2) + ab * f
      z3   = e * d
  {-# INLINABLE add #-}

  char = const 2
  {-# INLINABLE char #-}

  cof = h_
  {-# INLINABLE cof #-}

  -- Doubling formula dbl-2008-bl
  dbl (P  _  _  0) = P  0  1  0
  dbl (P x1 y1 z1) = P x3 y3 z3
    where
      a' = a_ (witness :: BPPoint e q r)
      a  = x1 * x1
      b  = a + y1 * z1
      c  = x1 * z1
      bc = b + c
      d  = c * c
      e  = b * bc + a' * d
      x3 = c * e
      y3 = bc * e + a * a * c
      z3 = c * d
  {-# INLINABLE dbl #-}

  def (P x y z) = ((x + a * z) * x + yz) * x + y * yz + b * z * z * z == 0
    where
      a  = a_ (witness :: BPPoint e q r)
      b  = b_ (witness :: BPPoint e q r)
      yz = y * z
  {-# INLINABLE def #-}

  disc _ = b_ (witness :: BPPoint e q r)
  {-# INLINABLE disc #-}

  frob (P x y z) = P (F.frob x) (F.frob y) (F.frob z)
  {-# INLINABLE frob #-}

  fromA (A x y) = P x y 1
  fromA _       = P 0 1 0
  {-# INLINABLE fromA #-}

  gen = gP_
  {-# INLINABLE gen #-}

  id = P 0 1 0
  {-# INLINABLE id #-}

  inv (P x y z) = P x (x + y) z
  {-# INLINABLE inv #-}

  order = r_
  {-# INLINABLE order #-}

  point x y = let p = P x y 1 in if def p then Just p else Nothing
  {-# INLINABLE point #-}

  pointX x = flip (P x) 1 <$> yX (witness :: BPPoint e q r) x
  {-# INLINABLE pointX #-}

  toA (P _ _ 0) = O
  toA (P x y z) = A (x / z) (y / z)
  {-# INLINABLE toA #-}

  yX _ x = quad 1 x ((x + a) * x * x + b)
    where
      a = a_ (witness :: BPPoint e q r)
      b = b_ (witness :: BPPoint e q r)
  {-# INLINABLE yX #-}

-- Binary projective points are equatable.
instance BPCurve e q r => Eq (BPPoint e q r) where

  P x1 y1 z1 == P x2 y2 z2 = z1 == 0 && z2 == 0
    || x1 * z2 == x2 * z1 && y1 * z2 == y2 * z1
  {-# INLINABLE (==) #-}

-- Binary projective points are pretty.
instance BPCurve e q r => Pretty (BPPoint e q r) where

  pretty (P x y z) = pretty (x, y, z)