packages feed

cf 0.4.1 → 0.4.2

raw patch · 3 files changed

+189/−165 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

+ Math.ContinuedFraction.Interval: doTricky :: Ord a => Interval a -> Interval a -> Interval a
+ Math.ContinuedFraction.Interval: interval :: Ord a => Extended a -> Extended a -> Interval a
- Math.ContinuedFraction.Interval: Interval :: (Extended a) -> (Extended a) -> Interval a
+ Math.ContinuedFraction.Interval: Interval :: (Extended a) -> (Extended a) -> Bool -> Interval a

Files

cf.cabal view
@@ -1,5 +1,5 @@ name:                cf-version:             0.4.1+version:             0.4.2 synopsis:            Exact real arithmetic using continued fractions license:             MIT    license-file:        LICENSE@@ -23,7 +23,7 @@   exposed-modules: Math.ContinuedFraction,                    Math.ContinuedFraction.Simple,                    Math.ContinuedFraction.Interval-  build-depends:       base >= 4 && < 5+  build-depends:       base >= 4.4 && < 5   default-language:    Haskell2010  test-suite tests
src/Math/ContinuedFraction.hs view
@@ -30,22 +30,35 @@ class (Fractional (FractionField a)) => HasFractionField a where   type FractionField a :: *   insert :: a -> FractionField a+  frac :: (a, a) -> FractionField a   extract :: FractionField a -> (a, a)  instance HasFractionField Integer where   type FractionField Integer = Rational   insert = fromInteger+  {-# INLINE insert #-}+  frac = uncurry (%)+  {-# INLINE frac #-}   extract r = (numerator r, denominator r)+  {-# INLINE extract #-}  instance HasFractionField Rational where   type FractionField Rational = Rational   insert = id+  {-# INLINE insert #-}+  frac = uncurry (/)+  {-# INLINE frac #-}   extract r = (numerator r % 1, denominator r % 1)+  {-# INLINE extract #-}  instance HasFractionField CF where   type FractionField CF = CF   insert = id+  {-# INLINE insert #-}+  frac = uncurry (/)+  {-# INLINE frac #-}   extract r = (r, 1)+  {-# INLINE extract #-}  homEmit :: Num a => Hom a -> a -> Hom a homEmit (n0, n1,@@ -61,15 +74,16 @@ det (n0, n1,      d0, d1) = n0 * d1 - n1 * d0 -homEval :: (Num a, HasFractionField a, Eq (FractionField a)) => Hom a -> Extended (FractionField a) -> Extended (FractionField a)+homEval :: (Eq a, Num a, HasFractionField a) => Hom a -> Extended (FractionField a) -> Extended (FractionField a) homEval (n0, n1,-         d0, d1) (Finite q) | denom /= 0 = Finite $ num / denom+         d0, d1) (Finite q) | denom /= 0 = Finite $ frac (num, denom)                             | num == 0 = error "0/0 in homQ"                             | otherwise = Infinity-  where num   = insert n0 * q + insert n1-        denom = insert d0 * q + insert d1+  where (qnum, qdenom) = extract q+        num   = n0 * qnum + n1 * qdenom+        denom = d0 * qnum + d1 * qdenom homEval (n0, _n1,-         d0, _d1) Infinity = Finite $ insert n0 / insert d0+         d0, _d1) Infinity = Finite $ frac (n0, d0)  constantFor :: (Eq a, Num a, HasFractionField a) => Hom a -> Extended (FractionField a) constantFor (_, _,@@ -79,29 +93,30 @@ constantFor (0, 0,              _, 0) = Finite 0 constantFor (a, 0,-             b, 0) = Finite (insert a / insert b)+             b, 0) = Finite $ frac (a, b) constantFor (_, a,-             _, b) = Finite (insert a / insert b)+             _, b) = Finite $ frac (a, b) -boundHom :: (Ord a, Num a, HasFractionField a, Eq (FractionField a)) => Hom a -> Interval (FractionField a) -> Interval (FractionField a)-boundHom h (Interval i s) | det h > 0 = Interval i' s'-                          | det h < 0 = Interval s' i'-                          | otherwise = Interval c c-  where i' = homEval h i+boundHom :: (Ord a, Num a, HasFractionField a, Ord (FractionField a)) => Hom a -> Interval (FractionField a) -> Interval (FractionField a)+boundHom h (Interval i s _) | d > 0 = interval i' s'+                            | d < 0 = interval s' i'+                            | otherwise = Interval c c True+  where d = det h+        i' = homEval h i         s' = homEval h s         c = constantFor h  primitiveBound :: forall a. (Ord a, Num a, HasFractionField a) => a -> Interval (FractionField a)-primitiveBound n | abs n < 1 = Interval (Finite $ insert bot) (Finite $ insert top)+primitiveBound n | abs n < 1 = Interval (Finite $ insert bot) (Finite $ insert top) True   where bot = (-2) :: a         top = 2 :: a-primitiveBound n = Interval (Finite $ an - 0.5) (Finite $ 0.5 - an)+primitiveBound n = Interval (Finite $ an - 0.5) (Finite $ 0.5 - an) False   where an = insert $ abs n  -- TODO: just take the rational answer from the hom-nthPrimitiveBounds :: (Ord a, Num a, HasFractionField a, Eq (FractionField a)) =>+nthPrimitiveBounds :: (Ord a, Num a, HasFractionField a, Ord (FractionField a)) =>                        CF' a -> [Interval (FractionField a)]-nthPrimitiveBounds (CF cf) = zipWith boundHom homs (map primitiveBound cf) ++ repeat (Interval ev ev)+nthPrimitiveBounds (CF cf) = zipWith boundHom homs (map primitiveBound cf) ++ repeat (Interval ev ev True)   where homs = scanl homAbsorb (1,0,0,1) cf         ev = evaluate (CF cf) @@ -121,34 +136,25 @@                 let (CF ds)  = valueToCF (recip rest) in CF (d:ds)   where (d, rest) = properFraction r -intervalThin :: (RealFrac a) => Interval a -> Bool-intervalThin (Interval Infinity    Infinity)  = False-intervalThin (Interval Infinity   (Finite _)) = False-intervalThin (Interval (Finite _)  Infinity)  = False-intervalThin (Interval (Finite i) (Finite s)) = abs z > 3 || abs (zi - zs) < 2-  where zi = round i-        zs = round s-        z  = if abs zs < abs zi then zs else zi -euclideanPart :: (RealFrac a, Integral b) => Interval a -> Maybe b-euclideanPart (Interval Infinity    Infinity)  = undefined-euclideanPart (Interval Infinity   (Finite b)) = Just $ floor b-euclideanPart (Interval (Finite a)  Infinity)  = Just $ ceiling a-euclideanPart i@(Interval (Finite a) (Finite b))-  | 0 `elementOf` i && not subsetZero = Nothing+existsEmittable :: (RealFrac a, Integral b) => Interval a -> Maybe b+existsEmittable (Interval Infinity    Infinity _)  = Nothing+existsEmittable (Interval Infinity   (Finite _) _) = Nothing+existsEmittable (Interval (Finite _)  Infinity _)  = Nothing+existsEmittable int@(Interval (Finite a) (Finite b) _) = euclideanCheck int a b++euclideanCheck :: (Num a, Ord a, RealFrac a, Integral b) => Interval a -> a -> a -> Maybe b+euclideanCheck int a b+  | not isThin = Nothing+  | 0 `elementOf` int && not subsetZero = Nothing   | zi /= 0 && zs /= 0 = Just z   | subsetZero = Just 0   | otherwise = Nothing     where zi = round a           zs = round b           z  = if abs zs < abs zi then zs else zi-          subsetZero = i `subset` Interval (Finite (-2)) (Finite 2)--existsEmittable :: RealFrac a => Interval a -> Maybe Integer-existsEmittable i = if intervalThin i then-                      euclideanPart i-                    else-                      Nothing+          isThin = abs z > 3 || abs (zi - zs) < 2+          subsetZero = int `subset` Interval (Finite (-2)) (Finite 2) True  hom :: (Ord a, Num a, HasFractionField a, RealFrac (FractionField a)) => Hom a -> CF' a -> CF hom (_n0, _n1,@@ -156,7 +162,7 @@ hom (_n0, _n1,      0,   _d1) (CF []) = CF [] hom (n0, _n1,-     d0, _d1) (CF []) = valueToCF (insert n0 / insert d0)+     d0, _d1) (CF []) = valueToCF $ frac (n0, d0) hom h (CF (x:xs)) = case existsEmittable $ boundHom h (primitiveBound x) of                      Just n ->  CF $ n : rest                        where (CF rest) = hom (homEmit h (fromInteger n)) (CF (x:xs))@@ -195,35 +201,30 @@                   d0, d1, _d2, _d3) Infinity = (n0, n1,                                                 d0, d1) -boundBihom :: (Ord a, Num a, HasFractionField a, Eq (FractionField a), Ord (FractionField a)) =>-              Bihom a -> Interval (FractionField a) -> Interval (FractionField a) -> Interval (FractionField a)-boundBihom bh x@(Interval ix sx) y@(Interval iy sy) = r1 `mergeInterval` r2 `mergeInterval` r3 `mergeInterval` r4-  where r1 = boundHom (bihomSubstituteX bh ix) y-        r2 = boundHom (bihomSubstituteY bh iy) x-        r3 = boundHom (bihomSubstituteX bh sx) y-        r4 = boundHom (bihomSubstituteY bh sy) x--select :: (Ord a, Num a, HasFractionField a, Eq (FractionField a), Ord (FractionField a)) =>-          Bihom a -> Interval (FractionField a) -> Interval (FractionField a) -> Bool-select bh x@(Interval ix sx) y@(Interval iy sy) = intX `smallerThan` intY-  where intX = if r1 `smallerThan` r2 then r2 else r1-        intY = if r3 `smallerThan` r4 then r4 else r3-        r1 = boundHom (bihomSubstituteX bh ix) y-        r2 = boundHom (bihomSubstituteX bh sx) y-        r3 = boundHom (bihomSubstituteY bh iy) x-        r4 = boundHom (bihomSubstituteY bh sy) x+boundBihomAndSelect :: (Ord a, Num a, HasFractionField a, Eq (FractionField a), Ord (FractionField a)) =>+              Bihom a -> Interval (FractionField a) -> Interval (FractionField a) -> (Interval (FractionField a), Bool)+boundBihomAndSelect bh x@(Interval ix sx _) y@(Interval iy sy _) = (interval, intX `smallerThan` intY)+  where interval = ixy `mergeInterval` iyx `mergeInterval` sxy `mergeInterval` syx+        ixy = boundHom (bihomSubstituteX bh ix) y+        iyx = boundHom (bihomSubstituteY bh iy) x+        sxy = boundHom (bihomSubstituteX bh sx) y+        syx = boundHom (bihomSubstituteY bh sy) x+        intX = if ixy `smallerThan` sxy then sxy else ixy+        intY = if iyx `smallerThan` syx then syx else iyx  bihom :: (Ord a, Num a, HasFractionField a, RealFrac (FractionField a))          => Bihom a -> CF' a -> CF' a -> CF bihom bh (CF []) y = hom (bihomSubstituteX bh Infinity) y bihom bh x (CF []) = hom (bihomSubstituteY bh Infinity) x-bihom bh (CF (x:xs)) (CF (y:ys)) = case existsEmittable $ boundBihom bh (primitiveBound x) (primitiveBound y) of-                   Just n -> CF $ n : rest-                     where (CF rest) = bihom (bihomEmit bh (fromInteger n)) (CF (x:xs)) (CF (y:ys))-                   Nothing -> if select bh (primitiveBound x) (primitiveBound y) then-                                let bh' = bihomAbsorbX bh x in bihom bh' (CF xs) (CF (y:ys))-                              else-                                let bh' = bihomAbsorbY bh y in bihom bh' (CF (x:xs)) (CF ys)+bihom bh (CF (x:xs)) (CF (y:ys)) =+  let (bound, which) = boundBihomAndSelect bh (primitiveBound x) (primitiveBound y) in+  case existsEmittable bound of+    Just n -> CF $ n : rest+      where (CF rest) = bihom (bihomEmit bh (fromInteger n)) (CF (x:xs)) (CF (y:ys))+    Nothing -> if which then+                 let bh' = bihomAbsorbX bh x in bihom bh' (CF xs) (CF (y:ys))+               else+                 let bh' = bihomAbsorbY bh y in bihom bh' (CF (x:xs)) (CF ys)  homchain :: [Hom Integer] -> CF homchain (h:h':hs) = case quotEmit h of@@ -307,10 +308,11 @@  instance RealFrac CF where   properFraction cf = head $ mapMaybe checkValid $ nthPrimitiveBounds cf-    where checkValid (Interval (Finite a) (Finite b)) = if a <= b && truncate a == truncate b then-                                                          Just (truncate a, cf - fromInteger (truncate a))-                                                        else-                                                          Nothing+    where checkValid (Interval (Finite a) (Finite b) True) =+            if truncate a == truncate b then+              Just (truncate a, cf - fromInteger (truncate a))+            else+              Nothing           checkValid _ = Nothing  -- | Convert a continued fraction whose terms are continued fractions
src/Math/ContinuedFraction/Interval.hs view
@@ -6,10 +6,10 @@  data Extended a = Finite a | Infinity deriving (Eq) -data Interval a = Interval (Extended a) (Extended a) 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 ++ ")"+  show (Interval a b _) = "(" ++ showE a ++ ", " ++ showE b ++ ")"     where showE Infinity = "Infinity"           showE (Finite r) = show (fromRat r) @@ -41,123 +41,145 @@   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) = i2 > s2-Interval (Finite _) Infinity `smallerThan` Interval (Finite i2) (Finite s2) = i2 > s2--- TODO: cache some of these comparisons-Interval (Finite i1) (Finite s1) `smallerThan` Interval (Finite i2) (Finite s2)-  =    (i1 <= s1 && i2 <= s2 && s1 - i1 <= s2 - i2)-    || (i1 >  s1 && i2 >  s2 && i1 - s1 >= i2 - s2)-    || (i1 <= s1 && i2 >  s2)+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) `comparePosition` Interval (Finite i2) (Finite s2)-  | i1 > s1 = Nothing-  | i2 > s2 = Nothing+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)) = if i <= s && floor i == floor s && floor i >= 0 then-                                                   Just $ floor i-                                                 else-                                                   Nothing+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) `subset` Interval Infinity (Finite s2)-  | i1 <= s1 && s1 <= s2 = True-  | otherwise            = False-Interval (Finite i1) (Finite s1) `subset` Interval (Finite i2) Infinity-  | i1 <= s1 && i2 <= i1 = True+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 Infinity (Finite s1) `subset` Interval (Finite i2) (Finite s2)-  | i2 > s2 && s1 <= s2 = True+Interval (Finite i1) (Finite s1) False `subset` Interval (Finite i2) (Finite s2) False+  | i2 <= i1 && s1 <= s2 = True   | otherwise            = False-Interval (Finite i1) Infinity `subset` Interval (Finite i2) (Finite s2)-  | i2 > s2 && i2 <= i1 = True+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) `subset` Interval (Finite i2) (Finite s2)-  | i1 <= s1 && i2 <= s2 &&-    i2 <= i1 && s1 <= s2     = True-  | s1 <  i1 && s2 <  i2 &&-    i2 <= i1 && s1 <= s2     = True-  | i1 <= s1 && s2 <  i2 &&-    i2 <= i1 && i2 <= s1     = True-  | i1 <= s1 && s2 <  i2 &&-    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))-  | i <= s = i <= x && x <= s-  | i >  s = i <= x || x <= s-  | otherwise = error "The impossible happened in elementOf"+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-mergeInterval (Interval (Finite i) Infinity) (Interval Infinity Infinity)-  = Interval Infinity Infinity-mergeInterval (Interval Infinity (Finite s)) (Interval Infinity Infinity)-  = Interval Infinity Infinity-mergeInterval (Interval (Finite i) (Finite s)) (Interval Infinity Infinity)-  = Interval Infinity Infinity-mergeInterval (Interval Infinity (Finite s)) (Interval (Finite i) Infinity)-  | s >= i    = Interval Infinity Infinity-  | otherwise = Interval (Finite i) (Finite s)-mergeInterval (Interval Infinity (Finite s1)) (Interval Infinity (Finite s2))-  = Interval Infinity (Finite $ max s1 s2)-mergeInterval (Interval (Finite i1) Infinity) (Interval (Finite i2) Infinity)-  = Interval Infinity (Finite $ min i1 i2)-mergeInterval (Interval (Finite i1) (Finite s1)) (Interval (Finite i2) Infinity)-  | i1 <= s1 = Interval (Finite $ min i1 i2) Infinity-  | i1 >  s1 && i1 <= i2 = Interval (Finite i1) (Finite s1)-  | i1 >  s1 && i2 <= s1 = Interval Infinity Infinity-  | i1 >  s1 && i2 >  s1 = Interval (Finite i2) (Finite s1)-mergeInterval (Interval (Finite i1) (Finite s1)) (Interval Infinity (Finite s2))-  | i1 <= s1 = Interval Infinity (Finite $ max s1 s2)-  | i1 >  s1 && s2 <= s1 = Interval (Finite i1) (Finite s1)-  | i1 >  s1 && i1 <= s2 = Interval Infinity Infinity-  | i1 >  s1 && i1 >  s2 = Interval (Finite i1) (Finite s2)-mergeInterval int1@(Interval (Finite i1) (Finite s1)) int2@(Interval (Finite i2) (Finite s2))-  | i1 <= s1 && i2 <= s2 = Interval (Finite $ min i1 i2) (Finite $ max s1 s2)-  | i1 >  s1 && i2 >  s2 && (i1 <= s2 || i2 <= s1) = Interval Infinity Infinity-  | i1 >  s1 && i2 >  s2 = Interval (Finite $ min i1 i2) (Finite $ max s1 s2)-  | i1 >  s1 && i2 <= s2 = doTricky int2 int1-  | i1 <= s1 && i2 >  s2 = doTricky int1 int2-  | otherwise = error "The impossible happened in mergeInterval"-  where doTricky int1@(Interval (Finite i1) (Finite s1)) int2@(Interval (Finite i2) (Finite s2))+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-          | s1 < i2  = Interval (Finite i2) (Finite s1)-          | s2 < i1  = Interval (Finite i1) (Finite s2)+          | 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"-mergeInterval int1 int2 = mergeInterval int2 int1