-----------------------------------------------------------------------------
-- Copyright 2010, Open Universiteit Nederland. This file is distributed 
-- under the terms of the GNU General Public License. For more information, 
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- Support for mathematical intervals (open, closed, unbounded). @Intervals@
-- is a normalized (and sorted) list of intervals that supports testing for
-- equality.
--
-----------------------------------------------------------------------------
module Domain.Math.Data.Interval
   ( -- Data types
     Intervals, Interval
     -- Interval constructors
   , empty, singleton, unbounded, open, closed
   , leftOpen, rightOpen, greaterThan, greaterThanOrEqualTo
   , lessThan, lessThanOrEqualTo
     -- Inspecing an interval
   , isEmpty, leftPoint, rightPoint, Endpoint(..)
     -- Making intervals
   , except, toList, fromList
   , union, intersect, complement
   , isIn, isInInterval
     -- QuickChecks
   , testMe
   ) where

import Common.TestSuite
import Common.Utils (commaList)
import Control.Monad
import Data.Maybe
import Test.QuickCheck

--------------------------------------------------------------------
-- Data declarations

newtype Intervals a = IS [Interval a]
   deriving Eq

data Interval a = Empty | I (Endpoint a) (Endpoint a)
   deriving Eq

data Endpoint a = Excluding a | Including a | Unbounded
   deriving Eq

instance Show a => Show (Intervals a) where
   show xs = "{ " ++ commaList (map show (toList xs)) ++ " }"

instance Show a => Show (Interval a) where
   show interval =
      case interval of
         Empty -> "{}"
         I a b -> showLeft a ++ "," ++ showRight b

instance Functor Endpoint where
   fmap f (Excluding a) = Excluding (f a)
   fmap f (Including a) = Including (f a)
   fmap _ Unbounded     = Unbounded

instance Functor Interval where
   fmap _ Empty   = Empty
   fmap f (I a b) = I (fmap f a) (fmap f b) -- function should not change order

instance Functor Intervals where
   fmap f (IS xs) = IS (map (fmap f) xs)

showLeft, showRight :: Show a => Endpoint a -> String
showLeft  (Excluding a) = '(' : show a
showLeft  (Including a) = '[' : show a
showLeft  Unbounded     = "(-inf"
showRight (Excluding a) = show a ++ ")"
showRight (Including a) = show a ++ "]"
showRight Unbounded     = "inf)"

--------------------------------------------------------------------
-- Interval constructors

empty :: Interval a
empty = Empty

singleton :: Ord a => a -> Interval a
singleton a = closed a a

unbounded :: Ord a => Interval a
unbounded = makeInterval Unbounded Unbounded

open :: Ord a => a -> a -> Interval a
open a b = makeInterval (Excluding a) (Excluding b)

closed :: Ord a => a -> a -> Interval a
closed a b = makeInterval (Including a) (Including b)

leftOpen :: Ord a => a -> a -> Interval a
leftOpen a b = makeInterval (Excluding a) (Including b)

rightOpen :: Ord a => a -> a -> Interval a
rightOpen a b = makeInterval (Including a) (Excluding b)

greaterThan :: Ord a => a -> Interval a
greaterThan a = makeInterval (Excluding a) Unbounded

greaterThanOrEqualTo :: Ord a => a -> Interval a
greaterThanOrEqualTo a = makeInterval (Including a) Unbounded

lessThan :: Ord a => a -> Interval a
lessThan a = makeInterval Unbounded (Excluding a)

lessThanOrEqualTo :: Ord a => a -> Interval a
lessThanOrEqualTo a = makeInterval Unbounded (Including a)

-- local constructor
makeInterval :: Ord a => Endpoint a -> Endpoint a -> Interval a
makeInterval pl pr =
   case liftM2 compare (getPoint pl) (getPoint pr) of
      Just LT -> I pl pr
      Just EQ
         | isIncluding pl && isIncluding pr -> I pl pr
         | otherwise                        -> Empty
      Just GT -> Empty
      Nothing -> I pl pr

isIncluding :: Endpoint a -> Bool
isIncluding (Including _) = True
isIncluding _             = False

isExcluding :: Endpoint a -> Bool
isExcluding (Excluding _) = True
isExcluding _             = False

--------------------------------------------------------------------
-- Inspecting an interval

isEmpty :: Interval a -> Bool
isEmpty Empty = True
isEmpty _     = False

leftPoint, rightPoint :: Interval a -> Endpoint a
leftPoint  (I a _) = a
leftPoint Empty    = error "leftPoint Empty"
rightPoint (I _ a) = a
rightPoint Empty   = error "rightPoint Empty"

--------------------------------------------------------------------
-- Combining multiple intervals

except :: Ord a => a -> Intervals a
except a = fromList [lessThan a, greaterThan a]

toList :: Intervals a -> [Interval a]
toList (IS xs) = xs

fromList :: Ord a => [Interval a] -> Intervals a
fromList = foldr insert (IS [])

insert :: Ord a => Interval a -> Intervals a -> Intervals a
insert Empty xs  = xs
insert iv@(I l _) (IS xs) = rec xs
 where
   rec []        = IS [iv]
   rec (hd:rest) =
      case (hd, merge iv hd) of
         (Empty, _)       -> rec rest
         (_, Just new)    -> insert new (IS rest)
         (I a _, Nothing)
            | minPointLeft a l == a -> let IS tl = rec rest in IS (hd:tl)
            | otherwise             -> IS (iv:hd:rest)

union :: Ord a => Intervals a -> Intervals a -> Intervals a
union xs = foldr insert xs . toList

intersect :: Ord a => Intervals a -> Intervals a -> Intervals a
intersect (IS xs) (IS ys) = fromList (f xs ys)
 where
   f (a@(I _ ar):as) (b@(I _ br):bs) = inBoth a b : rest
    where
      rest | maxPointRight ar br == ar = f (a:as) bs
           | otherwise                 = f as (b:bs)
   f _ _ = []

complement :: Ord a => Intervals a -> Intervals a
complement (IS xs) = fromList (left ++ zipWith f xs (drop 1 xs) ++ right)
 where
   f (I _ a) (I b _) = fromMaybe Empty (liftM2 I (g a) (g b))
   f _ _             = Empty
   
   g (Including a) = Just (Excluding a)
   g (Excluding a) = Just (Including a)
   g Unbounded     = Nothing
   
   left = case xs of 
             I al _:_ -> maybe [] (return . I Unbounded) (g al)
             _        -> [unbounded]
   right = case reverse xs of 
              I _ ar:_ -> maybe [] (return . flip I Unbounded) (g ar)
              _        -> [unbounded]

isIn :: Ord a => a -> Intervals a -> Bool
isIn a (IS xs) = any (isInInterval a) xs

isInInterval :: Ord a => a -> Interval a -> Bool
isInInterval _ Empty   = False
isInInterval a (I x y) = f GT x && f LT y
 where
   f value b = 
      let g c = (c==EQ && isIncluding b) || c==value 
      in maybe True (g . compare a) (getPoint b)

---------------------------------------------------------------------
-- Local helper functions

getPoint :: Endpoint a -> Maybe a
getPoint (Including a) = Just a
getPoint (Excluding a) = Just a
getPoint Unbounded     = Nothing

merge :: Ord a => Interval a -> Interval a -> Maybe (Interval a)
merge a Empty = Just a
merge Empty b = Just b
merge ia@(I al ar) ib@(I bl br)
   | minPointLeft al bl /= al = merge ib ia
   | otherwise = 
        case liftM2 compare (getPoint ar) (getPoint bl) of
           Just LT -> Nothing
           Just EQ
              | isIncluding ar || isIncluding bl -> ok
              | otherwise     -> Nothing
           Just GT -> ok
           Nothing -> ok
 where
   ok = Just (I al (maxPointRight ar br))

inBoth :: Ord a => Interval a -> Interval a -> Interval a
inBoth _ Empty = Empty
inBoth Empty _ = Empty
inBoth (I al ar) (I bl br) = makeInterval (maxPointLeft al bl) (minPointRight ar br)

minPointLeft, minPointRight, maxPointLeft, maxPointRight 
   :: Ord a => Endpoint a -> Endpoint a -> Endpoint a
minPointLeft  = compareEndpoint True  True
minPointRight = compareEndpoint True  False 
maxPointLeft  = compareEndpoint False False
maxPointRight = compareEndpoint False True 

compareEndpoint :: Ord a => Bool -> Bool -> Endpoint a -> Endpoint a -> Endpoint a
compareEndpoint b1 b2 a b = 
   case liftM2 compare (getPoint a) (getPoint b) of
      Just LT                -> x
      Just EQ | p a          -> x 
              | otherwise    -> y
      Just GT                -> y
      Nothing | b2           -> Unbounded
              | x==Unbounded -> y
              | otherwise    -> x
 where
   p = if b1==b2 then isIncluding else isExcluding
   (x, y) = if b1 then (a, b) else (b, a)
  
---------------------------------------------------------------------
-- QuickCheck

instance (Arbitrary a, Ord a) => Arbitrary (Endpoint a) where
   arbitrary = frequency 
      [ (2, liftM Excluding arbitrary)
      , (2, liftM Including arbitrary)
      , (1, return Unbounded)
      ]
instance (CoArbitrary a, Ord a) => CoArbitrary (Endpoint a) where
   coarbitrary (Excluding a) = variant (0 :: Int) . coarbitrary a
   coarbitrary (Including a) = variant (1 :: Int) . coarbitrary a
   coarbitrary Unbounded     = variant (2 :: Int)

instance (Arbitrary a, Ord a) => Arbitrary (Interval a) where
   arbitrary = frequency 
      [ (1, return Empty)
      , (5, liftM2 makeInterval arbitrary arbitrary)
      ]
instance (CoArbitrary a, Ord a) => CoArbitrary (Interval a) where
   coarbitrary Empty   = variant (0 :: Int)
   coarbitrary (I a b) = variant (1 :: Int) . coarbitrary a . coarbitrary b
   
instance (Arbitrary a, Ord a) => Arbitrary (Intervals a) where
   arbitrary = do
      n  <- choose (0, 100)
      xs <- replicateM n arbitrary
      return (fromList xs)
instance (CoArbitrary a, Ord a) => CoArbitrary (Intervals a) where
   coarbitrary (IS xs) = coarbitrary xs

testMe :: TestSuite
testMe = suite "Intervals" $ do

   suite "Constructor functions" $ do
     addProperty "empty"     $ op0 empty     (const False)
     addProperty "unbounded" $ op0 unbounded (const True)
   
     addProperty "greater than"             $ op1 greaterThan (>)
     addProperty "greater than or equal to" $ op1 greaterThanOrEqualTo (>=)
     addProperty "less than"                $ op1 lessThan (<)
     addProperty "less than or equal to"    $ op1 lessThanOrEqualTo (<=)
     addProperty "singleton"                $ op1 singleton (==)
   
     addProperty "open"       $ op2 open      (<)  (<)
     addProperty "closed"     $ op2 closed    (<=) (<=)
     addProperty "left open"  $ op2 leftOpen  (<)  (<=)
     addProperty "right open" $ op2 rightOpen (<=) (<)
   
   suite "From/to lists" $ do
      addProperty "" fromTo1
      addProperty "" fromTo2
   
   suite "Combinators" $ do
      addProperty "except"     defExcept
      addProperty "union"      defUnion
      addProperty "intersect"  defIntersect
      addProperty "complement" defComplement
   
   suite "Combinator properties" $ do
      addProperty "inverse complement"    $ selfInverse complement
      addProperty "transitive union"      $ transitive  union
      addProperty "commutative union"     $ commutative union
      addProperty "absorption union"      $ absorption  union
      addProperty "transitive intersect"  $ transitive  intersect
      addProperty "commutative intersect" $ commutative intersect
      addProperty "absorption intersect"  $ absorption  intersect

fromTo1, fromTo2 :: Intervals Int -> Bool
fromTo1 a = fromList (toList a) == a
fromTo2 a = fromList (reverse (toList a)) == a

defExcept :: Int -> Int -> Bool
defExcept a b = isIn a (except b) == (a/=b)

defUnion, defIntersect :: Int -> Intervals Int -> Intervals Int -> Bool
defUnion     a b c = isIn a (b `union` c) == (isIn a b || isIn a c)
defIntersect a b c = isIn a (b `intersect` c) == (isIn a b && isIn a c)

defComplement :: Int -> Intervals Int -> Bool
defComplement a b = isIn a (complement b) == not (isIn a b)

op0 :: Interval Int -> (Int -> Bool) -> Int -> Bool
op0 g p a = isInInterval a g == p a

op1 :: (Int -> Interval Int) -> (Int -> Int -> Bool) -> Int -> Int -> Bool
op1 g op a b = isInInterval a (g b) == (a `op` b)

op2 :: (Int -> Int -> Interval Int) -> (Int -> Int -> Bool) -> (Int -> Int -> Bool) -> Int -> Int -> Int -> Bool
op2 g opl opr a b c = isInInterval a (g b c) == (b `opl` a && a `opr` c)

transitive :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Intervals Int -> Intervals Int -> Bool
transitive op a b c = op a (op b c) == op (op a b) c

commutative :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Intervals Int -> Bool
commutative op a b = op a b == op b a

absorption :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Bool
absorption op a = op a a == a

selfInverse :: (Intervals Int -> Intervals Int) -> Intervals Int -> Bool
selfInverse op a = op (op a) == a