Sieve.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Interval.Sieve where

import           Control.Applicative (Applicative(..))
import           Control.Exception (assert)
import           Data.Bool
import           Data.Eq (Eq(..))
import           Data.FingerTree (FingerTree, ViewL(..), ViewR(..), (><), (<|), (|>))
import qualified Data.FingerTree as FT
import           Data.Foldable (Foldable)
import qualified Data.Foldable as Foldable
import           Data.Function (($), (.))
import           Data.Functor ((<$>))
import qualified Data.List
import           Data.Maybe (Maybe(..), fromMaybe)
import           Data.Monoid (Monoid(..))
import           Data.Ord (Ord(..), Ordering(..))
import           Prelude (Bounded(..), undefined)
import           Text.Show (Show(..))

import qualified Data.Interval as Interval
import           Data.Interval ( Interval(..)
                               , low, high
                               , (..<..), (..<<..)
                               , Position(..), position
                               , flip_limit
                               , Pretty(..) )

-- * Type 'Sieve'

-- | '..<<..'-ordered union of 'Interval's.
--
-- __Ressources:__
--
--  * Ralf Hinze and Ross Paterson,
--    \"Finger trees: a simple general-purpose data structure\",
--    /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
--    <http://staff.city.ac.uk/~ross/papers/FingerTree.html>
--  * <https://hackage.haskell.org/package/fingertree/docs/Data-IntervalMap-FingerTree.html>
newtype Sieve x =
	Sieve { unSieve :: FingerTree (Measure x) (Interval x) }

instance (Ord x, Show x) => Show (Pretty (Sieve x)) where
	show (Pretty s) | Data.Interval.Sieve.null s = "empty"
	show (Pretty s) = Data.List.intercalate " u " $ Data.List.map (show . Pretty) $ intervals s

-- | Like 'Data.Functor.fmap' but working on 'Interval's.
fmap_interval
 :: (Ord x, Ord y)
 => (Interval x -> Interval y) -> Sieve x -> Sieve y
fmap_interval f (Sieve ft) = Sieve (FT.fmap' f ft)

-- | Like 'Data.Functor.fmap' but working on 'Interval's,
--   and safe only if 'Measure' is preserved.
fmap_interval_unsafe
 :: Ord x
 => (Interval x -> Interval x)
 -> Sieve x -> Sieve x
fmap_interval_unsafe f (Sieve ft) = Sieve (FT.unsafeFmap f ft)

-- | Like 'Data.Traversable.traverse' but working on 'Interval's.
traverse_interval
 :: (Ord x, Ord y, Applicative f)
 => (Interval x -> f (Interval y))
 -> Sieve x -> f (Sieve y)
traverse_interval f (Sieve ft) = Sieve <$> FT.traverse' f ft

-- | Like 'Data.Traversable.traverse' but working on 'Interval's,
--   and safe only if 'Measure' is preserved.
traverse_interval_unsafe
 :: (Ord x, Applicative f)
 => (Interval x -> f (Interval x))
 -> Sieve x -> f (Sieve x)
traverse_interval_unsafe f (Sieve ft) = Sieve <$> FT.unsafeTraverse f ft

-- | 'FT.Measure' of each leaf or node of the 'Sieve' 'FingerTree'.
data Measure x
 = Measure_Empty -- ^ Measure of 'FT.empty' 'Fingertree'.
 | Measure
   { max_high_of_max_low :: Interval x
	-- ^ An __'Interval' with the max 'high' 'Limit'__
	--   __amongst those having the max 'low' 'Limit'__
	--   (which is the 'max' 'Interval'
	--   because of lexicographical ordering).
  {- NOTE: not useful in the particular case of '..<..'-ordered 'Interval's
   , max_high            :: Interval x
	-- ^ An __'Interval' with the max 'high' 'Limit'__
	--   (which may be a different 'Interval'
	--   as it can have a lower 'low' 'Limit',
	--   and thus not be the 'max' 'Interval').
  -}
   }
instance Ord x => Monoid (Measure x) where
	mempty = Measure_Empty
	
	Measure_Empty `mappend` i  = i
	i `mappend` Measure_Empty  = i
	_i `mappend` j = Measure (max_high_of_max_low j)
  {- NOTE: not useful in the particular case of '..<..'-ordered 'Interval's
	i `mappend` j =
		Measure (max_high_of_max_low j) $
		case compare_without_adherence (high (max_high i)) (high (max_high j)) of
		 LT -> max_high j
		 EQ ->
			case (adherence (high (max_high i)), adherence (high (max_high j))) of
			 (In , In)  -> max_high i
			 (In , Out) -> max_high i
			 (Out, In)  -> max_high j
			 (Out, Out) -> max_high i
		 GT -> max_high i
	-}
instance Ord x => FT.Measured (Measure x) (Interval x) where
	measure = Measure

empty :: Ord x => Sieve x
empty = Sieve FT.empty

-- | Return the 'True' iif. the given 'Sieve' is 'empty'.
null :: Ord x => Sieve x -> Bool
null (Sieve ft) = FT.null ft

singleton :: Ord x => Interval x -> Sieve x
singleton = Sieve . FT.singleton

-- | Return an 'Interval' with:
--
-- * the 'Interval.low'  'Interval.Limit' of the 'min' 'Interval',
-- * the 'Interval.high' 'Interval.Limit' of the 'max' 'Interval'.
interval :: Ord x => Sieve x -> Maybe (Interval x)
interval (Sieve ft) =
	case FT.viewl ft of
	 FT.EmptyL -> Nothing
	 -- l :< ls | FT.null ls -> Just l
	 l :< _ ->
		case FT.viewr ft of
		 FT.EmptyR -> Nothing
		 _ :> r    -> Just $ Interval (low l, high r)

-- | All the 'Interval's of the 'Sieve' in '..<<..' order.
intervals :: Ord x => Sieve x -> [Interval x]
intervals (Sieve t) = Foldable.toList t

-- * Union

-- | Return a 'Sieve' merging the given 'Sieve's with 'Interval.union'.
union :: Ord x => Sieve x -> Sieve x -> Sieve x
union (Sieve s0) (Sieve s1) =
	Sieve (merge s0 s1)
	where
		merge is js =
			case FT.viewl is of
			 FT.EmptyL -> js
			 i :< gt_i ->
				let (js_not_away_lt_i, js_away_gt_i ) = FT.split (      (i ..<<..) . max_high_of_max_low) js in
				let (js_away_lt_i    , js_not_away_i) = FT.split (not . (..<<.. i) . max_high_of_max_low) js_not_away_lt_i in
				js_away_lt_i ><
				 -- NOTE: flip merge when possible
				 --       (i.e. when high i is majoring high-s of intersecting Interval-s)
				 --       to preserve complexity over commutativity.
				case FT.viewl js_not_away_i of
				 FT.EmptyL -> i <| merge js_away_gt_i gt_i
				 lu :< us ->
					case FT.viewr us of
					 FT.EmptyR ->
						let u = lu in
						case position i u of
						 (Adjacent, LT) -> merge gt_i (Interval (low i, high u) <| js_away_gt_i) -- flip: NO
						 (Overlap , LT) -> merge gt_i (Interval (low i, high u) <| js_away_gt_i) -- flip: NO
						 (Prefix  , LT) -> merge gt_i (Interval (low i, high u) <| js_away_gt_i) -- flip: NO
						 (Include , GT) -> merge gt_i (u                        <| js_away_gt_i) -- flip: NO
						 (Suffixed, LT) -> i                        <| merge js_away_gt_i gt_i   -- flip: YES
						 (Include , LT) -> i                        <| merge js_away_gt_i gt_i   -- flip: YES
						 (Equal   , _ ) -> i                        <| merge js_away_gt_i gt_i   -- flip: YES
						 (Adjacent, GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i   -- flip: YES
						 (Overlap , GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i   -- flip: YES
						 (Prefix  , GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i   -- flip: YES
						 (Suffixed, GT) -> Interval (low u, high i) <| merge js_away_gt_i gt_i   -- flip: YES
						 _              -> assert False undefined
					 _ :> hu ->
						let l = low $
							case position i lu of
							 (Adjacent, GT) -> lu
							 (Overlap , GT) -> lu
							 (Prefix  , GT) -> lu
							 (Suffixed, GT) -> lu
							 _              -> i in
						case position i hu of
						 (Adjacent, LT) -> merge gt_i (Interval (l, high hu) <| js_away_gt_i) -- flip: NO
						 (Overlap , LT) -> merge gt_i (Interval (l, high hu) <| js_away_gt_i) -- flip: NO
						 (Prefix  , LT) -> merge gt_i (Interval (l, high hu) <| js_away_gt_i) -- flip: NO
						 _              -> Interval (l, high i) <| merge js_away_gt_i gt_i    -- flip: YES

-- | Return a 'Sieve' merging the 'Interval's in the given 'Foldable' with 'Interval.union'.
from_Foldable :: (Foldable f, Ord x) => f (Interval x) -> Sieve x
from_Foldable = Foldable.foldr (union . singleton) empty

-- * Intersection

-- | Return a 'Sieve' merging the given 'Sieve's with 'Interval.intersection'.
intersection :: Ord x => Sieve x -> Sieve x -> Sieve x
intersection (Sieve s0) (Sieve s1) =
	Sieve (merge s0 s1)
	where
		intersect i j = fromMaybe (assert False undefined) $ Interval.intersection i j
		merge is js =
			case FT.viewl is of
			 FT.EmptyL -> FT.empty
			 i :< gt_i ->
				let (_, js_not_lt_i)       = FT.split (not . (..<.. i) . max_high_of_max_low) js in
				let (js_intersecting_i, _) = FT.split (      (i ..<..) . max_high_of_max_low) js_not_lt_i in
				case FT.viewl js_intersecting_i of
				 li :< li' ->
					intersect li i <|
					case FT.viewr li' of
					 hi' :> hi -> hi' |> intersect i hi
					 _         -> li'
					><  merge js_not_lt_i gt_i
				 _ -> merge js_not_lt_i gt_i
				 -- NOTE: swap merging to preserve complexity over commutativity

-- | All 'Interval's having a non-'Nothing' 'Interval.intersection' with the given 'Interval',
-- in '..<<..' order.
intersecting :: Ord x => Interval x -> Sieve x -> [Interval x]
intersecting i = Foldable.toList . unSieve . intersection (singleton i)

-- * Complement

-- | Return the 'Sieve' spanning over all the values not within the given 'Sieve'.
complement :: (Ord x, Bounded (Interval.Limit x)) => Sieve x -> Sieve x
complement = complement_with (Interval (minBound, maxBound))

-- | Return the 'Sieve' spanning over all the values not within the given 'Sieve',
--   but within the given 'Interval' which MUST be 'Interval.onto' every 'Interval' inside the 'Sieve'.
complement_with :: Ord x => Interval x -> Sieve x -> Sieve x
complement_with b (Sieve s) =
	let (last_low, c) =
		Foldable.foldr
		 (\i (previous_low, ft) ->
			( low i
			, if (Interval.HH $ high i) < (Interval.HH $ high b)
				then Interval (flip_limit $ high i, flip_limit previous_low) <| ft
				else ft
			))
		 (flip_limit $ high b, FT.empty) s in
	Sieve $
	case compare (Interval.LL $ low b) (Interval.LL last_low) of
	 LT -> Interval (low b, flip_limit last_low) <| c
	 EQ | low b == high b && FT.null s -> FT.singleton b
	 _ -> c