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 ( ($)
  23                          , (.)
  24                          , Bounded(..)
  25                          , Ord(..)
  26                          , Show(..)
  27                          , undefined
  28                          )
  29
  30 import qualified Hcompta.Lib.Interval as Interval
  31 import           Hcompta.Lib.Interval (Interval(..), low, high, (..<..), (..<<..), Position(..), position, flip_limit, Pretty(..))
  32
  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) | Hcompta.Lib.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