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