module Data.Interval.Sieve where
import Control.Applicative (Applicative(..))
import Control.Exception (assert)
import Data.Bool
import Data.Eq (Eq(..))
import Data.FingerTree (FingerTree, ViewL(..), ViewR(..), (><), (<|), (|>))
import qualified Data.FingerTree as FT
import Data.Foldable (Foldable)
import qualified Data.Foldable as Foldable
import Data.Function (($), (.))
import Data.Functor ((<$>))
import qualified Data.List
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..), Ordering(..))
import Prelude (Bounded(..), undefined)
import Text.Show (Show(..))
import qualified Data.Interval as Interval
import Data.Interval ( Interval(..)
, low, high
, (..<..), (..<<..)
, Position(..), position
, flip_limit
, Pretty(..) )
newtype Sieve x =
Sieve { unSieve :: FingerTree (Measure x) (Interval x) }
instance (Ord x, Show x) => Show (Pretty (Sieve x)) where
show (Pretty s) | Data.Interval.Sieve.null s = "empty"
show (Pretty s) = Data.List.intercalate " u " $ Data.List.map (show . Pretty) $ intervals s
fmap_interval
:: (Ord x, Ord y)
=> (Interval x -> Interval y) -> Sieve x -> Sieve y
fmap_interval f (Sieve ft) = Sieve (FT.fmap' f ft)
fmap_interval_unsafe
:: Ord x
=> (Interval x -> Interval x)
-> Sieve x -> Sieve x
fmap_interval_unsafe f (Sieve ft) = Sieve (FT.unsafeFmap f ft)
traverse_interval
:: (Ord x, Ord y, Applicative f)
=> (Interval x -> f (Interval y))
-> Sieve x -> f (Sieve y)
traverse_interval f (Sieve ft) = Sieve <$> FT.traverse' f ft
traverse_interval_unsafe
:: (Ord x, Applicative f)
=> (Interval x -> f (Interval x))
-> Sieve x -> f (Sieve x)
traverse_interval_unsafe f (Sieve ft) = Sieve <$> FT.unsafeTraverse f ft
data Measure x
= Measure_Empty
| Measure
{ max_high_of_max_low :: Interval x
}
instance Ord x => Monoid (Measure x) where
mempty = Measure_Empty
Measure_Empty `mappend` i = i
i `mappend` Measure_Empty = i
_i `mappend` j = Measure (max_high_of_max_low j)
instance Ord x => FT.Measured (Measure x) (Interval x) where
measure = Measure
empty :: Ord x => Sieve x
empty = Sieve FT.empty
null :: Ord x => Sieve x -> Bool
null (Sieve ft) = FT.null ft
singleton :: Ord x => Interval x -> Sieve x
singleton = Sieve . FT.singleton
interval :: Ord x => Sieve x -> Maybe (Interval x)
interval (Sieve ft) =
case FT.viewl ft of
FT.EmptyL -> Nothing
l :< _ ->
case FT.viewr ft of
FT.EmptyR -> Nothing
_ :> r -> Just $ Interval (low l, high r)
intervals :: Ord x => Sieve x -> [Interval x]
intervals (Sieve t) = Foldable.toList t
union :: Ord x => Sieve x -> Sieve x -> Sieve x
union (Sieve s0) (Sieve s1) =
Sieve (merge s0 s1)
where
merge is js =
case FT.viewl is of
FT.EmptyL -> js
i :< gt_i ->
let (js_not_away_lt_i, js_away_gt_i ) = FT.split ( (i ..<<..) . max_high_of_max_low) js in
let (js_away_lt_i , js_not_away_i) = FT.split (not . (..<<.. i) . max_high_of_max_low) js_not_away_lt_i in
js_away_lt_i ><
case FT.viewl js_not_away_i of
FT.EmptyL -> i <| merge js_away_gt_i gt_i
lu :< us ->
case FT.viewr us of
FT.EmptyR ->
let u = lu in
case position i u of
(Adjacent, LT) -> merge gt_i (Interval (low i, high u) <| js_away_gt_i)
(Overlap , LT) -> merge gt_i (Interval (low i, high u) <| js_away_gt_i)
(Prefix , LT) -> merge gt_i (Interval (low i, high u) <| js_away_gt_i)
(Include , GT) -> merge gt_i (u <| js_away_gt_i)
(Suffixed, LT) -> i <| merge js_away_gt_i gt_i
(Include , LT) -> i <| merge js_away_gt_i gt_i
(Equal , _ ) -> i <| merge js_away_gt_i gt_i
(Adjacent, GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i
(Overlap , GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i
(Prefix , GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i
(Suffixed, GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i
_ -> assert False undefined
_ :> hu ->
let l = low $
case position i lu of
(Adjacent, GT) -> lu
(Overlap , GT) -> lu
(Prefix , GT) -> lu
(Suffixed, GT) -> lu
_ -> i in
case position i hu of
(Adjacent, LT) -> merge gt_i (Interval (l, high hu) <| js_away_gt_i)
(Overlap , LT) -> merge gt_i (Interval (l, high hu) <| js_away_gt_i)
(Prefix , LT) -> merge gt_i (Interval (l, high hu) <| js_away_gt_i)
_ -> Interval (l, high i) <| merge js_away_gt_i gt_i
from_Foldable :: (Foldable f, Ord x) => f (Interval x) -> Sieve x
from_Foldable = Foldable.foldr (union . singleton) empty
intersection :: Ord x => Sieve x -> Sieve x -> Sieve x
intersection (Sieve s0) (Sieve s1) =
Sieve (merge s0 s1)
where
intersect i j = fromMaybe (assert False undefined) $ Interval.intersection i j
merge is js =
case FT.viewl is of
FT.EmptyL -> FT.empty
i :< gt_i ->
let (_, js_not_lt_i) = FT.split (not . (..<.. i) . max_high_of_max_low) js in
let (js_intersecting_i, _) = FT.split ( (i ..<..) . max_high_of_max_low) js_not_lt_i in
case FT.viewl js_intersecting_i of
li :< li' ->
intersect li i <|
case FT.viewr li' of
hi' :> hi -> hi' |> intersect i hi
_ -> li'
>< merge js_not_lt_i gt_i
_ -> merge js_not_lt_i gt_i
intersecting :: Ord x => Interval x -> Sieve x -> [Interval x]
intersecting i = Foldable.toList . unSieve . intersection (singleton i)
complement :: (Ord x, Bounded (Interval.Limit x)) => Sieve x -> Sieve x
complement = complement_with (Interval (minBound, maxBound))
complement_with :: Ord x => Interval x -> Sieve x -> Sieve x
complement_with b (Sieve s) =
let (last_low, c) =
Foldable.foldr
(\i (previous_low, ft) ->
( low i
, if (Interval.HH $ high i) < (Interval.HH $ high b)
then Interval (flip_limit $ high i, flip_limit previous_low) <| ft
else ft
))
(flip_limit $ high b, FT.empty) s in
Sieve $
case compare (Interval.LL $ low b) (Interval.LL last_low) of
LT -> Interval (low b, flip_limit last_low) <| c
EQ | low b == high b && FT.null s -> FT.singleton b
_ -> c