-- ------------------------------------------------------------

{- |
   Module     : Data.Set.CharSet
   Copyright  : Copyright (C) 2010 - Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   Char sets implemeted as non-overlapping ordered lists of intervalls

-}

-- ------------------------------------------------------------

module Data.Set.CharSet
    ( CharSet
    , emptyCS
    , allCS
    , singleCS
    , stringCS
    , rangeCS
    , nullCS
    , fullCS
    , unionCS
    , diffCS
    , intersectCS
    , exorCS
    , compCS
    , elemCS
    , toListCS
    )
where

-- ------------------------------------------------------------

type CharSet            = [(Char, Char)]

emptyCS                 :: CharSet
emptyCS                 = []
{-# INLINE emptyCS #-}

allCS                   :: CharSet
allCS                   = [(minBound, maxBound)]
{-# INLINE allCS #-}

singleCS                :: Char -> CharSet
singleCS c              = [(c,c)]
{-# INLINE singleCS #-}

stringCS                :: String -> CharSet
stringCS                = foldr (unionCS . singleCS) emptyCS
{-# INLINE stringCS #-}

rangeCS                 :: Char -> Char -> CharSet
rangeCS l u
    | l <= u            = [(l,u)]
    | otherwise         = emptyCS
{-# INLINE rangeCS #-}

nullCS                  :: CharSet -> Bool
nullCS                  = null
{-# INLINE nullCS #-}

fullCS                  :: CharSet -> Bool
fullCS [(lb, ub)]
                        = lb == minBound
                          &&
                          ub == maxBound
fullCS _                = False

elemCS                  :: Char -> CharSet -> Bool
elemCS i                = foldr (\ (lb, ub) b -> i >= lb && (i <= ub || b)) False
{-# INLINE elemCS #-}

toListCS                :: CharSet -> [Char]
toListCS                = concatMap (\ (lb, ub) -> [lb..ub])

unionCS                 :: CharSet -> CharSet -> CharSet

unionCS [] s2           = s2
unionCS s1 []           = s1

unionCS s1@((l1,u1):s1') s2@((l2,u2):s2')
    | l1 <  l2          = union l1 u1            $ unionCS s1' s2
    | l1 == l2          = union l1 (u1 `max` u2) $ unionCS s1' s2'
    | otherwise         = union l2 u2            $ unionCS s1  s2'
    -- l1 >  l2
    where
    union l u []        = [(l,u)]
    union l u s@((l', u') : s')
        | u < pred l'   = (l,u) : s
        | otherwise     = union l (u `max` u') s'

diffCS                  :: CharSet -> CharSet -> CharSet

diffCS [] _             = []
diffCS s  []            = s

diffCS s1@((l1,u1):s1') s2@((l2,u2):s2')
    | u1 < l2           = (l1,u1) : diffCS s1' s2       -- whole intervall remains in set
    | u2 < l1           = diffCS s1  s2'                -- no elements to remove
                                                        -- intervalls overlap
    | otherwise         = p ++ diffCS (s ++ s1') s2
    where
    p | l1 < l2         = [(l1, pred l2)]               -- = rangeCS l1 (pred l2), but prevent underflow
      | otherwise       = []
    s | u2 < u1         = [(succ u2, u1)]               -- = rangeCS (succ u2) u1, but prevent overflow
      | otherwise       = []

compCS                  :: CharSet -> CharSet
compCS                  = (allCS `diffCS`)

intersectCS             :: CharSet -> CharSet -> CharSet

intersectCS []  _s2     = []
intersectCS _s1  []     = []

intersectCS s1@((l1,u1):s1') s2@((l2,u2):s2')
    | u1 < l2           = intersectCS s1' s2
    | u2 < l1           = intersectCS s1  s2'
                                                        -- intervalls overlap
    | otherwise         = i : isect
    where
    i                   = (l1 `max` l2, u1 `min` u2)
    isect
        | u1 < u2       = intersectCS s1' s2
        | otherwise     = intersectCS s1  s2'

exorCS                  :: CharSet -> CharSet -> CharSet

exorCS [] s2            = s2
exorCS s1 []            = s1

exorCS s1@(i1@(l1,u1):s1') s2@(i2@(l2,u2):s2')
    | u1 < l2           = i1 : exorCS s1' s2
    | u2 < l1           = i2 : exorCS s1  s2'
                                                        -- intervalls overlap
    | otherwise         = i ++ exor'
    where
    i   | l1 < l2       = [(l1, pred l2)]
        | l2 < l1       = [(l2, pred l1)]
        | otherwise     = []
    exor'
        | u1 < u2       = exorCS                  s1' ((succ u1, u2) : s2')
        | u2 < u1       = exorCS ((succ u2, u1) : s1')                 s2'
        | otherwise     = exorCS                  s1'                  s2'

-- ------------------------------------------------------------