{-# LANGUAGE RebindableSyntax, ImplicitPrelude #-}
module Data.Q.Private (Q, Qp (..), fromQ, fromQp, toQ, toQp, frac, fracPos) where

import "base" Prelude (abs, fromRational, fromIntegral, negate, signum, toRational)
import qualified "base" Prelude as Base
import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import Text.Read (Read (..))
import Text.Show (Show (..))

import qualified Data.Ratio as Base

import Data.Difference (Difference (..))
import qualified Data.Difference as D
import Data.N  as N
import Data.Np as Np hiding (X0, X1, One)
import Data.Z        hiding (abs)
import qualified Data.Z as Z
import Data.Whole (isTopMoreInformative, isQuadraticTopMoreInformative)

data Qp = NR Qp
        | DL Qp
        | One
  deriving (Base.Eq)

instance PartialEq Qp where (≡) = (Base.==)
instance Preord Qp where x ≤ y = GT ≢ compare x y
instance Eq Qp
instance PartialOrd Qp where tryCompare x y = Just (compare x y)
instance Ord Qp where
    compare x y = case quadratic' 0 (1) (-1) 0 0 0 0 1 x y of
        Zero -> EQ
        Pos _ -> GT
        Neg _ -> LT
instance Base.Ord Qp where compare = compare

instance {-# OVERLAPPING #-} Semigroup (Sum Qp) where
    Sum x <> Sum y = Sum (quadraticPos 0 1 1 0 0 0 0 1 x y)

type Q = Difference Qp

instance Base.Num Q where
    (+) = quadratic 0 1 1 0 0 0 0 1
    (-) = quadratic 0 (1) (-1) 0 0 0 0 1
    (*) = quadratic 1 0 0 0 0 0 0 1
    abs = maybe Zero Pos . altMap Just
    signum = (One <$)
    negate = D.negate
    fromInteger = fromRational . Base.fromInteger

instance Base.Fractional Q where
    (/) = quadratic 0 1 0 0 0 0 1 0
    fromRational q = frac' (fromIntegral $ Base.numerator q) (fromIntegral $ Base.denominator q)

instance Base.Real Q where
    toRational Zero = 0
    toRational (Pos q) = id     . toRational $ fromQp q
    toRational (Neg q) = negate . toRational $ fromQp q

instance FromInteger Q where fromInteger = Base.fromInteger

toQ :: Base.Rational -> Q
toQ = fromRational

fromQ :: Q -> Base.Rational
fromQ = Base.toRational

toQp :: Base.Ratio Natural -> Qp
toQp q = fracPos' (fromIntegral $ Base.numerator q) (fromIntegral $ Base.denominator q)

fromQp :: Qp -> Base.Ratio Natural
fromQp One = 1
fromQp (NR q) = 1 + fromQp q
fromQp (DL q) = 1 / (1 + 1 / fromQp q)

fracPos :: Np -> Np -> Qp
fracPos x y = case Np.sub' x y of
    Zero -> One
    Neg z -> DL (fracPos x z)
    Pos z -> NR (fracPos z y)

fracPos' :: Z -> Z -> Qp
fracPos' x y = case compare x y of
    EQ -> One
    LT -> DL (fracPos' x (y - x))
    GT -> NR (fracPos' (x - y) y)

frac :: Z -> Np -> Q
frac Zero _ = Zero
frac (Pos n) d = Pos (fracPos n d)
frac (Neg n) d = Neg (fracPos n d)

frac' :: Z -> Z -> Q
frac' m n = fracPos' (abs m) (abs n) <$ m * n

homographicSign
 :: Z -> Z -> Z -> Z -> Qp
 -> (Z, ((Z, Z, Z, Z), Qp))
homographicSign a b c d p = case (p, o) of
    (NR q, Zero) -> homographicSign a (a + b) c (c + d) q
    (DL q, Zero) -> homographicSign (a + b) b (c + d) d q
    _ -> (signum o1 * signum o2, ((a, b, c, d), p))
  where
    o1 = outside [a, b]
    o2 = outside [c, d]
    o = bool 1 o1 (0 ≢ b) * bool 1 o2 (0 ≢ d)

homographic' :: Z -> Z -> Z -> Z -> Qp -> Q
homographic' a b c d p
  | a * d ≡ b * c = case d of
        Zero -> frac' a c
        _    -> frac' b d
  | otherwise = q <$ s'
  where
    (s', ((a', b', c', d'), p')) = homographicSign a b c d p
    q = homographicPos (Z.abs a') (Z.abs b') (Z.abs c') (Z.abs d') p'

homographic :: Z -> Z -> Z -> Z -> Q -> Q
homographic a b c d = \ case
    Zero -> frac' b d
    Pos p -> homographic' a b c d p
    Neg p -> homographic' (negate a) b (negate c) d p

homographicPos :: N -> N -> N -> N -> Qp -> Qp
homographicPos a b c d
  | a * d ≡ b * c = pure $ case d of
    Nul -> fracPos' (fromN a) (fromN c)
    _   -> fracPos' (fromN b) (fromN d)
  | otherwise = \ case
    One -> fracPos' (fromN $ a + b) (fromN $ c + d)
    p | Just (x, y) <- isTopMoreInformative a b c d -> NR (homographicPos x y c d p)
      | Just (x, y) <- isTopMoreInformative c d a b -> DL (homographicPos a b x y p)
    NR q -> homographicPos a (a + b) c (c + d) q
    DL q -> homographicPos (a + b) b (c + d) d q

quadraticSign
 :: Z -> Z -> Z -> Z -> Z -> Z -> Z -> Z
 -> Qp -> Qp
 -> (Z, ((Z, Z, Z, Z, Z, Z, Z, Z), (Qp, Qp)))
quadraticSign a b c d e f g h p q = case (p, q, o') of
    (_, One, _) ->
        let (s', ((a', b', c', d'), r')) = homographicSign (a + b) (c + d) (e + f) (g + h) p
        in (s', ((Zero, a', Zero, b', Zero, c', Zero, d'), (r', One)))
    (One, _, _) ->
        let (s', ((a', b', c', d'), r')) = homographicSign (a + c) (b + d) (e + g) (f + h) q
        in (s', ((Zero, Zero, a', b', Zero, Zero, c', d'), (One, r')))
    (NR xs, NR ys, Zero) -> quadraticSign
        a (a + b) (a + c) (a + b + c + d) e (e + f) (e + g) (e + f + g + h) xs ys
    (NR xs, DL ys, Zero) -> quadraticSign
        (a + b) b (a + b + c + d) (b + d) (e + f) f (e + f + g + h) (f + h) xs ys
    (DL xs, NR ys, Zero) -> quadraticSign
        (a + c) (a + b + c + d) c (c + d) (e + g) (e + f + g + h) g (g + h) xs ys
    (DL xs, DL ys, Zero) -> quadraticSign
        (a + b + c + d) (b + d) (c + d) d (e + f + g + h) (f + h) (g + h) h xs ys
    _ -> (signum o1 * signum o2, ((a, b, c, d, e, f, g, h), (p, q)))
  where
    o1 = outside [a, b, c, d]
    o2 = outside [e, f, g, h]
    o1' = Base.iterate ((-) <*> signum) o1 Base.!! 2
    o2' = Base.iterate ((-) <*> signum) o2 Base.!! 2
    o' = bool 1 o1' ((0, 0, 0) ≢ (b, c, d)) * bool 1 o2' ((0, 0, 0) ≢ (f, g, h))

quadratic' :: Z -> Z -> Z -> Z -> Z -> Z -> Z -> Z -> Qp -> Qp -> Q
quadratic' a b c d e f g h p q
  | quadraticSameRatiosPairwise a b c d e f g h = case (e, f, g) of
        (Zero, Zero, Zero) -> frac' d h
        (Zero, Zero, _)    -> frac' c g
        (Zero, _,    _)    -> frac' b f
        (_,    _,    _)    -> frac' a e
  | otherwise = r <$ s'
  where
    (s', ((a', b', c', d', e', f', g', h'), (p', q'))) = quadraticSign a b c d e f g h p q
    r = quadraticPos (Z.abs a') (Z.abs b') (Z.abs c') (Z.abs d') (Z.abs e') (Z.abs f') (Z.abs g') (Z.abs h') p' q'

quadratic :: Z -> Z -> Z -> Z -> Z -> Z -> Z -> Z -> Q -> Q -> Q
quadratic a b c d e f g h = curry $ \ case
    (Zero, t) -> homographic c d g h t
    (s, Zero) -> homographic b d f h s
    (Pos p, Pos q) -> blah id id p q
    (Pos p, Neg q) -> blah id negate p q
    (Neg p, Pos q) -> blah negate id p q
    (Neg p, Neg q) -> blah negate negate p q
  where blah φ χ = quadratic' ((φ . χ) a) (φ b) (χ c) d ((φ . χ) e) (φ f) (χ g) h

quadraticPos :: N -> N -> N -> N -> N -> N -> N -> N -> Qp -> Qp -> Qp
quadraticPos a b c d e f g h
  | quadraticSameRatiosPairwise a b c d e f g h = curry . pure $ case (e, f, g) of
    (Nul, Nul, Nul) -> fracPos' (fromN d) (fromN h)
    (Nul, Nul, _)   -> fracPos' (fromN c) (fromN g)
    (Nul, _,   _)   -> fracPos' (fromN b) (fromN f)
    (_,   _,   _)   -> fracPos' (fromN a) (fromN e)
  | otherwise = curry $ \ case
    (One, q) -> homographicPos (a + c) (b + d) (e + g) (f + h) q
    (p, One) -> homographicPos (a + b) (c + d) (e + f) (g + h) p
    (p, q)
      | Just (w, x, y, z) <- isQuadraticTopMoreInformative a b c d e f g h -> NR
        (quadraticPos w x y z e f g h p q)
      | Just (w, x, y, z) <- isQuadraticTopMoreInformative e f g h a b c d -> DL
        (quadraticPos a b c d w x y z p q)
    (NR xs, NR ys) -> quadraticPos
        a (a + b) (a + c) (a + b + c + d) e (e + f) (e + g) (e + f + g + h) xs ys
    (NR xs, DL ys) -> quadraticPos
        (a + b) b (a + b + c + d) (b + d) (e + f) f (e + f + g + h) (f + h) xs ys
    (DL xs, NR ys) -> quadraticPos
        (a + c) (a + b + c + d) c (c + d) (e + g) (e + f + g + h) g (g + h) xs ys
    (DL xs, DL ys) -> quadraticPos
        (a + b + c + d) (b + d) (c + d) d (e + f + g + h) (f + h) (g + h) h xs ys

quadraticSameRatiosPairwise
 :: (Eq a, Semigroup (Product a)) => a -> a -> a -> a -> a -> a -> a -> a -> Bool
quadraticSameRatiosPairwise a b c d e f g h =
    sameRatiosPairwise [(a, e), (b, f), (c, g), (d, h)]

sameRatiosPairwise
 :: (Eq a, Semigroup (Product a)) => [(a, a)] -> Bool
sameRatiosPairwise xs = Base.and [a₁ × b₂ ≡ a₂ × b₁ | (a₁, b₁) <- xs, (a₂, b₂) <- xs]

instance Show Qp where
    show = \ case
        One -> ""
        DL p' -> 'L':show p'
        NR p' -> 'R':show p'

instance {-# OVERLAPPING #-} Show Q where
    show = \ case
        Zero -> "0"
        Pos p' -> '+':show p'
        Neg p' -> '-':show p'

instance Read Qp where
    readPrec = ReadPrec.lift $
        foldr id One <$> many (DL <$ ReadP.char 'L' <|> NR <$ ReadP.char 'R')

instance Read Q where
    readPrec = ReadPrec.readP_to_Prec $ \ prec ->
        Zero <$ ReadP.char '0' <|>
        fromMaybe Pos <$> optional (Neg <$ ReadP.char '-' <|> Pos <$ ReadP.char '+')
                       <*> ReadPrec.readPrec_to_P readPrec prec