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  :: (Interval x -> Interval y) -> Sieve x -> Sieve y
  55 fmap_interval f (Sieve ft) = Sieve (FT.fmap' f ft)
  56
  57 -- | Like 'Data.Functor.fmap' but working on 'Interval's,
  58 --   and safe only if 'Measure' is preserved.
  59 fmap_interval_unsafe
  60  :: (Interval x -> Interval x)
  61  -> Sieve x -> Sieve x
  62 fmap_interval_unsafe f (Sieve ft) = Sieve (FT.unsafeFmap f ft)
  63
  64 -- | Like 'Data.Traversable.traverse' but working on 'Interval's.
  65 traverse_interval
  66  :: Applicative f
  67  => (Interval x -> f (Interval y))
  68  -> Sieve x -> f (Sieve y)
  69 traverse_interval f (Sieve ft) = Sieve <$> FT.traverse' f ft
  70
  71 -- | Like 'Data.Traversable.traverse' but working on 'Interval's,
  72 --   and safe only if 'Measure' is preserved.
  73 traverse_interval_unsafe
  74  :: Applicative f
  75  => (Interval x -> f (Interval x))
  76  -> Sieve x -> f (Sieve x)
  77 traverse_interval_unsafe f (Sieve ft) = Sieve <$> FT.unsafeTraverse f ft
  78
  79 -- | 'FT.Measure' of each leaf or node of the 'Sieve' 'FingerTree'.
  80 data Measure x
  81  = Measure_Empty -- ^ Measure of 'FT.empty' 'Fingertree'.
  82  | Measure
  83    { max_high_of_max_low :: Interval x
  84         -- ^ An __'Interval' with the max 'high' 'Limit'__
  85         --   __amongst those having the max 'low' 'Limit'__
  86         --   (which is the 'max' 'Interval'
  87         --   because of lexicographical ordering).
  88   {- NOTE: not useful in the particular case of '..<..'-ordered 'Interval's
  89    , max_high            :: Interval x
  90         -- ^ An __'Interval' with the max 'high' 'Limit'__
  91         --   (which may be a different 'Interval'
  92         --   as it can have a lower 'low' 'Limit',
  93         --   and thus not be the 'max' 'Interval').
  94   -}
  95    }
  96 instance Monoid (Measure x) where
  97         mempty = Measure_Empty
  98
  99         Measure_Empty `mappend` i  = i
 100         i `mappend` Measure_Empty  = i
 101         _i `mappend` j = Measure (max_high_of_max_low j)
 102   {- NOTE: not useful in the particular case of '..<..'-ordered 'Interval's
 103         i `mappend` j =
 104                 Measure (max_high_of_max_low j) $
 105                 case compare_without_adherence (high (max_high i)) (high (max_high j)) of
 106                  LT -> max_high j
 107                  EQ ->
 108                         case (adherence (high (max_high i)), adherence (high (max_high j))) of
 109                          (In , In)  -> max_high i
 110                          (In , Out) -> max_high i
 111                          (Out, In)  -> max_high j
 112                          (Out, Out) -> max_high i
 113                  GT -> max_high i
 114         -}
 115 instance FT.Measured (Measure x) (Interval x) where
 116         measure = Measure
 117
 118 empty :: Sieve x
 119 empty = Sieve FT.empty
 120
 121 -- | Return the 'True' iif. the given 'Sieve' is 'empty'.
 122 null :: Sieve x -> Bool
 123 null (Sieve ft) = FT.null ft
 124
 125 singleton :: Interval x -> Sieve x
 126 singleton = Sieve . FT.singleton
 127
 128 -- | Return an 'Interval' with:
 129 --
 130 -- * the 'Interval.low'  'Interval.Limit' of the 'min' 'Interval',
 131 -- * the 'Interval.high' 'Interval.Limit' of the 'max' 'Interval'.
 132 interval :: Ord x => Sieve x -> Maybe (Interval x)
 133 interval (Sieve ft) =
 134         case FT.viewl ft of
 135          FT.EmptyL -> Nothing
 136          -- l :< ls | FT.null ls -> Just l
 137          l :< _ ->
 138                 case FT.viewr ft of
 139                  FT.EmptyR -> Nothing
 140                  _ :> r    -> Just $ Interval (low l, high r)
 141
 142 -- | All the 'Interval's of the 'Sieve' in '..<<..' order.
 143 intervals :: Sieve x -> [Interval x]
 144 intervals (Sieve t) = Foldable.toList t
 145
 146 -- * Union
 147
 148 -- | Return a 'Sieve' merging the given 'Sieve's with 'Interval.union'.
 149 union :: Ord x => Sieve x -> Sieve x -> Sieve x
 150 union (Sieve s0) (Sieve s1) =
 151         Sieve (merge s0 s1)
 152         where
 153                 merge is js =
 154                         case FT.viewl is of
 155                          FT.EmptyL -> js
 156                          i :< gt_i ->
 157                                 let (js_not_away_lt_i, js_away_gt_i ) = FT.split (      (i ..<<..) . max_high_of_max_low) js in
 158                                 let (js_away_lt_i    , js_not_away_i) = FT.split (not . (..<<.. i) . max_high_of_max_low) js_not_away_lt_i in
 159                                 js_away_lt_i ><
 160                                  -- NOTE: flip merge when possible
 161                                  --       (i.e. when high i is majoring high-s of intersecting Interval-s)
 162                                  --       to preserve complexity over commutativity.
 163                                 case FT.viewl js_not_away_i of
 164                                  FT.EmptyL -> i <| merge js_away_gt_i gt_i
 165                                  lu :< us ->
 166                                         case FT.viewr us of
 167                                          FT.EmptyR ->
 168                                                 let u = lu in
 169                                                 case position i u of
 170                                                  (Adjacent, LT) -> merge gt_i (Interval (low i, high u) <| js_away_gt_i) -- flip: NO
 171                                                  (Overlap , LT) -> merge gt_i (Interval (low i, high u) <| js_away_gt_i) -- flip: NO
 172                                                  (Prefix  , LT) -> merge gt_i (Interval (low i, high u) <| js_away_gt_i) -- flip: NO
 173                                                  (Include , GT) -> merge gt_i (u                        <| js_away_gt_i) -- flip: NO
 174                                                  (Suffixed, LT) -> i                        <| merge js_away_gt_i gt_i   -- flip: YES
 175                                                  (Include , LT) -> i                        <| merge js_away_gt_i gt_i   -- flip: YES
 176                                                  (Equal   , _ ) -> i                        <| merge js_away_gt_i gt_i   -- flip: YES
 177                                                  (Adjacent, GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i   -- flip: YES
 178                                                  (Overlap , GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i   -- flip: YES
 179                                                  (Prefix  , GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i   -- flip: YES
 180                                                  (Suffixed, GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i   -- flip: YES
 181                                                  _              -> assert False undefined
 182                                          _ :> hu ->
 183                                                 let l = low $
 184                                                         case position i lu of
 185                                                          (Adjacent, GT) -> lu
 186                                                          (Overlap , GT) -> lu
 187                                                          (Prefix  , GT) -> lu
 188                                                          (Suffixed, GT) -> lu
 189                                                          _              -> i in
 190                                                 case position i hu of
 191                                                  (Adjacent, LT) -> merge gt_i (Interval (l, high hu) <| js_away_gt_i) -- flip: NO
 192                                                  (Overlap , LT) -> merge gt_i (Interval (l, high hu) <| js_away_gt_i) -- flip: NO
 193                                                  (Prefix  , LT) -> merge gt_i (Interval (l, high hu) <| js_away_gt_i) -- flip: NO
 194                                                  _              -> Interval (l, high i) <| merge js_away_gt_i gt_i    -- flip: YES
 195
 196 -- | Return a 'Sieve' merging the 'Interval's in the given 'Foldable' with 'Interval.union'.
 197 from_Foldable :: (Foldable f, Ord x) => f (Interval x) -> Sieve x
 198 from_Foldable = Foldable.foldr (union . singleton) empty
 199
 200 -- * Intersection
 201
 202 -- | Return a 'Sieve' merging the given 'Sieve's with 'Interval.intersection'.
 203 intersection :: Ord x => Sieve x -> Sieve x -> Sieve x
 204 intersection (Sieve s0) (Sieve s1) =
 205         Sieve (merge s0 s1)
 206         where
 207                 intersect i j = fromMaybe (assert False undefined) $ Interval.intersection i j
 208                 merge is js =
 209                         case FT.viewl is of
 210                          FT.EmptyL -> FT.empty
 211                          i :< gt_i ->
 212                                 let (_, js_not_lt_i)       = FT.split (not . (..<.. i) . max_high_of_max_low) js in
 213                                 let (js_intersecting_i, _) = FT.split (      (i ..<..) . max_high_of_max_low) js_not_lt_i in
 214                                 case FT.viewl js_intersecting_i of
 215                                  li :< li' ->
 216                                         intersect li i <|
 217                                         case FT.viewr li' of
 218                                          hi' :> hi -> hi' |> intersect i hi
 219                                          _         -> li'
 220                                         ><  merge js_not_lt_i gt_i
 221                                  _ -> merge js_not_lt_i gt_i
 222                                  -- NOTE: swap merging to preserve complexity over commutativity
 223
 224 -- | All 'Interval's having a non-'Nothing' 'Interval.intersection' with the given 'Interval',
 225 -- in '..<<..' order.
 226 intersecting :: Ord x => Interval x -> Sieve x -> [Interval x]
 227 intersecting i = Foldable.toList . unSieve . intersection (singleton i)
 228
 229 -- * Complement
 230
 231 -- | Return the 'Sieve' spanning over all the values not within the given 'Sieve'.
 232 complement :: (Ord x, Bounded (Interval.Limit x)) => Sieve x -> Sieve x
 233 complement = complement_with (Interval (minBound, maxBound))
 234
 235 -- | Return the 'Sieve' spanning over all the values not within the given 'Sieve',
 236 --   but within the given 'Interval' which MUST be 'Interval.onto' every 'Interval' inside the 'Sieve'.
 237 complement_with :: Ord x => Interval x -> Sieve x -> Sieve x
 238 complement_with b (Sieve s) =
 239         let (last_low, c) =
 240                 Foldable.foldr
 241                  (\i (previous_low, ft) ->
 242                         ( low i
 243                         , if (Interval.HH $ high i) < (Interval.HH $ high b)
 244                                 then Interval (flip_limit $ high i, flip_limit previous_low) <| ft
 245                                 else ft
 246                         ))
 247                  (flip_limit $ high b, FT.empty) s in
 248         Sieve $
 249         case compare (Interval.LL $ low b) (Interval.LL last_low) of
 250          LT -> Interval (low b, flip_limit last_low) <| c
 251          EQ | low b == high b && FT.null s -> FT.singleton b
 252          _ -> c