Data/Interval/Sieve.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE TupleSections #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Data.Interval.Sieve where
   8
   9 import           Control.Applicative (Applicative(..))
  10 import           Control.Exception (assert)
  11 import           Data.Bool
  12 import           Data.Eq (Eq(..))
  13 import           Data.FingerTree (FingerTree, ViewL(..), ViewR(..), (><), (<|), (|>))
  14 import qualified Data.FingerTree as FT
  15 import           Data.Foldable (Foldable)
  16 import qualified Data.Foldable as Foldable
  17 import           Data.Function (($), (.))
  18 import           Data.Functor ((<$>))
  19 import qualified Data.List
  20 import           Data.Maybe (Maybe(..), fromMaybe)
  21 import           Data.Monoid (Monoid(..))
  22 import           Data.Ord (Ord(..), Ordering(..))
  23 import           Prelude (Bounded(..), undefined)
  24 import           Text.Show (Show(..))
  25
  26 import qualified Data.Interval as Interval
  27 import           Data.Interval ( Interval(..)
  28                                , low, high
  29                                , (..<..), (..<<..)
  30                                , Position(..), position
  31                                , flip_limit
  32                                , Pretty(..) )
  33
  34 -- * Type 'Sieve'
  35
  36 -- | '..<<..'-ordered union of 'Interval's.
  37 --
  38 -- __Ressources:__
  39 --
  40 --  * Ralf Hinze and Ross Paterson,
  41 --    \"Finger trees: a simple general-purpose data structure\",
  42 --    /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
  43 --    <http://staff.city.ac.uk/~ross/papers/FingerTree.html>
  44 --  * <https://hackage.haskell.org/package/fingertree/docs/Data-IntervalMap-FingerTree.html>
  45 newtype Sieve x =
  46         Sieve { unSieve :: FingerTree (Measure x) (Interval x) }
  47
  48 instance (Ord x, Show x) => Show (Pretty (Sieve x)) where
  49         show (Pretty s) | Data.Interval.Sieve.null s = "empty"
  50         show (Pretty s) = Data.List.intercalate " u " $ Data.List.map (show . Pretty) $ intervals s
  51
  52 -- | Like 'Data.Functor.fmap' but working on 'Interval's.
  53 fmap_interval
  54  :: (Ord x, Ord y)
  55  => (Interval x -> Interval y) -> Sieve x -> Sieve y
  56 fmap_interval f (Sieve ft) = Sieve (FT.fmap' f ft)
  57
  58 -- | Like 'Data.Functor.fmap' but working on 'Interval's,
  59 --   and safe only if 'Measure' is preserved.
  60 fmap_interval_unsafe
  61  :: Ord x
  62  => (Interval x -> Interval x)
  63  -> Sieve x -> Sieve x
  64 fmap_interval_unsafe f (Sieve ft) = Sieve (FT.unsafeFmap f ft)
  65
  66 -- | Like 'Data.Traversable.traverse' but working on 'Interval's.
  67 traverse_interval
  68  :: (Ord x, Ord y, Applicative f)
  69  => (Interval x -> f (Interval y))
  70  -> Sieve x -> f (Sieve y)
  71 traverse_interval f (Sieve ft) = Sieve <$> FT.traverse' f ft
  72
  73 -- | Like 'Data.Traversable.traverse' but working on 'Interval's,
  74 --   and safe only if 'Measure' is preserved.
  75 traverse_interval_unsafe
  76  :: (Ord x, Applicative f)
  77  => (Interval x -> f (Interval x))
  78  -> Sieve x -> f (Sieve x)
  79 traverse_interval_unsafe f (Sieve ft) = Sieve <$> FT.unsafeTraverse f ft
  80
  81 -- | 'FT.Measure' of each leaf or node of the 'Sieve' 'FingerTree'.
  82 data Measure x
  83  = Measure_Empty -- ^ Measure of 'FT.empty' 'Fingertree'.
  84  | Measure
  85    { max_high_of_max_low :: Interval x
  86         -- ^ An __'Interval' with the max 'high' 'Limit'__
  87         --   __amongst those having the max 'low' 'Limit'__
  88         --   (which is the 'max' 'Interval'
  89         --   because of lexicographical ordering).
  90   {- NOTE: not useful in the particular case of '..<..'-ordered 'Interval's
  91    , max_high            :: Interval x
  92         -- ^ An __'Interval' with the max 'high' 'Limit'__
  93         --   (which may be a different 'Interval'
  94         --   as it can have a lower 'low' 'Limit',
  95         --   and thus not be the 'max' 'Interval').
  96   -}
  97    }
  98 instance Ord x => Monoid (Measure x) where
  99         mempty = Measure_Empty
 100
 101         Measure_Empty `mappend` i  = i
 102         i `mappend` Measure_Empty  = i
 103         _i `mappend` j = Measure (max_high_of_max_low j)
 104   {- NOTE: not useful in the particular case of '..<..'-ordered 'Interval's
 105         i `mappend` j =
 106                 Measure (max_high_of_max_low j) $
 107                 case compare_without_adherence (high (max_high i)) (high (max_high j)) of
 108                  LT -> max_high j
 109                  EQ ->
 110                         case (adherence (high (max_high i)), adherence (high (max_high j))) of
 111                          (In , In)  -> max_high i
 112                          (In , Out) -> max_high i
 113                          (Out, In)  -> max_high j
 114                          (Out, Out) -> max_high i
 115                  GT -> max_high i
 116         -}
 117 instance Ord x => FT.Measured (Measure x) (Interval x) where
 118         measure = Measure
 119
 120 empty :: Ord x => Sieve x
 121 empty = Sieve FT.empty
 122
 123 -- | Return the 'True' iif. the given 'Sieve' is 'empty'.
 124 null :: Ord x => Sieve x -> Bool
 125 null (Sieve ft) = FT.null ft
 126
 127 singleton :: Ord x => Interval x -> Sieve x
 128 singleton = Sieve . FT.singleton
 129
 130 -- | Return an 'Interval' with:
 131 --
 132 -- * the 'Interval.low'  'Interval.Limit' of the 'min' 'Interval',
 133 -- * the 'Interval.high' 'Interval.Limit' of the 'max' 'Interval'.
 134 interval :: Ord x => Sieve x -> Maybe (Interval x)
 135 interval (Sieve ft) =
 136         case FT.viewl ft of
 137          FT.EmptyL -> Nothing
 138          -- l :< ls | FT.null ls -> Just l
 139          l :< _ ->
 140                 case FT.viewr ft of
 141                  FT.EmptyR -> Nothing
 142                  _ :> r    -> Just $ Interval (low l, high r)
 143
 144 -- | All the 'Interval's of the 'Sieve' in '..<<..' order.
 145 intervals :: Ord x => Sieve x -> [Interval x]
 146 intervals (Sieve t) = Foldable.toList t
 147
 148 -- * Union
 149
 150 -- | Return a 'Sieve' merging the given 'Sieve's with 'Interval.union'.
 151 union :: Ord x => Sieve x -> Sieve x -> Sieve x
 152 union (Sieve s0) (Sieve s1) =
 153         Sieve (merge s0 s1)
 154         where
 155                 merge is js =
 156                         case FT.viewl is of
 157                          FT.EmptyL -> js
 158                          i :< gt_i ->
 159                                 let (js_not_away_lt_i, js_away_gt_i ) = FT.split (      (i ..<<..) . max_high_of_max_low) js in
 160                                 let (js_away_lt_i    , js_not_away_i) = FT.split (not . (..<<.. i) . max_high_of_max_low) js_not_away_lt_i in
 161                                 js_away_lt_i ><
 162                                  -- NOTE: flip merge when possible
 163                                  --       (i.e. when high i is majoring high-s of intersecting Interval-s)
 164                                  --       to preserve complexity over commutativity.
 165                                 case FT.viewl js_not_away_i of
 166                                  FT.EmptyL -> i <| merge js_away_gt_i gt_i
 167                                  lu :< us ->
 168                                         case FT.viewr us of
 169                                          FT.EmptyR ->
 170                                                 let u = lu in
 171                                                 case position i u of
 172                                                  (Adjacent, LT) -> merge gt_i (Interval (low i, high u) <| js_away_gt_i) -- flip: NO
 173                                                  (Overlap , LT) -> merge gt_i (Interval (low i, high u) <| js_away_gt_i) -- flip: NO
 174                                                  (Prefix  , LT) -> merge gt_i (Interval (low i, high u) <| js_away_gt_i) -- flip: NO
 175                                                  (Include , GT) -> merge gt_i (u                        <| js_away_gt_i) -- flip: NO
 176                                                  (Suffixed, LT) -> i                        <| merge js_away_gt_i gt_i   -- flip: YES
 177                                                  (Include , LT) -> i                        <| merge js_away_gt_i gt_i   -- flip: YES
 178                                                  (Equal   , _ ) -> i                        <| merge js_away_gt_i gt_i   -- flip: YES
 179                                                  (Adjacent, GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i   -- flip: YES
 180                                                  (Overlap , GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i   -- flip: YES
 181                                                  (Prefix  , GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i   -- flip: YES
 182                                                  (Suffixed, GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i   -- flip: YES
 183                                                  _              -> assert False undefined
 184                                          _ :> hu ->
 185                                                 let l = low $
 186                                                         case position i lu of
 187                                                          (Adjacent, GT) -> lu
 188                                                          (Overlap , GT) -> lu
 189                                                          (Prefix  , GT) -> lu
 190                                                          (Suffixed, GT) -> lu
 191                                                          _              -> i in
 192                                                 case position i hu of
 193                                                  (Adjacent, LT) -> merge gt_i (Interval (l, high hu) <| js_away_gt_i) -- flip: NO
 194                                                  (Overlap , LT) -> merge gt_i (Interval (l, high hu) <| js_away_gt_i) -- flip: NO
 195                                                  (Prefix  , LT) -> merge gt_i (Interval (l, high hu) <| js_away_gt_i) -- flip: NO
 196                                                  _              -> Interval (l, high i) <| merge js_away_gt_i gt_i    -- flip: YES
 197
 198 -- | Return a 'Sieve' merging the 'Interval's in the given 'Foldable' with 'Interval.union'.
 199 from_Foldable :: (Foldable f, Ord x) => f (Interval x) -> Sieve x
 200 from_Foldable = Foldable.foldr (union . singleton) empty
 201
 202 -- * Intersection
 203
 204 -- | Return a 'Sieve' merging the given 'Sieve's with 'Interval.intersection'.
 205 intersection :: Ord x => Sieve x -> Sieve x -> Sieve x
 206 intersection (Sieve s0) (Sieve s1) =
 207         Sieve (merge s0 s1)
 208         where
 209                 intersect i j = fromMaybe (assert False undefined) $ Interval.intersection i j
 210                 merge is js =
 211                         case FT.viewl is of
 212                          FT.EmptyL -> FT.empty
 213                          i :< gt_i ->
 214                                 let (_, js_not_lt_i)       = FT.split (not . (..<.. i) . max_high_of_max_low) js in
 215                                 let (js_intersecting_i, _) = FT.split (      (i ..<..) . max_high_of_max_low) js_not_lt_i in
 216                                 case FT.viewl js_intersecting_i of
 217                                  li :< li' ->
 218                                         intersect li i <|
 219                                         case FT.viewr li' of
 220                                          hi' :> hi -> hi' |> intersect i hi
 221                                          _         -> li'
 222                                         ><  merge js_not_lt_i gt_i
 223                                  _ -> merge js_not_lt_i gt_i
 224                                  -- NOTE: swap merging to preserve complexity over commutativity
 225
 226 -- | All 'Interval's having a non-'Nothing' 'Interval.intersection' with the given 'Interval',
 227 -- in '..<<..' order.
 228 intersecting :: Ord x => Interval x -> Sieve x -> [Interval x]
 229 intersecting i = Foldable.toList . unSieve . intersection (singleton i)
 230
 231 -- * Complement
 232
 233 -- | Return the 'Sieve' spanning over all the values not within the given 'Sieve'.
 234 complement :: (Ord x, Bounded (Interval.Limit x)) => Sieve x -> Sieve x
 235 complement = complement_with (Interval (minBound, maxBound))
 236
 237 -- | Return the 'Sieve' spanning over all the values not within the given 'Sieve',
 238 --   but within the given 'Interval' which MUST be 'Interval.onto' every 'Interval' inside the 'Sieve'.
 239 complement_with :: Ord x => Interval x -> Sieve x -> Sieve x
 240 complement_with b (Sieve s) =
 241         let (last_low, c) =
 242                 Foldable.foldr
 243                  (\i (previous_low, ft) ->
 244                         ( low i
 245                         , if (Interval.HH $ high i) < (Interval.HH $ high b)
 246                                 then Interval (flip_limit $ high i, flip_limit previous_low) <| ft
 247                                 else ft
 248                         ))
 249                  (flip_limit $ high b, FT.empty) s in
 250         Sieve $
 251         case compare (Interval.LL $ low b) (Interval.LL last_low) of
 252          LT -> Interval (low b, flip_limit last_low) <| c
 253          EQ | low b == high b && FT.null s -> FT.singleton b
 254          _ -> c