{-# 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