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

{- |
   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 :: CharSet
emptyCS                 = []
{-# INLINE emptyCS #-}

allCS                   :: CharSet
allCS :: CharSet
allCS                   = [(Char
forall a. Bounded a => a
minBound, Char
forall a. Bounded a => a
maxBound)]
{-# INLINE allCS #-}

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

stringCS                :: String -> CharSet
stringCS :: String -> CharSet
stringCS                = (Char -> CharSet -> CharSet) -> CharSet -> String -> CharSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CharSet -> CharSet -> CharSet
unionCS (CharSet -> CharSet -> CharSet)
-> (Char -> CharSet) -> Char -> CharSet -> CharSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> CharSet
singleCS) CharSet
emptyCS
{-# INLINE stringCS #-}

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

nullCS                  :: CharSet -> Bool
nullCS :: CharSet -> Bool
nullCS                  = CharSet -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
{-# INLINE nullCS #-}

fullCS                  :: CharSet -> Bool
fullCS :: CharSet -> Bool
fullCS [(Char
lb, Char
ub)]
                        = Char
lb Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
forall a. Bounded a => a
minBound
                          Bool -> Bool -> Bool
&&
                          Char
ub Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
forall a. Bounded a => a
maxBound
fullCS CharSet
_                = Bool
False

elemCS                  :: Char -> CharSet -> Bool
elemCS :: Char -> CharSet -> Bool
elemCS Char
i                = ((Char, Char) -> Bool -> Bool) -> Bool -> CharSet -> Bool
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Char
lb, Char
ub) Bool
b -> Char
i Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
lb Bool -> Bool -> Bool
&& (Char
i Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
ub Bool -> Bool -> Bool
|| Bool
b)) Bool
False
{-# INLINE elemCS #-}

toListCS                :: CharSet -> [Char]
toListCS :: CharSet -> String
toListCS                = ((Char, Char) -> String) -> CharSet -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\ (Char
lb, Char
ub) -> [Char
lb..Char
ub])

unionCS                 :: CharSet -> CharSet -> CharSet

unionCS :: CharSet -> CharSet -> CharSet
unionCS [] CharSet
s2           = CharSet
s2
unionCS CharSet
s1 []           = CharSet
s1

unionCS s1 :: CharSet
s1@((Char
l1,Char
u1):CharSet
s1') s2 :: CharSet
s2@((Char
l2,Char
u2):CharSet
s2')
    | Char
l1 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<  Char
l2          = Char -> Char -> CharSet -> CharSet
forall t. (Ord t, Enum t) => t -> t -> [(t, t)] -> [(t, t)]
union Char
l1 Char
u1            (CharSet -> CharSet) -> CharSet -> CharSet
forall a b. (a -> b) -> a -> b
$ CharSet -> CharSet -> CharSet
unionCS CharSet
s1' CharSet
s2
    | Char
l1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
l2          = Char -> Char -> CharSet -> CharSet
forall t. (Ord t, Enum t) => t -> t -> [(t, t)] -> [(t, t)]
union Char
l1 (Char
u1 Char -> Char -> Char
forall a. Ord a => a -> a -> a
`max` Char
u2) (CharSet -> CharSet) -> CharSet -> CharSet
forall a b. (a -> b) -> a -> b
$ CharSet -> CharSet -> CharSet
unionCS CharSet
s1' CharSet
s2'
    | Bool
otherwise         = Char -> Char -> CharSet -> CharSet
forall t. (Ord t, Enum t) => t -> t -> [(t, t)] -> [(t, t)]
union Char
l2 Char
u2            (CharSet -> CharSet) -> CharSet -> CharSet
forall a b. (a -> b) -> a -> b
$ CharSet -> CharSet -> CharSet
unionCS CharSet
s1  CharSet
s2'
    -- l1 >  l2
    where
    union :: t -> t -> [(t, t)] -> [(t, t)]
union t
l t
u []        = [(t
l,t
u)]
    union t
l t
u s :: [(t, t)]
s@((t
l', t
u') : [(t, t)]
s')
        | t
u t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t -> t
forall a. Enum a => a -> a
pred t
l'   = (t
l,t
u) (t, t) -> [(t, t)] -> [(t, t)]
forall a. a -> [a] -> [a]
: [(t, t)]
s
        | Bool
otherwise     = t -> t -> [(t, t)] -> [(t, t)]
union t
l (t
u t -> t -> t
forall a. Ord a => a -> a -> a
`max` t
u') [(t, t)]
s'

diffCS                  :: CharSet -> CharSet -> CharSet

diffCS :: CharSet -> CharSet -> CharSet
diffCS [] CharSet
_             = []
diffCS CharSet
s  []            = CharSet
s

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

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

intersectCS             :: CharSet -> CharSet -> CharSet

intersectCS :: CharSet -> CharSet -> CharSet
intersectCS []  CharSet
_s2     = []
intersectCS CharSet
_s1  []     = []

intersectCS s1 :: CharSet
s1@((Char
l1,Char
u1):CharSet
s1') s2 :: CharSet
s2@((Char
l2,Char
u2):CharSet
s2')
    | Char
u1 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
l2           = CharSet -> CharSet -> CharSet
intersectCS CharSet
s1' CharSet
s2
    | Char
u2 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
l1           = CharSet -> CharSet -> CharSet
intersectCS CharSet
s1  CharSet
s2'
                                                        -- intervalls overlap
    | Bool
otherwise         = (Char, Char)
i (Char, Char) -> CharSet -> CharSet
forall a. a -> [a] -> [a]
: CharSet
isect
    where
    i :: (Char, Char)
i                   = (Char
l1 Char -> Char -> Char
forall a. Ord a => a -> a -> a
`max` Char
l2, Char
u1 Char -> Char -> Char
forall a. Ord a => a -> a -> a
`min` Char
u2)
    isect :: CharSet
isect
        | Char
u1 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
u2       = CharSet -> CharSet -> CharSet
intersectCS CharSet
s1' CharSet
s2
        | Bool
otherwise     = CharSet -> CharSet -> CharSet
intersectCS CharSet
s1  CharSet
s2'

exorCS                  :: CharSet -> CharSet -> CharSet

exorCS :: CharSet -> CharSet -> CharSet
exorCS [] CharSet
s2            = CharSet
s2
exorCS CharSet
s1 []            = CharSet
s1

exorCS s1 :: CharSet
s1@(i1 :: (Char, Char)
i1@(Char
l1,Char
u1):CharSet
s1') s2 :: CharSet
s2@(i2 :: (Char, Char)
i2@(Char
l2,Char
u2):CharSet
s2')
    | Char
u1 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
l2           = (Char, Char)
i1 (Char, Char) -> CharSet -> CharSet
forall a. a -> [a] -> [a]
: CharSet -> CharSet -> CharSet
exorCS CharSet
s1' CharSet
s2
    | Char
u2 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
l1           = (Char, Char)
i2 (Char, Char) -> CharSet -> CharSet
forall a. a -> [a] -> [a]
: CharSet -> CharSet -> CharSet
exorCS CharSet
s1  CharSet
s2'
                                                        -- intervalls overlap
    | Bool
otherwise         = CharSet
i CharSet -> CharSet -> CharSet
forall a. [a] -> [a] -> [a]
++ CharSet
exor'
    where
    i :: CharSet
i   | Char
l1 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
l2       = [(Char
l1, Char -> Char
forall a. Enum a => a -> a
pred Char
l2)]
        | Char
l2 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
l1       = [(Char
l2, Char -> Char
forall a. Enum a => a -> a
pred Char
l1)]
        | Bool
otherwise     = []
    exor' :: CharSet
exor'
        | Char
u1 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
u2       = CharSet -> CharSet -> CharSet
exorCS                  CharSet
s1' ((Char -> Char
forall a. Enum a => a -> a
succ Char
u1, Char
u2) (Char, Char) -> CharSet -> CharSet
forall a. a -> [a] -> [a]
: CharSet
s2')
        | Char
u2 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
u1       = CharSet -> CharSet -> CharSet
exorCS ((Char -> Char
forall a. Enum a => a -> a
succ Char
u2, Char
u1) (Char, Char) -> CharSet -> CharSet
forall a. a -> [a] -> [a]
: CharSet
s1')                 CharSet
s2'
        | Bool
otherwise     = CharSet -> CharSet -> CharSet
exorCS                  CharSet
s1'                  CharSet
s2'

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