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