```{-# LANGUAGE FlexibleInstances #-}
module Math.ContinuedFraction.Interval where

import Data.Ratio
import Numeric

data Extended a = Finite a | Infinity deriving (Eq)

data Interval a = Interval (Extended a) (Extended a) Bool deriving (Eq)

instance Show (Interval Rational) where
show (Interval a b _) = "(" ++ showE a ++ ", " ++ showE b ++ ")"
where showE Infinity = "Infinity"
showE (Finite r) = show (fromRat r)

instance Num a => Num (Extended a) where
Finite a + Finite b = Finite (a + b)
Infinity + Finite _ = Infinity
Finite _ + Infinity = Infinity
Infinity + Infinity = error "Infinity + Infinity"

Finite a * Finite b = Finite (a * b)
Infinity * Finite a = Infinity
-- Infinity * Finite a | a == 0 = error "Infinity * 0"
--                     | otherwise = Infinity
Finite a * i = i * Finite a
Infinity * Infinity = undefined "Infinity * Infinity"

negate (Finite r) = Finite (-r)
negate Infinity = Infinity

signum (Finite r) = Finite \$ signum r
signum Infinity = error "signum Infinity"

abs (Finite r) = Finite \$ abs r
abs Infinity = Infinity

fromInteger = Finite . fromInteger

instance (Show a) => Show (Extended a) where
show (Finite r) = show r
show Infinity = "Infinity"

interval :: Ord a => Extended a -> Extended a -> Interval a
interval (Finite i) (Finite s) = Interval (Finite i) (Finite s) (i <= s)
interval i s = Interval i s True
{-# INLINE interval #-}

smallerThan :: (Num a, Ord a) => Interval a -> Interval a -> Bool
Interval _ _ _ `smallerThan` Interval Infinity Infinity _ = False -- TODO CHECK
Interval Infinity Infinity _ `smallerThan` Interval _ _ _ = True
Interval (Finite a) Infinity _ `smallerThan` Interval (Finite b) Infinity _ = a >= b
Interval (Finite a) Infinity _ `smallerThan` Interval Infinity (Finite b) _ = a >= -b
Interval Infinity (Finite a) _ `smallerThan` Interval (Finite b) Infinity _ = a <= -b
Interval Infinity (Finite a) _ `smallerThan` Interval Infinity (Finite b) _ = a <= b
Interval (Finite i1) (Finite s1) _ `smallerThan` Interval Infinity (Finite _) _ = i1 <= s1
Interval (Finite i1) (Finite s1) _ `smallerThan` Interval (Finite _) Infinity _ = i1 <= s1
Interval Infinity (Finite _) _ `smallerThan` Interval (Finite i2) (Finite s2) False = True
Interval (Finite _) Infinity _ `smallerThan` Interval (Finite i2) (Finite s2) False = True
Interval Infinity (Finite _) _ `smallerThan` Interval (Finite i2) (Finite s2) True = False
Interval (Finite _) Infinity _ `smallerThan` Interval (Finite i2) (Finite s2) True = False
Interval (Finite i1) (Finite s1) True `smallerThan` Interval (Finite i2) (Finite s2) True
= s1 - i1 <= s2 - i2
Interval (Finite i1) (Finite s1) False `smallerThan` Interval (Finite i2) (Finite s2) False
= i1 - s1 >= i2 - s2
Interval (Finite i1) (Finite s1) True `smallerThan` Interval (Finite i2) (Finite s2) False
= True
Interval (Finite i1) (Finite s1) False `smallerThan` Interval (Finite i2) (Finite s2) True
= False

epsilon :: Rational
epsilon = 1 % 10^10

comparePosition :: Interval Rational -> Interval Rational -> Maybe Ordering
Interval (Finite i1) (Finite s1) True `comparePosition` Interval (Finite i2) (Finite s2) True
| s1 < i2 = Just LT
| s2 < i1 = Just GT
| (s1 - i1) < epsilon && (s2 - i2) < epsilon = Just EQ
_ `comparePosition` _ = Nothing

intervalDigit :: (RealFrac a) => Interval a -> Maybe Integer
intervalDigit (Interval (Finite i) (Finite s) True) =
if floor i == floor s && floor i >= 0 then
Just \$ floor i
else
Nothing
intervalDigit _ = Nothing

subset :: Ord a => Interval a -> Interval a -> Bool
Interval _ _ _ `subset` Interval Infinity Infinity _ = True
Interval Infinity Infinity _ `subset` Interval _ _ _ = False
Interval Infinity (Finite s1) _ `subset` Interval Infinity (Finite s2) _ = s1 <= s2
Interval (Finite i1) Infinity _ `subset` Interval (Finite i2) Infinity _ = i1 >= i2
Interval Infinity (Finite _) _ `subset` Interval (Finite _) Infinity _ = False
Interval (Finite _) Infinity _ `subset` Interval Infinity (Finite _) _ = False
Interval (Finite i1) (Finite s1) True `subset` Interval Infinity (Finite s2) _
| s1 <= s2  = True
| otherwise = False
Interval (Finite i1) (Finite s1) False `subset` Interval Infinity (Finite s2) _
= False
Interval (Finite i1) (Finite s1) True `subset` Interval (Finite i2) Infinity _
| i2 <= i1  = True
| otherwise = False
Interval (Finite i1) (Finite s1) False `subset` Interval (Finite i2) Infinity _
= False
Interval Infinity (Finite s1) _ `subset` Interval (Finite i2) (Finite s2) False
| s1 <= s2  = True
| otherwise = False
Interval Infinity (Finite s1) _ `subset` Interval (Finite i2) (Finite s2) True
= False
Interval (Finite i1) Infinity _ `subset` Interval (Finite i2) (Finite s2) False
| i2 <= i1  = True
| otherwise = False
Interval (Finite i1) Infinity _ `subset` Interval (Finite i2) (Finite s2) True
= False
Interval (Finite i1) (Finite s1) True `subset` Interval (Finite i2) (Finite s2) True
| i2 <= i1 && s1 <= s2 = True
| otherwise            = False
Interval (Finite i1) (Finite s1) False `subset` Interval (Finite i2) (Finite s2) False
| i2 <= i1 && s1 <= s2 = True
| otherwise            = False
Interval (Finite i1) (Finite s1) True `subset` Interval (Finite i2) (Finite s2) False
| i2 <= i1 && i2 <= s1 = True
| i1 <= s2 && s1 <= s2 = True
| otherwise            = False
Interval (Finite i1) (Finite s1) False `subset` Interval (Finite i2) (Finite s2) True
= False

elementOf :: (Ord a) => Extended a -> Interval a -> Bool
Infinity `elementOf` (Interval Infinity Infinity _) = True
(Finite _) `elementOf` (Interval Infinity Infinity _) = True
Infinity `elementOf` (Interval (Finite _) Infinity _) = True
(Finite x) `elementOf` (Interval (Finite a) Infinity _) = x >= a
Infinity `elementOf` (Interval Infinity (Finite _) _) = True
(Finite x) `elementOf` (Interval Infinity (Finite b) _) = x <= b
Infinity `elementOf` (Interval (Finite i) (Finite s) _) = i > s
(Finite x) `elementOf` (Interval (Finite i) (Finite s) True) = i <= x && x <= s
(Finite x) `elementOf` (Interval (Finite i) (Finite s) False) = i <= x || x <= s

-- Here we interpret Interval Infinity Infinity as the whole real line
mergeInterval :: (Ord a) => Interval a -> Interval a -> Interval a
mergeInterval (Interval Infinity Infinity _) (Interval Infinity Infinity _)
= Interval Infinity Infinity True
mergeInterval (Interval (Finite i) Infinity _) (Interval Infinity Infinity _)
= Interval Infinity Infinity True
mergeInterval (Interval Infinity (Finite s) _) (Interval Infinity Infinity _)
= Interval Infinity Infinity True
mergeInterval (Interval (Finite i) (Finite s) _) (Interval Infinity Infinity _)
= Interval Infinity Infinity True
mergeInterval (Interval Infinity (Finite s) _) (Interval (Finite i) Infinity _)
| s >= i    = Interval Infinity Infinity True
| otherwise = Interval (Finite i) (Finite s) False
mergeInterval (Interval Infinity (Finite s1) _) (Interval Infinity (Finite s2) _)
= Interval Infinity (Finite \$ max s1 s2) True
mergeInterval (Interval (Finite i1) Infinity _) (Interval (Finite i2) Infinity _)
= Interval Infinity (Finite \$ min i1 i2) True
mergeInterval (Interval (Finite i1) (Finite s1) True) (Interval (Finite i2) Infinity _)
= Interval (Finite \$ min i1 i2) Infinity True
mergeInterval (Interval (Finite i1) (Finite s1) False) (Interval (Finite i2) Infinity _)
| i1 <= i2 = Interval (Finite i1) (Finite s1) False
| i2 <= s1 = Interval Infinity Infinity True
| i2 >  s1 = Interval (Finite i2) (Finite s1) False
mergeInterval (Interval (Finite i1) (Finite s1) True) (Interval Infinity (Finite s2) _)
= Interval Infinity (Finite \$ max s1 s2) True
mergeInterval (Interval (Finite i1) (Finite s1) False) (Interval Infinity (Finite s2) _)
| s2 <= s1 = Interval (Finite i1) (Finite s1) False
| i1 <= s2 = Interval Infinity Infinity True
| i1 >  s2 = Interval (Finite i1) (Finite s2) False
mergeInterval (Interval (Finite i1) (Finite s1) True) (Interval (Finite i2) (Finite s2) True)
= Interval (Finite \$ min i1 i2) (Finite \$ max s1 s2) True
mergeInterval (Interval (Finite i1) (Finite s1) False) (Interval (Finite i2) (Finite s2) False)
| (i1 <= s2 || i2 <= s1) = Interval Infinity Infinity True
| otherwise              = Interval (Finite \$ min i1 i2) (Finite \$ max s1 s2) False
mergeInterval int1@(Interval (Finite i1) (Finite s1) True) int2@(Interval (Finite i2) (Finite s2) False)
= doTricky int1 int2
mergeInterval int1@(Interval (Finite i1) (Finite s1) False) int2@(Interval (Finite i2) (Finite s2) True)
= doTricky int2 int1
mergeInterval int1 int2 = mergeInterval int2 int1

doTricky int1@(Interval (Finite i1) (Finite s1) True) int2@(Interval (Finite i2) (Finite s2) False)
| int1 `subset` int2         = int2
| i2 <= s1 && i1 <= s2       = Interval Infinity Infinity True
| s1 < i2  = Interval (Finite i2) (Finite s1) False
| s2 < i1  = Interval (Finite i1) (Finite s2) False
| otherwise = error "The impossible happened in mergeInterval"
```