lib/Hcompta/Lib/Interval/Sieve.hs

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