diff --git a/cf.cabal b/cf.cabal
--- a/cf.cabal
+++ b/cf.cabal
@@ -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
diff --git a/src/Math/ContinuedFraction.hs b/src/Math/ContinuedFraction.hs
--- a/src/Math/ContinuedFraction.hs
+++ b/src/Math/ContinuedFraction.hs
@@ -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
diff --git a/src/Math/ContinuedFraction/Interval.hs b/src/Math/ContinuedFraction/Interval.hs
--- a/src/Math/ContinuedFraction/Interval.hs
+++ b/src/Math/ContinuedFraction/Interval.hs
@@ -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