content: {-# LANGUAGE CPP #-}
  module Intervals(VSetInteger, vEmpty, vSing, vFromTo, vGetSing,
                  vCompRange, vUnion, vIntersect, vNull) where
  
  #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804)
  import Prelude hiding ((<>))
  #endif
  
  import PPrint
  
  
  data IVal = IVal Integer Integer
      deriving (Show, Eq)
  
  instance PPrint IVal where
      pPrint d _ (IVal l h) =
          if l == h then
              text "[" <> pPrint d 0 l <> text "]"
          else
              text "[" <> pPrint d 0 l <> text ".." <> pPrint d 0 h <> text "]"
  
  -- A set of values is represented as a list of ordered, non-overlapping intervals
  newtype VSetInteger = VSet [IVal]
      deriving (Show, Eq)
  
  instance PPrint VSetInteger where
      pPrint d p (VSet is) = pPrint d p is
  
  vNull :: VSetInteger -> Bool
  vNull (VSet xs) = null xs -- only if no empty or [h,l] intervals
  
  vEmpty :: VSetInteger
  vEmpty = VSet []
  
  -- Complement within a range
  vCompRange :: Integer -> Integer -> VSetInteger -> VSetInteger
  vCompRange lo hi (VSet [])  = VSet [IVal lo hi]
  vCompRange lo hi (VSet is)  = foldr1 vIntersect (map (vCompRangeI lo hi) is)
  
  vCompRangeI :: Integer -> Integer -> IVal -> VSetInteger
  vCompRangeI lo hi (IVal l h)    = VSet [IVal lo (l-1), IVal (h+1) hi]
  
  vSing :: Integer -> VSetInteger
  vSing i = VSet [IVal i i]
  
  vGetSing :: VSetInteger -> Maybe Integer
  vGetSing (VSet [IVal i i']) | i == i' = Just i
  vGetSing _ = Nothing
  
  vFromTo ::  Integer -> Integer -> VSetInteger
  vFromTo i j = VSet [IVal i j]
  
  
  vUnionI :: IVal -> VSetInteger -> VSetInteger
  vUnionI (IVal l h) (VSet is) = VSet (add l h is)
    where add l h [] = [IVal l h]
          add l h (i@(IVal vl vh) : is) =
                  if vl <= l then
                      if vh < l then
                          coal (i : add l h is)        -- (l,h) above i
                      else if vh < h then
                          add vl h is                -- (l,h) overlaps i
                      else
                          i : is                        -- (l,h) contained in i
                  else if vl > h then
                          coal (IVal l h : i : is)-- (l,h) below i
                  else
                      if vh <= h then
                          add l h is                -- (l,h) contains i
                      else
                          add l vh is                -- (l,h) overlaps i
          coal (IVal l1 h1 : IVal l2 h2 : is) | h1+1 == l2 = IVal l1 h2 : is
          coal is = is
  
  vUnion :: VSetInteger -> VSetInteger -> VSetInteger
  vUnion (VSet is) vs = foldr vUnionI vs is
  
  vIntersectI :: IVal -> VSetInteger -> VSetInteger
  vIntersectI (IVal l h) (VSet is) = VSet (sub l h is)
    where sub l h [] = []
          sub l h (i@(IVal vl vh) : is) =
                  if vl <= l then
                      if vh < l then
                          sub l h is                -- (l,h) above i
                      else if vh < h then
                          IVal l vh : sub l h is        -- (l,h) overlaps i
                      else
                          [IVal l h]                -- (l,h) contained in i
                  else if vl > h then
                          []
                  else
                      if vh <= h then
                          i : sub l h is                -- (l,h) contains i
                      else
                          [IVal vl h]                -- (l,h) overlaps i
  
  vIntersect :: VSetInteger -> VSetInteger -> VSetInteger
  vIntersect (VSet is) vs = foldr (\ i -> vUnion (vIntersectI i vs)) vEmpty is
  