├── stack.yaml ├── .gitignore ├── cabal.haskell-ci ├── Setup.lhs ├── stack-8.10.7.yaml ├── test ├── TestSuite.hs ├── TestInstances.hs ├── TestIntervalRelation.hs ├── TestIntervalSet.hs ├── TestIntegerInterval.hs └── TestIntervalMap.hs ├── README.md ├── COPYING ├── .github └── workflows │ ├── coverage.yaml │ └── build.yaml ├── CHANGELOG.markdown ├── src └── Data │ ├── IntervalMap │ ├── Lazy.hs │ ├── Strict.hs │ └── Base.hs │ ├── IntervalRelation.hs │ ├── IntegerInterval │ └── Internal.hs │ ├── Interval │ └── Internal.hs │ ├── IntervalSet.hs │ ├── IntegerInterval.hs │ └── Interval.hs └── data-interval.cabal /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2020-09-28 2 | packages: 3 | - . 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virthualenv 8 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | constraint-set no-lattices 2 | constraints: data-interval -lattices 3 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain 5 | -------------------------------------------------------------------------------- /stack-8.10.7.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.28 2 | packages: 3 | - . 4 | extra-deps: 5 | - extended-reals-0.2.7.0 6 | -------------------------------------------------------------------------------- /test/TestSuite.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import TestInterval 4 | import TestIntervalMap 5 | import TestIntervalRelation 6 | import TestIntervalSet 7 | import TestIntegerInterval 8 | import Test.Tasty 9 | 10 | main :: IO () 11 | main = defaultMain $ testGroup "data-interval test suite" 12 | [ intervalTestGroup 13 | , intervalMapTestGroup 14 | , intervalRelationTestGroup 15 | , intervalSetTestGroup 16 | , integerIntervalTestGroup 17 | ] 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | data-interval 2 | ============= 3 | 4 | [![Build Status (GitHub Actions)](https://github.com/msakai/data-interval/actions/workflows/build.yaml/badge.svg)](https://github.com/msakai/data-interval/actions/workflows/build.yaml) 5 | [![Hackage](https://img.shields.io/hackage/v/data-interval.svg)](https://hackage.haskell.org/package/data-interval) 6 | [![Hackage Deps](https://img.shields.io/hackage-deps/v/data-interval.svg)](https://packdeps.haskellers.com/feed?needle=data-interval) 7 | [![Coverage Status](https://coveralls.io/repos/msakai/data-interval/badge.svg)](https://coveralls.io/r/msakai/data-interval) 8 | [![License](https://img.shields.io/badge/License-BSD%203--Clause-blue.svg)](https://opensource.org/licenses/BSD-3-Clause) 9 | 10 | Interval datatype, interval arithmetic, and interval-based containers for Haskell. 11 | 12 | Unlike the [intervals package](), 13 | this package provides both open and closed intervals and is intended to be used 14 | with Rational. 15 | -------------------------------------------------------------------------------- /test/TestInstances.hs: -------------------------------------------------------------------------------- 1 | module TestInstances where 2 | 3 | import Control.Monad 4 | 5 | import Test.Tasty.QuickCheck 6 | 7 | import Data.Interval 8 | import Data.IntervalRelation 9 | 10 | instance Arbitrary Boundary where 11 | arbitrary = arbitraryBoundedEnum 12 | 13 | instance Arbitrary r => Arbitrary (Extended r) where 14 | arbitrary = frequency 15 | [ (1, return NegInf) 16 | , (1, return PosInf) 17 | , (3, liftM Finite arbitrary) 18 | ] 19 | shrink NegInf = [] 20 | shrink (Finite x) = NegInf : PosInf : map Finite (shrink x) 21 | shrink PosInf = [] 22 | 23 | instance (Arbitrary r, Ord r) => Arbitrary (Interval r) where 24 | arbitrary = do 25 | x <- arbitrary 26 | y <- arbitrary 27 | frequency 28 | [ (1, return $ interval x y) 29 | , (3, return $ interval (min x y) (max x y)) 30 | ] 31 | shrink a 32 | | isSingleton a = case lowerBound a of 33 | Finite x -> map singleton $ shrink x 34 | _ -> [] 35 | | otherwise = mkPoint lb ++ mkPoint ub ++ map (lb `interval`) (shrink ub) ++ map (`interval` ub) (shrink lb) 36 | where 37 | lb = lowerBound' a 38 | ub = upperBound' a 39 | 40 | mkPoint (Finite x, _) = [singleton x] 41 | mkPoint _ = [] 42 | 43 | intervals :: Gen (Interval Rational) 44 | intervals = arbitrary 45 | 46 | instance Arbitrary Relation where 47 | arbitrary = arbitraryBoundedEnum 48 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright 2010-2013 Masahiro Sakai. All rights reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above 10 | copyright notice, this list of conditions and the following 11 | disclaimer in the documentation and/or other materials provided 12 | with the distribution. 13 | 3. The name of the author may not be used to endorse or promote 14 | products derived from this software without specific prior 15 | written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 18 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, 21 | INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 22 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 25 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 26 | IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 27 | POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /.github/workflows/coverage.yaml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | name: Coverage 3 | jobs: 4 | coveralls: 5 | name: data-interval 6 | runs-on: ${{ matrix.os }} 7 | env: 8 | STACK_YAML: ${{ matrix.stack_yaml }} 9 | strategy: 10 | matrix: 11 | include: 12 | - ghc: '8.10.7' 13 | os: ubuntu-latest 14 | stack_yaml: 'stack-8.10.7.yaml' 15 | flags: '' 16 | steps: 17 | - uses: actions/checkout@v4 18 | 19 | - uses: haskell-actions/setup@v2 20 | name: Setup Haskell 21 | with: 22 | ghc-version: ${{ matrix.ghc }} 23 | enable-stack: true 24 | stack-version: 'latest' 25 | stack-no-global: true 26 | stack-setup-ghc: true 27 | 28 | - uses: actions/cache@v4 29 | name: Cache ~/.stack 30 | with: 31 | path: ~/.stack 32 | key: ${{ runner.os }}-${{ matrix.ghc }}-stack 33 | 34 | - name: Build 35 | run: stack build --test --no-run-tests --coverage ${{ matrix.flags }} 36 | 37 | - name: Test 38 | run: stack test --coverage ${{ matrix.flags }} 39 | 40 | - name: Coveralls 41 | continue-on-error: true 42 | env: 43 | COVERALLS_REPO_TOKEN: ${{ secrets.COVERALLS_REPO_TOKEN }} 44 | run: | 45 | curl -L https://github.com/rubik/stack-hpc-coveralls/releases/download/v0.0.7.0/shc-Linux-X64.tar.bz2 | tar xj shc 46 | ./shc --repo-token="$COVERALLS_REPO_TOKEN" data-interval test-interval 47 | -------------------------------------------------------------------------------- /CHANGELOG.markdown: -------------------------------------------------------------------------------- 1 | 2.1.2 2 | ----- 3 | 4 | * fix `Data.IntegerInterval.width` (#38, thanks to ncfavier) 5 | * add `Data.IntegerInterval.memberCount` (#44, thanks to ncfavier) 6 | * add `instance Ord` for `Interval`, `IntervalSet` and `IntervalMap` (#41, thanks to googleson78) 7 | * fix `Data.IntervalSet.insert` (#43) 8 | 9 | 2.1.1 10 | ----- 11 | 12 | * fix boundary comparison in `relate` (#30, thanks to marcosh) 13 | * fix behaviour of `lattices` flag 14 | 15 | 2.1.0 16 | ----- 17 | 18 | * introduce operations for Allen's interval algebra (#18, thanks to marcosh) 19 | * make `recip` precise when 0 is not an interior point (#21) 20 | * add `instance Storable` for `Interval` (#25) 21 | * add `instance Floating` for `Interval` (#26) 22 | 23 | 2.0.0 24 | ----- 25 | * change internal representation of `Interval` and `IntegerInterval` to 26 | reduce memory footprint (#7, thanks Bodigrim) 27 | * introduce `Boundary` type (#10, thanks Bodigrim) 28 | * export `isSingleton` function for `Interval` and `IntegerInterval` (#13) 29 | * remove deprecated `EndPoint` data type (#14, thanks Bodigrim) 30 | 31 | 1.3.1 32 | ----- 33 | * support lattices-2.0 (Thanks to Bodigrim). 34 | * move definitions of `Interval` and `IntegerInterval` data types into 35 | internal modules and abstract away representations from the rest of 36 | modules (Thanks to Bodigrim). 37 | 38 | 39 | 1.3.0 40 | ----- 41 | * add `Data.IntervalSet`, `Data.IntervalMap.Lazy`, `Data.IntervalMap.Strict` modules 42 | * add new function `mapMonotonic` to `Data.Interval` and `Data.IntegerInterval` 43 | * add new function `isConnected` to `Data.Interval`. 44 | 45 | 1.2.0 46 | ----- 47 | * add `Data.IntegerInterval` 48 | * use extended-reals >=0.2 49 | * `EndPoint` is deprecated. Use `Extended` instead. 50 | 51 | 1.1.1 52 | ----- 53 | * remove unnecessary `Real` constraint from comparison operators. 54 | 55 | 1.1.0 56 | ----- 57 | * remove unnecessary Num constraint from bunch of constructors and operations: 58 | `interval`, `(<=..<=)`, `(<..<=)`, `(<=..<)`, `(<..<)`, `whole`, `empty`, 59 | `singleton`, `intersection`, `intersections`, `hull`, `hulls`. 60 | Thanks to Tad Doxsee for pointing out that. 61 | 62 | 1.0.0 63 | ----- 64 | * use extended-reals package for representing endpoints 65 | * add (experimental) comparison operators that produce witnesses: 66 | `(=??)`, `(>??)` 67 | 68 | 0.6.0 69 | ----- 70 | * add `hulls, intersections :: (Num r, Ord r) => [Interval r] -> Interval r` 71 | * fix a bug of `(<=?)` operator 72 | 73 | 0.5.0 74 | ----- 75 | * fix dependency issue with QuickCheck and test-framework-quickcheck2 76 | 77 | 0.4.0 78 | ----- 79 | * add `simplestRationalWithin :: RealFrac r => Interval r -> Maybe Rational` 80 | -------------------------------------------------------------------------------- /src/Data/IntervalMap/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE Safe #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Data.IntervalMap.Base 6 | -- Copyright : (c) Masahiro Sakai 2016 7 | -- License : BSD-style 8 | -- 9 | -- Maintainer : masahiro.sakai@gmail.com 10 | -- Stability : provisional 11 | -- Portability : portable 12 | -- 13 | -- Mapping from intervals to values. 14 | -- 15 | -- API of this module is strict in the keys, but lazy in the values. 16 | -- If you need value-strict maps, use "Data.IntervalMap.Strict" instead. 17 | -- The 'IntervalMap' type itself is shared between the lazy and strict modules, 18 | -- meaning that the same 'IntervalMap' value can be passed to functions in 19 | -- both modules (although that is rarely needed). 20 | -- 21 | -- These modules are intended to be imported qualified, to avoid name 22 | -- clashes with Prelude functions, e.g. 23 | -- 24 | -- > import Data.IntervalMap.Lazy (IntervalMap) 25 | -- > import qualified Data.IntervalMap.Lazy as IntervalMap 26 | -- 27 | ----------------------------------------------------------------------------- 28 | module Data.IntervalMap.Lazy 29 | ( 30 | -- * Strictness properties 31 | -- $strictness 32 | 33 | -- * IntervalMap type 34 | IntervalMap 35 | , module Data.ExtendedReal 36 | 37 | -- * Operators 38 | , (!) 39 | , (\\) 40 | 41 | -- * Query 42 | , null 43 | , member 44 | , notMember 45 | , lookup 46 | , findWithDefault 47 | , span 48 | 49 | -- * Construction 50 | , whole 51 | , empty 52 | , singleton 53 | 54 | -- ** Insertion 55 | , insert 56 | , insertWith 57 | 58 | -- ** Delete\/Update 59 | , delete 60 | , adjust 61 | , update 62 | , alter 63 | 64 | -- * Combine 65 | , union 66 | , unionWith 67 | , unions 68 | , unionsWith 69 | , intersection 70 | , intersectionWith 71 | , difference 72 | 73 | -- * Traversal 74 | , map 75 | , mapKeysMonotonic 76 | 77 | -- * Conversion 78 | , elems 79 | , keys 80 | , assocs 81 | , keysSet 82 | 83 | -- ** List 84 | , fromList 85 | , fromListWith 86 | , toList 87 | 88 | -- ** Ordered List 89 | , toAscList 90 | , toDescList 91 | 92 | -- * Filter 93 | , filter 94 | , split 95 | 96 | -- * Submap 97 | , isSubmapOf 98 | , isSubmapOfBy 99 | , isProperSubmapOf 100 | , isProperSubmapOfBy 101 | ) 102 | where 103 | 104 | 105 | import Prelude hiding (null, lookup, map, filter, span) 106 | import Data.IntervalMap.Base 107 | import Data.ExtendedReal 108 | 109 | -- $strictness 110 | -- 111 | -- This module satisfies the following strictness property: 112 | -- 113 | -- * Key arguments are evaluated to WHNF 114 | -- 115 | -- Here are some examples that illustrate the property: 116 | -- 117 | -- > insert undefined v m == undefined 118 | -- > insert k undefined m == OK 119 | -- > delete undefined m == undefined 120 | -------------------------------------------------------------------------------- /src/Data/IntervalRelation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} 3 | {-# LANGUAGE Safe #-} 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Data.IntervalRelation 7 | -- Copyright : (c) Masahiro Sakai 2016 8 | -- License : BSD-style 9 | -- 10 | -- Maintainer : masahiro.sakai@gmail.com 11 | -- Stability : provisional 12 | -- 13 | -- Interval relations and their algebra. 14 | -- 15 | ----------------------------------------------------------------------------- 16 | module Data.IntervalRelation 17 | ( Relation(..) 18 | , invert 19 | ) 20 | where 21 | 22 | import Data.Data (Data) 23 | import GHC.Generics (Generic) 24 | 25 | -- | Describes how two intervals @x@ and @y@ can be related. 26 | -- See [Allen's interval algebra](https://en.wikipedia.org/wiki/Allen%27s_interval_algebra) 27 | -- and [Intervals and their relations](http://marcosh.github.io/post/2020/05/04/intervals-and-their-relations.html). 28 | data Relation 29 | = Before 30 | -- ^ Any element of @x@ is smaller than any element of @y@, 31 | -- and intervals are not connected. In other words, there exists an element 32 | -- that is bigger than any element of @x@ and smaller than any element of @y@. 33 | | JustBefore 34 | -- ^ Any element of @x@ is smaller than any element of @y@, 35 | -- but intervals are connected and non-empty. This implies that intersection 36 | -- of intervals is empty, and union is a single interval. 37 | | Overlaps 38 | -- ^ Intersection of @x@ and @y@ is non-empty, 39 | -- @x@ start and finishes earlier than @y@. This implies that union 40 | -- is a single interval, and @x@ finishes no earlier than @y@ starts. 41 | | Starts 42 | -- ^ @x@ is a proper subset of @y@, 43 | -- and they share lower bounds. 44 | | During 45 | -- ^ @x@ is a proper subset of @y@, 46 | -- but they share neither lower nor upper bounds. 47 | | Finishes 48 | -- ^ @x@ is a proper subset of @y@, 49 | -- and they share upper bounds. 50 | | Equal 51 | -- ^ Intervals are equal. 52 | | FinishedBy 53 | -- ^ Inverse of 'Finishes'. 54 | | Contains 55 | -- ^ Inverse of 'During'. 56 | | StartedBy 57 | -- ^ Inverse of 'Starts'. 58 | | OverlappedBy 59 | -- ^ Inverse of 'Overlaps'. 60 | | JustAfter 61 | -- ^ Inverse of 'JustBefore'. 62 | | After 63 | -- ^ Inverse of 'Before'. 64 | deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Data) 65 | 66 | -- | Inverts a relation, such that @'invert' ('Data.Interval.relate' x y) = 'Data.Interval.relate' y x@ 67 | invert :: Relation -> Relation 68 | invert relation = case relation of 69 | Before -> After 70 | JustBefore -> JustAfter 71 | Overlaps -> OverlappedBy 72 | Starts -> StartedBy 73 | During -> Contains 74 | Finishes -> FinishedBy 75 | Equal -> Equal 76 | FinishedBy -> Finishes 77 | Contains -> During 78 | StartedBy -> Starts 79 | OverlappedBy -> Overlaps 80 | JustAfter -> JustBefore 81 | After -> Before 82 | -------------------------------------------------------------------------------- /data-interval.cabal: -------------------------------------------------------------------------------- 1 | Name: data-interval 2 | Version: 2.1.2 3 | License: BSD3 4 | License-File: COPYING 5 | Author: Masahiro Sakai (masahiro.sakai@gmail.com) 6 | Maintainer: masahiro.sakai@gmail.com 7 | Category: Data, Math 8 | Cabal-Version: 2.0 9 | Synopsis: Interval datatype, interval arithmetic and interval-based containers 10 | Description: 11 | Interval datatype, interval arithmetic and interval-based containers for Haskell. 12 | Unlike the intervals package (), 13 | this package provides both open and closed intervals and is intended to be used 14 | with exact number types such as Rational and Integer. 15 | Bug-Reports: https://github.com/msakai/data-interval/issues 16 | Extra-Doc-Files: 17 | README.md 18 | CHANGELOG.markdown 19 | Build-Type: Simple 20 | Tested-With: 21 | GHC ==8.6.5 22 | GHC ==8.8.4 23 | GHC ==8.10.7 24 | GHC ==9.0.2 25 | GHC ==9.2.8 26 | GHC ==9.4.8 27 | GHC ==9.6.7 28 | GHC ==9.8.4 29 | GHC ==9.10.2 30 | GHC ==9.12.2 31 | 32 | source-repository head 33 | type: git 34 | location: https://github.com/msakai/data-interval 35 | 36 | flag lattices 37 | description: Derive lattice instances 38 | default: True 39 | 40 | Library 41 | Hs-source-dirs: src 42 | Build-Depends: 43 | base >=4.12 && <5 44 | , containers >= 0.5.8 && < 0.9 45 | , deepseq < 1.6 46 | , hashable >=1.1.2.5 && <1.6 47 | , extended-reals >=0.2 && <1.0 48 | if flag(lattices) 49 | build-depends: 50 | lattices >=2 && <2.3 51 | Default-Language: Haskell2010 52 | Other-Extensions: 53 | ScopedTypeVariables 54 | TypeFamilies 55 | DeriveDataTypeable 56 | DeriveGeneric 57 | LambdaCase 58 | MultiWayIf 59 | Safe 60 | Exposed-Modules: 61 | Data.Interval 62 | Data.IntervalMap.Lazy 63 | Data.IntervalMap.Strict 64 | Data.IntervalRelation 65 | Data.IntervalSet 66 | Data.IntegerInterval 67 | Other-Modules: 68 | Data.Interval.Internal 69 | Data.IntegerInterval.Internal 70 | Data.IntervalMap.Base 71 | 72 | Test-suite test-interval 73 | Type: exitcode-stdio-1.0 74 | HS-Source-Dirs: test 75 | Main-is: TestSuite.hs 76 | Other-Modules: 77 | TestInterval 78 | TestIntervalMap 79 | TestIntervalRelation 80 | TestIntervalSet 81 | TestIntegerInterval 82 | TestInstances 83 | Build-depends: 84 | base >=4 && <5 85 | , ChasingBottoms 86 | , containers 87 | , deepseq 88 | , hashable 89 | , data-interval 90 | , syb 91 | , tasty >=0.10.1 92 | , tasty-hunit >=0.9 && <0.11 93 | , tasty-quickcheck >=0.8.1 && <0.12 94 | , tasty-th 95 | , HUnit 96 | , QuickCheck >=2.5 && <3 97 | , quickcheck-classes-base 98 | if flag(lattices) 99 | build-depends: 100 | lattices 101 | Default-Language: Haskell2010 102 | Other-Extensions: 103 | TemplateHaskell 104 | ScopedTypeVariables 105 | -------------------------------------------------------------------------------- /src/Data/IntegerInterval/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE Safe #-} 4 | {-# LANGUAGE RoleAnnotations #-} 5 | 6 | module Data.IntegerInterval.Internal 7 | ( IntegerInterval 8 | , lowerBound 9 | , upperBound 10 | , (<=..<=) 11 | , empty 12 | ) where 13 | 14 | import Control.DeepSeq 15 | import Data.Data 16 | import Data.ExtendedReal 17 | import Data.Hashable 18 | 19 | infix 5 <=..<= 20 | 21 | -- | The intervals (/i.e./ connected and convex subsets) over integers (__Z__). 22 | data IntegerInterval 23 | = Whole 24 | | Empty 25 | | Point !Integer 26 | | LessOrEqual !Integer 27 | | GreaterOrEqual !Integer 28 | | BothClosed !Integer !Integer 29 | deriving (Eq) 30 | 31 | -- | Lower endpoint (/i.e./ greatest lower bound) of the interval. 32 | -- 33 | -- * 'lowerBound' of the empty interval is 'PosInf'. 34 | -- 35 | -- * 'lowerBound' of a left unbounded interval is 'NegInf'. 36 | -- 37 | -- * 'lowerBound' of an interval may or may not be a member of the interval. 38 | lowerBound :: IntegerInterval -> Extended Integer 39 | lowerBound = \case 40 | Whole -> NegInf 41 | Empty -> PosInf 42 | Point r -> Finite r 43 | LessOrEqual _ -> NegInf 44 | GreaterOrEqual r -> Finite r 45 | BothClosed p _ -> Finite p 46 | 47 | -- | Upper endpoint (/i.e./ least upper bound) of the interval. 48 | -- 49 | -- * 'upperBound' of the empty interval is 'NegInf'. 50 | -- 51 | -- * 'upperBound' of a right unbounded interval is 'PosInf'. 52 | -- 53 | -- * 'upperBound' of an interval is a member of the interval. 54 | upperBound :: IntegerInterval -> Extended Integer 55 | upperBound = \case 56 | Whole -> PosInf 57 | Empty -> NegInf 58 | Point r -> Finite r 59 | LessOrEqual r -> Finite r 60 | GreaterOrEqual _ -> PosInf 61 | BothClosed _ p -> Finite p 62 | 63 | -- This instance preserves data abstraction at the cost of inefficiency. 64 | -- We provide limited reflection services for the sake of data abstraction. 65 | 66 | instance Data IntegerInterval where 67 | gfoldl k z x = z (<=..<=) `k` lowerBound x `k` upperBound x 68 | toConstr _ = intervalConstr 69 | gunfold k z c = case constrIndex c of 70 | 1 -> k (k (z (<=..<=))) 71 | _ -> error "gunfold" 72 | dataTypeOf _ = intervalDataType 73 | 74 | intervalConstr :: Constr 75 | intervalConstr = mkConstr intervalDataType "<=..<=" [] Infix 76 | 77 | intervalDataType :: DataType 78 | intervalDataType = mkDataType "Data.IntegerInterval.Internal.IntegerInterval" [intervalConstr] 79 | 80 | instance NFData IntegerInterval where 81 | rnf = \case 82 | Whole -> () 83 | Empty -> () 84 | Point r -> rnf r 85 | LessOrEqual r -> rnf r 86 | GreaterOrEqual r -> rnf r 87 | BothClosed p q -> rnf p `seq` rnf q 88 | 89 | instance Hashable IntegerInterval where 90 | hashWithSalt s = \case 91 | Whole -> s `hashWithSalt` (1 :: Int) 92 | Empty -> s `hashWithSalt` (2 :: Int) 93 | Point r -> s `hashWithSalt` (3 :: Int) `hashWithSalt` r 94 | LessOrEqual r -> s `hashWithSalt` (4 :: Int) `hashWithSalt` r 95 | GreaterOrEqual r -> s `hashWithSalt` (5 :: Int) `hashWithSalt` r 96 | BothClosed p q -> s `hashWithSalt` (6 :: Int) `hashWithSalt` p `hashWithSalt` q 97 | 98 | -- | closed interval [@l@,@u@] 99 | (<=..<=) 100 | :: Extended Integer -- ^ lower bound @l@ 101 | -> Extended Integer -- ^ upper bound @u@ 102 | -> IntegerInterval 103 | (<=..<=) PosInf _ = empty 104 | (<=..<=) _ NegInf = empty 105 | (<=..<=) NegInf PosInf = Whole 106 | (<=..<=) NegInf (Finite ub) = LessOrEqual ub 107 | (<=..<=) (Finite lb) PosInf = GreaterOrEqual lb 108 | (<=..<=) (Finite lb) (Finite ub) = 109 | case compare lb ub of 110 | EQ -> Point lb 111 | LT -> BothClosed lb ub 112 | GT -> Empty 113 | {-# INLINE (<=..<=) #-} 114 | 115 | -- | empty (contradicting) interval 116 | empty :: IntegerInterval 117 | empty = Empty 118 | -------------------------------------------------------------------------------- /test/TestIntervalRelation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} 2 | module TestIntervalRelation (intervalRelationTestGroup) where 3 | 4 | import Test.Tasty.HUnit 5 | import Test.Tasty.QuickCheck 6 | import Test.Tasty.TH 7 | 8 | import Data.Interval as I 9 | import Data.IntervalRelation 10 | import Data.Ord (Down(..)) 11 | 12 | import TestInstances 13 | 14 | {-------------------------------------------------------------------- 15 | invert 16 | --------------------------------------------------------------------} 17 | 18 | prop_invert_is_involution a = 19 | invert (invert a) === a 20 | 21 | prop_invert_inverts_relation = 22 | forAllShrink intervals shrink $ \a -> 23 | forAllShrink intervals shrink $ \b -> 24 | relate a b === invert (relate b a) 25 | 26 | ------------------------------------------------------------------------ 27 | 28 | case_empty1 = 29 | relate (empty :: Interval Rational) empty @?= Equal 30 | 31 | prop_empty2 = 32 | forAllShrink intervals shrink $ \a -> not (I.null a) ==> 33 | relate (empty :: Interval Rational) a === During 34 | 35 | prop_empty3 = 36 | forAllShrink intervals shrink $ \a -> not (I.null a) ==> 37 | relate a (empty :: Interval Rational) === Contains 38 | 39 | prop_universal_lt = 40 | forAllShrink intervals shrink $ \a -> not (I.null a) ==> 41 | forAllShrink intervals shrink $ \b -> not (I.null b) ==> 42 | let r = relate a b in counterexample (show r) $ 43 | if a not (I.null a) ==> 48 | forAllShrink intervals shrink $ \b -> not (I.null b) ==> 49 | let r = relate a b in counterexample (show r) $ 50 | if a <=! b then r `elem` [Before, JustBefore, Overlaps, Starts, Equal, FinishedBy] 51 | else r `notElem` [Before, JustBefore] 52 | 53 | prop_universal_eq = 54 | forAllShrink intervals shrink $ \a -> not (I.null a) ==> 55 | forAllShrink intervals shrink $ \b -> not (I.null b) ==> 56 | not (a ==! b) || relate a b == Equal 57 | 58 | prop_universal_gt = 59 | forAllShrink intervals shrink $ \a -> 60 | forAllShrink intervals shrink $ \b -> 61 | (a >! b) === (b 65 | forAllShrink intervals shrink $ \b -> 66 | (a >=! b) === (b <=! a) 67 | 68 | prop_universal_ne = 69 | forAllShrink intervals shrink $ \a -> not (I.null a) ==> 70 | forAllShrink intervals shrink $ \b -> not (I.null b) ==> 71 | let r = relate a b in counterexample (show r) $ 72 | if a /=! b then r `elem` [Before, JustBefore, After, JustAfter] 73 | else r `notElem` [Before, JustBefore, After, JustAfter] 74 | 75 | ------------------------------------------------------------------------ 76 | 77 | prop_existential_lt = 78 | forAllShrink intervals shrink $ \a -> 79 | forAllShrink intervals shrink $ \b -> 80 | (a =! b) 81 | 82 | prop_existential_le = 83 | forAllShrink intervals shrink $ \a -> 84 | forAllShrink intervals shrink $ \b -> 85 | (a <=? b) === not (a >! b) 86 | 87 | prop_existential_eq = 88 | forAllShrink intervals shrink $ \a -> 89 | forAllShrink intervals shrink $ \b -> 90 | (a ==? b) === not (a /=! b) 91 | 92 | prop_existential_gt = 93 | forAllShrink intervals shrink $ \a -> 94 | forAllShrink intervals shrink $ \b -> 95 | (a >? b) === not (a <=! b) 96 | 97 | prop_existential_ge = 98 | forAllShrink intervals shrink $ \a -> 99 | forAllShrink intervals shrink $ \b -> 100 | (a >=? b) === not (a 104 | forAllShrink intervals shrink $ \b -> 105 | (a /=? b) === not (a ==! b) 106 | 107 | ------------------------------------------------------------------------ 108 | 109 | prop_before = 110 | forAllShrink intervals shrink $ \a -> 111 | forAllShrink intervals shrink $ \b -> 112 | let r = relate a b in counterexample (show r) $ 113 | (r == Before) === (a 117 | forAllShrink intervals shrink $ \b -> 118 | let r = relate a b in counterexample (show r) $ 119 | (r == JustBefore) === (a 123 | forAllShrink intervals shrink $ \b -> 124 | let r = relate a b in counterexample (show r) $ 125 | (r == Overlaps) === (not (I.null (intersection a b)) && fmap Down (lowerBound' a) < fmap Down (lowerBound' b) && upperBound' a < upperBound' b) 126 | 127 | prop_starts = 128 | forAllShrink intervals shrink $ \a -> 129 | forAllShrink intervals shrink $ \b -> 130 | let r = relate a b in counterexample (show r) $ 131 | (r == Starts) === (isProperSubsetOf a b && lowerBound' a == lowerBound' b) 132 | 133 | prop_during = 134 | forAllShrink intervals shrink $ \a -> 135 | forAllShrink intervals shrink $ \b -> 136 | let r = relate a b in counterexample (show r) $ 137 | (r == During) === (isProperSubsetOf a b && lowerBound' a /= lowerBound' b && upperBound' a /= upperBound' b) 138 | 139 | prop_finishes = 140 | forAllShrink intervals shrink $ \a -> 141 | forAllShrink intervals shrink $ \b -> 142 | let r = relate a b in counterexample (show r) $ 143 | (r == Finishes) === (isProperSubsetOf a b && upperBound' a == upperBound' b) 144 | 145 | prop_equal = 146 | forAllShrink intervals shrink $ \a -> 147 | forAllShrink intervals shrink $ \b -> 148 | let r = relate a b in counterexample (show r) $ 149 | (r == Equal) === (a == b) 150 | 151 | ------------------------------------------------------------------------ 152 | -- Test harness 153 | 154 | intervalRelationTestGroup = $(testGroupGenerator) 155 | -------------------------------------------------------------------------------- /src/Data/Interval/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric, LambdaCase, ScopedTypeVariables #-} 3 | {-# LANGUAGE Safe #-} 4 | {-# LANGUAGE RoleAnnotations #-} 5 | 6 | module Data.Interval.Internal 7 | ( Boundary(..) 8 | , Interval 9 | , lowerBound' 10 | , upperBound' 11 | , interval 12 | , empty 13 | ) where 14 | 15 | import Control.DeepSeq 16 | import Data.Data 17 | import Data.ExtendedReal 18 | import Data.Hashable 19 | import Data.Int 20 | import Foreign.Marshal.Array 21 | import Foreign.Ptr 22 | import Foreign.Storable 23 | import GHC.Generics (Generic) 24 | 25 | -- | Boundary of an interval may be 26 | -- open (excluding an endpoint) or closed (including an endpoint). 27 | -- 28 | -- @since 2.0.0 29 | data Boundary 30 | = Open 31 | | Closed 32 | deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Data) 33 | 34 | instance NFData Boundary 35 | 36 | instance Hashable Boundary 37 | 38 | -- | The intervals (/i.e./ connected and convex subsets) over a type @r@. 39 | data Interval r 40 | = Whole 41 | | Empty 42 | | Point !r 43 | | LessThan !r 44 | | LessOrEqual !r 45 | | GreaterThan !r 46 | | GreaterOrEqual !r 47 | -- For constructors below 48 | -- the first argument is strictly less than the second one 49 | | BothClosed !r !r 50 | | LeftOpen !r !r 51 | | RightOpen !r !r 52 | | BothOpen !r !r 53 | deriving 54 | ( Eq 55 | , Ord 56 | -- ^ Note that this Ord is derived and not semantically meaningful. 57 | -- The primary intended use case is to allow using 'Interval' 58 | -- in maps and sets that require ordering. 59 | ) 60 | 61 | peekInterval :: (Applicative m, Monad m, Ord r) => m Int8 -> m r -> m r -> m (Interval r) 62 | peekInterval tagM x y = do 63 | tag <- tagM 64 | case tag of 65 | 0 -> pure Whole 66 | 1 -> pure Empty 67 | 2 -> Point <$> x 68 | 3 -> LessThan <$> x 69 | 4 -> LessOrEqual <$> x 70 | 5 -> GreaterThan <$> x 71 | 6 -> GreaterOrEqual <$> x 72 | 7 -> wrap BothClosed <$> x <*> y 73 | 8 -> wrap LeftOpen <$> x <*> y 74 | 9 -> wrap RightOpen <$> x <*> y 75 | _ -> wrap BothOpen <$> x <*> y 76 | 77 | -- | Enforce the internal invariant 78 | -- of 'BothClosed' / 'LeftOpen' / 'RightOpen' / 'BothOpen'. 79 | wrap :: Ord r => (r -> r -> Interval r) -> r -> r -> Interval r 80 | wrap f x y 81 | | x < y = f x y 82 | | otherwise = Empty 83 | 84 | pokeInterval :: Applicative m => (Int8 -> m ()) -> (r -> m ()) -> (r -> m ()) -> Interval r -> m () 85 | pokeInterval tag actX actY = \case 86 | Whole -> tag (0 :: Int8) 87 | Empty -> tag (1 :: Int8) 88 | Point x -> tag (2 :: Int8) *> actX x 89 | LessThan x -> tag (3 :: Int8) *> actX x 90 | LessOrEqual x -> tag (4 :: Int8) *> actX x 91 | GreaterThan x -> tag (5 :: Int8) *> actX x 92 | GreaterOrEqual x -> tag (6 :: Int8) *> actX x 93 | BothClosed x y -> tag (7 :: Int8) *> actX x *> actY y 94 | LeftOpen x y -> tag (8 :: Int8) *> actX x *> actY y 95 | RightOpen x y -> tag (9 :: Int8) *> actX x *> actY y 96 | BothOpen x y -> tag (10 :: Int8) *> actX x *> actY y 97 | 98 | instance (Storable r, Ord r) => Storable (Interval r) where 99 | sizeOf _ = 3 * sizeOf (undefined :: r) 100 | alignment _ = alignment (undefined :: r) 101 | peek ptr = peekInterval 102 | (peek $ castPtr ptr) 103 | (peek $ castPtr ptr `advancePtr` 1) 104 | (peek $ castPtr ptr `advancePtr` 2) 105 | poke ptr = pokeInterval 106 | (poke $ castPtr ptr) 107 | (poke $ castPtr ptr `advancePtr` 1) 108 | (poke $ castPtr ptr `advancePtr` 2) 109 | 110 | -- | Lower endpoint (/i.e./ greatest lower bound) of the interval, 111 | -- together with 'Boundary' information. 112 | -- The result is convenient to use as an argument for 'interval'. 113 | lowerBound' :: Interval r -> (Extended r, Boundary) 114 | lowerBound' = \case 115 | Whole -> (NegInf, Open) 116 | Empty -> (PosInf, Open) 117 | Point r -> (Finite r, Closed) 118 | LessThan{} -> (NegInf, Open) 119 | LessOrEqual{} -> (NegInf, Open) 120 | GreaterThan r -> (Finite r, Open) 121 | GreaterOrEqual r -> (Finite r, Closed) 122 | BothClosed p _ -> (Finite p, Closed) 123 | LeftOpen p _ -> (Finite p, Open) 124 | RightOpen p _ -> (Finite p, Closed) 125 | BothOpen p _ -> (Finite p, Open) 126 | 127 | -- | Upper endpoint (/i.e./ least upper bound) of the interval, 128 | -- together with 'Boundary' information. 129 | -- The result is convenient to use as an argument for 'interval'. 130 | upperBound' :: Interval r -> (Extended r, Boundary) 131 | upperBound' = \case 132 | Whole -> (PosInf, Open) 133 | Empty -> (NegInf, Open) 134 | Point r -> (Finite r, Closed) 135 | LessThan r -> (Finite r, Open) 136 | LessOrEqual r -> (Finite r, Closed) 137 | GreaterThan{} -> (PosInf, Open) 138 | GreaterOrEqual{} -> (PosInf, Open) 139 | BothClosed _ q -> (Finite q, Closed) 140 | LeftOpen _ q -> (Finite q, Closed) 141 | RightOpen _ q -> (Finite q, Open) 142 | BothOpen _ q -> (Finite q, Open) 143 | 144 | type role Interval nominal 145 | 146 | instance (Ord r, Data r) => Data (Interval r) where 147 | gfoldl k z x = z interval `k` lowerBound' x `k` upperBound' x 148 | toConstr _ = intervalConstr 149 | gunfold k z c = case constrIndex c of 150 | 1 -> k (k (z interval)) 151 | _ -> error "gunfold" 152 | dataTypeOf _ = intervalDataType 153 | dataCast1 f = gcast1 f 154 | 155 | intervalConstr :: Constr 156 | intervalConstr = mkConstr intervalDataType "interval" [] Prefix 157 | 158 | intervalDataType :: DataType 159 | intervalDataType = mkDataType "Data.Interval.Internal.Interval" [intervalConstr] 160 | 161 | instance NFData r => NFData (Interval r) where 162 | rnf = \case 163 | Whole -> () 164 | Empty -> () 165 | Point r -> rnf r 166 | LessThan r -> rnf r 167 | LessOrEqual r -> rnf r 168 | GreaterThan r -> rnf r 169 | GreaterOrEqual r -> rnf r 170 | BothClosed p q -> rnf p `seq` rnf q 171 | LeftOpen p q -> rnf p `seq` rnf q 172 | RightOpen p q -> rnf p `seq` rnf q 173 | BothOpen p q -> rnf p `seq` rnf q 174 | 175 | instance Hashable r => Hashable (Interval r) where 176 | hashWithSalt s = \case 177 | Whole -> s `hashWithSalt` (1 :: Int) 178 | Empty -> s `hashWithSalt` (2 :: Int) 179 | Point r -> s `hashWithSalt` (3 :: Int) `hashWithSalt` r 180 | LessThan r -> s `hashWithSalt` (4 :: Int) `hashWithSalt` r 181 | LessOrEqual r -> s `hashWithSalt` (5 :: Int) `hashWithSalt` r 182 | GreaterThan r -> s `hashWithSalt` (6 :: Int) `hashWithSalt` r 183 | GreaterOrEqual r -> s `hashWithSalt` (7 :: Int) `hashWithSalt` r 184 | BothClosed p q -> s `hashWithSalt` (8 :: Int) `hashWithSalt` p `hashWithSalt` q 185 | LeftOpen p q -> s `hashWithSalt` (9 :: Int) `hashWithSalt` p `hashWithSalt` q 186 | RightOpen p q -> s `hashWithSalt` (10 :: Int) `hashWithSalt` p `hashWithSalt` q 187 | BothOpen p q -> s `hashWithSalt` (11 :: Int) `hashWithSalt` p `hashWithSalt` q 188 | 189 | -- | empty (contradicting) interval 190 | empty :: Ord r => Interval r 191 | empty = Empty 192 | 193 | -- | smart constructor for 'Interval' 194 | interval 195 | :: (Ord r) 196 | => (Extended r, Boundary) -- ^ lower bound and whether it is included 197 | -> (Extended r, Boundary) -- ^ upper bound and whether it is included 198 | -> Interval r 199 | interval = \case 200 | (NegInf, _) -> \case 201 | (NegInf, _) -> Empty 202 | (Finite r, Open) -> LessThan r 203 | (Finite r, Closed) -> LessOrEqual r 204 | (PosInf, _) -> Whole 205 | (Finite p, Open) -> \case 206 | (NegInf, _) -> Empty 207 | (Finite q, Open) 208 | | p < q -> BothOpen p q 209 | | otherwise -> Empty 210 | (Finite q, Closed) 211 | | p < q -> LeftOpen p q 212 | | otherwise -> Empty 213 | (PosInf, _) -> GreaterThan p 214 | (Finite p, Closed) -> \case 215 | (NegInf, _) -> Empty 216 | (Finite q, Open) 217 | | p < q -> RightOpen p q 218 | | otherwise -> Empty 219 | (Finite q, Closed) -> case p `compare` q of 220 | LT -> BothClosed p q 221 | EQ -> Point p 222 | GT -> Empty 223 | (PosInf, _) -> GreaterOrEqual p 224 | (PosInf, _) -> const Empty 225 | {-# INLINE interval #-} 226 | -------------------------------------------------------------------------------- /src/Data/IntervalMap/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE BangPatterns, TupleSections #-} 3 | {-# LANGUAGE Safe #-} 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Data.IntervalMap.Base 7 | -- Copyright : (c) Masahiro Sakai 2016 8 | -- License : BSD-style 9 | -- 10 | -- Maintainer : masahiro.sakai@gmail.com 11 | -- Stability : provisional 12 | -- Portability : non-portable (BangPatterns, TupleSections) 13 | -- 14 | -- Mapping from intervals to values. 15 | -- 16 | -- API of this module is strict in both the keys and the values. 17 | -- If you need value-lazy maps, use "Data.IntervalMap.Lazy" instead. 18 | -- The 'IntervalMap' type itself is shared between the lazy and strict modules, 19 | -- meaning that the same 'IntervalMap' value can be passed to functions in 20 | -- both modules (although that is rarely needed). 21 | -- 22 | -- These modules are intended to be imported qualified, to avoid name 23 | -- clashes with Prelude functions, e.g. 24 | -- 25 | -- > import Data.IntervalMap.Strict (IntervalMap) 26 | -- > import qualified Data.IntervalMap.Strict as IntervalMap 27 | -- 28 | ----------------------------------------------------------------------------- 29 | module Data.IntervalMap.Strict 30 | ( 31 | -- * Strictness properties 32 | -- $strictness 33 | 34 | -- * IntervalMap type 35 | IntervalMap 36 | , module Data.ExtendedReal 37 | 38 | -- * Operators 39 | , (!) 40 | , (\\) 41 | 42 | -- * Query 43 | , null 44 | , member 45 | , notMember 46 | , lookup 47 | , findWithDefault 48 | , span 49 | 50 | -- * Construction 51 | , whole 52 | , empty 53 | , singleton 54 | 55 | -- ** Insertion 56 | , insert 57 | , insertWith 58 | 59 | -- ** Delete\/Update 60 | , delete 61 | , adjust 62 | , update 63 | , alter 64 | 65 | -- * Combine 66 | , union 67 | , unionWith 68 | , unions 69 | , unionsWith 70 | , intersection 71 | , intersectionWith 72 | , difference 73 | 74 | -- * Traversal 75 | , map 76 | , mapKeysMonotonic 77 | 78 | -- * Conversion 79 | , elems 80 | , keys 81 | , assocs 82 | , keysSet 83 | 84 | -- ** List 85 | , fromList 86 | , fromListWith 87 | , toList 88 | 89 | -- ** Ordered List 90 | , toAscList 91 | , toDescList 92 | 93 | -- * Filter 94 | , filter 95 | , split 96 | 97 | -- * Submap 98 | , isSubmapOf 99 | , isSubmapOfBy 100 | , isProperSubmapOf 101 | , isProperSubmapOfBy 102 | ) 103 | where 104 | 105 | 106 | import Prelude hiding (Foldable(..), lookup, map, filter, span) 107 | import Data.ExtendedReal 108 | import Data.Foldable hiding (null, toList) 109 | import Data.Interval (Interval) 110 | import qualified Data.Interval as Interval 111 | import Data.IntervalMap.Base hiding 112 | ( whole 113 | , singleton 114 | , insert 115 | , insertWith 116 | , adjust 117 | , update 118 | , alter 119 | , unionWith 120 | , unionsWith 121 | , intersectionWith 122 | , map 123 | , fromList 124 | , fromListWith 125 | ) 126 | import qualified Data.IntervalMap.Base as B 127 | import qualified Data.IntervalSet as IntervalSet 128 | import qualified Data.Map.Strict as Map 129 | 130 | -- $strictness 131 | -- 132 | -- This module satisfies the following strictness properties: 133 | -- 134 | -- 1. Key arguments are evaluated to WHNF; 135 | -- 136 | -- 2. Keys and values are evaluated to WHNF before they are stored in 137 | -- the map. 138 | -- 139 | -- Here's an example illustrating the first property: 140 | -- 141 | -- > delete undefined m == undefined 142 | -- 143 | -- Here are some examples that illustrate the second property: 144 | -- 145 | -- > map (\ v -> undefined) m == undefined -- m is not empty 146 | -- > mapKeysMonotonic (\ k -> undefined) m == undefined -- m is not empty 147 | 148 | -- | The map that maps whole range of k to a. 149 | whole :: Ord k => a -> IntervalMap k a 150 | whole !a = B.whole a 151 | 152 | -- | A map with a single interval. 153 | singleton :: Ord k => Interval k -> a -> IntervalMap k a 154 | singleton i !a = B.singleton i a 155 | 156 | -- | insert a new key and value in the map. 157 | -- If the key is already present in the map, the associated value is 158 | -- replaced with the supplied value. 159 | insert :: Ord k => Interval k -> a -> IntervalMap k a -> IntervalMap k a 160 | insert i !a m = B.insert i a m 161 | 162 | -- | Insert with a function, combining new value and old value. 163 | -- @'insertWith' f key value mp@ will insert the pair (interval, value) into @mp@. 164 | -- If the interval overlaps with existing entries, the value for the entry is replace 165 | -- with @(f new_value old_value)@. 166 | insertWith :: Ord k => (a -> a -> a) -> Interval k -> a -> IntervalMap k a -> IntervalMap k a 167 | insertWith _ i _ m | Interval.null i = m 168 | insertWith f i !a m = alter g i m 169 | where 170 | g Nothing = Just a 171 | g (Just a') = Just $! f a a' 172 | 173 | -- | Update a value at a specific interval with the result of the provided function. 174 | -- When the interval does not overlatp with the map, the original map is returned. 175 | adjust :: Ord k => (a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a 176 | adjust f = update (Just . f) 177 | 178 | -- | The expression (@'update' f i map@) updates the value @x@ 179 | -- at @i@ (if it is in the map). If (@f x@) is 'Nothing', the element is 180 | -- deleted. If it is (@'Just' y@), the key @i@ is bound to the new value @y@. 181 | update :: Ord k => (a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a 182 | update _ i m | Interval.null i = m 183 | update f i m = 184 | case split i m of 185 | (IntervalMap m1, IntervalMap m2, IntervalMap m3) -> 186 | IntervalMap $ Map.unions [m1, Map.mapMaybe (\(j,a) -> (\b -> seq b (j,b)) <$> f a) m2, m3] 187 | 188 | -- | The expression (@'alter' f i map@) alters the value @x@ at @i@, or absence thereof. 189 | -- 'alter' can be used to insert, delete, or update a value in a 'IntervalMap'. 190 | alter :: Ord k => (Maybe a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a 191 | alter _ i m | Interval.null i = m 192 | alter f i m = 193 | case split i m of 194 | (IntervalMap m1, IntervalMap m2, IntervalMap m3) -> 195 | let m2' = Map.mapMaybe (\(j,a) -> (\b -> seq b (j,b)) <$> f (Just a)) m2 196 | js = IntervalSet.singleton i `IntervalSet.difference` keysSet (IntervalMap m2) 197 | IntervalMap m2'' = 198 | case f Nothing of 199 | Nothing -> empty 200 | Just !a -> B.fromList [(j,a) | j <- IntervalSet.toList js] 201 | in seq m2' $ IntervalMap $ Map.unions [m1, m2', m2'', m3] 202 | 203 | -- ------------------------------------------------------------------------ 204 | -- Combine 205 | 206 | -- | Union with a combining function. 207 | unionWith :: Ord k => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a 208 | unionWith f m1 m2 = 209 | foldl' (\m (i,a) -> insertWith f i a m) m2 (toList m1) 210 | 211 | -- | The union of a list of maps, with a combining operation: 212 | -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@). 213 | unionsWith :: Ord k => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a 214 | unionsWith f = foldl' (unionWith f) empty 215 | 216 | -- | Intersection with a combining function. 217 | intersectionWith :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c 218 | intersectionWith f im1@(IntervalMap m1) im2@(IntervalMap m2) 219 | | Map.size m1 >= Map.size m2 = g f im1 im2 220 | | otherwise = g (flip f) im2 im1 221 | where 222 | g :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c 223 | g h jm1 (IntervalMap m3) = IntervalMap $ Map.unions $ go jm1 (Map.elems m3) 224 | where 225 | go _ [] = [] 226 | go im ((i,b) : xs) = 227 | case split i im of 228 | (_, IntervalMap m, jm2) -> 229 | Map.map (\(j, a) -> (j,) $! h a b) m : go jm2 xs 230 | 231 | -- ------------------------------------------------------------------------ 232 | -- Traversal 233 | 234 | -- | Map a function over all values in the map. 235 | map :: (a -> b) -> IntervalMap k a -> IntervalMap k b 236 | map f (IntervalMap m) = IntervalMap $ Map.map (\(i, a) -> (i,) $! f a) m 237 | 238 | -- ------------------------------------------------------------------------ 239 | -- Conversion 240 | 241 | -- | Build a map from a list of key\/value pairs. 242 | -- If the list contains more than one value for the same key, the last value 243 | -- for the key is retained. 244 | fromList :: Ord k => [(Interval k, a)] -> IntervalMap k a 245 | fromList = foldl' (\m (i,a) -> insert i a m) empty 246 | 247 | -- | Build a map from a list of key\/value pairs with a combining function. 248 | fromListWith :: Ord k => (a -> a -> a) -> [(Interval k, a)] -> IntervalMap k a 249 | fromListWith f = foldl' (\m (i,a) -> insertWith f i a m) empty 250 | -------------------------------------------------------------------------------- /.github/workflows/build.yaml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'data-interval.cabal' '--output' '.github/workflows/build.yaml' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250605 12 | # 13 | # REGENDATA ("0.19.20250605",["github","data-interval.cabal","--output",".github/workflows/build.yaml"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-24.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.2 32 | compilerKind: ghc 33 | compilerVersion: 9.12.2 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.10.2 37 | compilerKind: ghc 38 | compilerVersion: 9.10.2 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.7 47 | compilerKind: ghc 48 | compilerVersion: 9.6.7 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.2.8 57 | compilerKind: ghc 58 | compilerVersion: 9.2.8 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-9.0.2 62 | compilerKind: ghc 63 | compilerVersion: 9.0.2 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.10.7 67 | compilerKind: ghc 68 | compilerVersion: 8.10.7 69 | setup-method: ghcup 70 | allow-failure: false 71 | - compiler: ghc-8.8.4 72 | compilerKind: ghc 73 | compilerVersion: 8.8.4 74 | setup-method: ghcup 75 | allow-failure: false 76 | - compiler: ghc-8.6.5 77 | compilerKind: ghc 78 | compilerVersion: 8.6.5 79 | setup-method: ghcup 80 | allow-failure: false 81 | fail-fast: false 82 | steps: 83 | - name: apt-get install 84 | run: | 85 | apt-get update 86 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 87 | - name: Install GHCup 88 | run: | 89 | mkdir -p "$HOME/.ghcup/bin" 90 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 91 | chmod a+x "$HOME/.ghcup/bin/ghcup" 92 | - name: Install cabal-install 93 | run: | 94 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 95 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 96 | - name: Install GHC (GHCup) 97 | if: matrix.setup-method == 'ghcup' 98 | run: | 99 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 100 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 101 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 102 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 103 | echo "HC=$HC" >> "$GITHUB_ENV" 104 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 105 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 106 | env: 107 | HCKIND: ${{ matrix.compilerKind }} 108 | HCNAME: ${{ matrix.compiler }} 109 | HCVER: ${{ matrix.compilerVersion }} 110 | - name: Set PATH and environment variables 111 | run: | 112 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 113 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 114 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 115 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 116 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 117 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 118 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 119 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 120 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 121 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 122 | env: 123 | HCKIND: ${{ matrix.compilerKind }} 124 | HCNAME: ${{ matrix.compiler }} 125 | HCVER: ${{ matrix.compilerVersion }} 126 | - name: env 127 | run: | 128 | env 129 | - name: write cabal config 130 | run: | 131 | mkdir -p $CABAL_DIR 132 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 165 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 166 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 167 | rm -f cabal-plan.xz 168 | chmod a+x $HOME/.cabal/bin/cabal-plan 169 | cabal-plan --version 170 | - name: checkout 171 | uses: actions/checkout@v4 172 | with: 173 | path: source 174 | - name: initial cabal.project for sdist 175 | run: | 176 | touch cabal.project 177 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 178 | cat cabal.project 179 | - name: sdist 180 | run: | 181 | mkdir -p sdist 182 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 183 | - name: unpack 184 | run: | 185 | mkdir -p unpacked 186 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 187 | - name: generate cabal.project 188 | run: | 189 | PKGDIR_data_interval="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/data-interval-[0-9.]*')" 190 | echo "PKGDIR_data_interval=${PKGDIR_data_interval}" >> "$GITHUB_ENV" 191 | rm -f cabal.project cabal.project.local 192 | touch cabal.project 193 | touch cabal.project.local 194 | echo "packages: ${PKGDIR_data_interval}" >> cabal.project 195 | echo "package data-interval" >> cabal.project 196 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 197 | cat >> cabal.project <> cabal.project.local 200 | cat cabal.project 201 | cat cabal.project.local 202 | - name: dump install plan 203 | run: | 204 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 205 | cabal-plan 206 | - name: restore cache 207 | uses: actions/cache/restore@v4 208 | with: 209 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 210 | path: ~/.cabal/store 211 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 212 | - name: install dependencies 213 | run: | 214 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 215 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 216 | - name: build w/o tests 217 | run: | 218 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 219 | - name: build 220 | run: | 221 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 222 | - name: tests 223 | run: | 224 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 225 | - name: cabal check 226 | run: | 227 | cd ${PKGDIR_data_interval} || false 228 | ${CABAL} -vnormal check 229 | - name: haddock 230 | run: | 231 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 232 | - name: unconstrained build 233 | run: | 234 | rm -f cabal.project.local 235 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 236 | - name: prepare for constraint sets 237 | run: | 238 | rm -f cabal.project.local 239 | - name: constraint set no-lattices 240 | run: | 241 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='data-interval -lattices' all --dry-run 242 | cabal-plan topo | sort 243 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='data-interval -lattices' --dependencies-only -j2 all 244 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='data-interval -lattices' all 245 | - name: save cache 246 | if: always() 247 | uses: actions/cache/save@v4 248 | with: 249 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 250 | path: ~/.cabal/store 251 | -------------------------------------------------------------------------------- /src/Data/IntervalSet.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE CPP, LambdaCase, ScopedTypeVariables, TypeFamilies, MultiWayIf #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | {-# LANGUAGE RoleAnnotations #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.IntervalSet 8 | -- Copyright : (c) Masahiro Sakai 2016 9 | -- License : BSD-style 10 | -- 11 | -- Maintainer : masahiro.sakai@gmail.com 12 | -- Stability : provisional 13 | -- 14 | -- Interval datatype and interval arithmetic. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | module Data.IntervalSet 18 | ( 19 | -- * IntervalSet type 20 | IntervalSet 21 | , module Data.ExtendedReal 22 | 23 | -- * Construction 24 | , whole 25 | , empty 26 | , singleton 27 | 28 | -- * Query 29 | , null 30 | , member 31 | , notMember 32 | , isSubsetOf 33 | , isProperSubsetOf 34 | , span 35 | 36 | -- * Construction 37 | , complement 38 | , insert 39 | , delete 40 | 41 | -- * Combine 42 | , union 43 | , unions 44 | , intersection 45 | , intersections 46 | , difference 47 | 48 | -- * Conversion 49 | 50 | -- ** List 51 | , fromList 52 | , toList 53 | 54 | -- ** Ordered list 55 | , toAscList 56 | , toDescList 57 | , fromAscList 58 | ) 59 | where 60 | 61 | import Prelude hiding (Foldable(..), span) 62 | #ifdef MIN_VERSION_lattices 63 | import Algebra.Lattice 64 | #endif 65 | import Control.DeepSeq 66 | import Data.Data 67 | import Data.ExtendedReal 68 | import Data.Foldable hiding (null, toList) 69 | import Data.Function 70 | import Data.Hashable 71 | import Data.List (sortBy) 72 | import Data.Map (Map) 73 | import qualified Data.Map as Map 74 | import Data.Maybe 75 | import qualified Data.Semigroup as Semigroup 76 | import Data.Interval (Interval, Boundary(..)) 77 | import qualified Data.Interval as Interval 78 | import qualified GHC.Exts as GHCExts 79 | 80 | -- | A set comprising zero or more non-empty, /disconnected/ intervals. 81 | -- 82 | -- Any connected intervals are merged together, and empty intervals are ignored. 83 | newtype IntervalSet r = IntervalSet (Map (Extended r) (Interval r)) 84 | deriving 85 | ( Eq 86 | , Ord 87 | -- ^ Note that this Ord is derived and not semantically meaningful. 88 | -- The primary intended use case is to allow using 'IntervalSet' 89 | -- in maps and sets that require ordering. 90 | ) 91 | 92 | type role IntervalSet nominal 93 | 94 | instance (Ord r, Show r) => Show (IntervalSet r) where 95 | showsPrec p (IntervalSet m) = showParen (p > appPrec) $ 96 | showString "fromList " . 97 | showsPrec (appPrec+1) (Map.elems m) 98 | 99 | instance (Ord r, Read r) => Read (IntervalSet r) where 100 | readsPrec p = 101 | (readParen (p > appPrec) $ \s0 -> do 102 | ("fromList",s1) <- lex s0 103 | (xs,s2) <- readsPrec (appPrec+1) s1 104 | return (fromList xs, s2)) 105 | 106 | appPrec :: Int 107 | appPrec = 10 108 | 109 | -- This instance preserves data abstraction at the cost of inefficiency. 110 | -- We provide limited reflection services for the sake of data abstraction. 111 | 112 | instance (Ord r, Data r) => Data (IntervalSet r) where 113 | gfoldl k z x = z fromList `k` toList x 114 | toConstr _ = fromListConstr 115 | gunfold k z c = case constrIndex c of 116 | 1 -> k (z fromList) 117 | _ -> error "gunfold" 118 | dataTypeOf _ = setDataType 119 | dataCast1 f = gcast1 f 120 | 121 | fromListConstr :: Constr 122 | fromListConstr = mkConstr setDataType "fromList" [] Prefix 123 | 124 | setDataType :: DataType 125 | setDataType = mkDataType "Data.IntervalSet.IntervalSet" [fromListConstr] 126 | 127 | instance NFData r => NFData (IntervalSet r) where 128 | rnf (IntervalSet m) = rnf m 129 | 130 | instance Hashable r => Hashable (IntervalSet r) where 131 | hashWithSalt s (IntervalSet m) = hashWithSalt s (Map.toList m) 132 | 133 | #ifdef MIN_VERSION_lattices 134 | instance (Ord r) => Lattice (IntervalSet r) where 135 | (\/) = union 136 | (/\) = intersection 137 | 138 | instance (Ord r) => BoundedJoinSemiLattice (IntervalSet r) where 139 | bottom = empty 140 | 141 | instance (Ord r) => BoundedMeetSemiLattice (IntervalSet r) where 142 | top = whole 143 | #endif 144 | 145 | instance Ord r => Monoid (IntervalSet r) where 146 | mempty = empty 147 | mappend = (Semigroup.<>) 148 | mconcat = unions 149 | 150 | instance (Ord r) => Semigroup.Semigroup (IntervalSet r) where 151 | (<>) = union 152 | stimes = Semigroup.stimesIdempotentMonoid 153 | 154 | lift1 155 | :: Ord r => (Interval r -> Interval r) 156 | -> IntervalSet r -> IntervalSet r 157 | lift1 f as = fromList [f a | a <- toList as] 158 | 159 | lift2 160 | :: Ord r => (Interval r -> Interval r -> Interval r) 161 | -> IntervalSet r -> IntervalSet r -> IntervalSet r 162 | lift2 f as bs = fromList [f a b | a <- toList as, b <- toList bs] 163 | 164 | instance (Num r, Ord r) => Num (IntervalSet r) where 165 | (+) = lift2 (+) 166 | 167 | (*) = lift2 (*) 168 | 169 | negate = lift1 negate 170 | 171 | abs = lift1 abs 172 | 173 | fromInteger i = singleton (fromInteger i) 174 | 175 | signum xs = fromList $ do 176 | x <- toList xs 177 | y <- 178 | [ if Interval.member 0 x 179 | then Interval.singleton 0 180 | else Interval.empty 181 | , if Interval.null ((0 Interval.<..< inf) `Interval.intersection` x) 182 | then Interval.empty 183 | else Interval.singleton 1 184 | , if Interval.null ((-inf Interval.<..< 0) `Interval.intersection` x) 185 | then Interval.empty 186 | else Interval.singleton (-1) 187 | ] 188 | return y 189 | 190 | -- | @recip (recip xs) == delete 0 xs@ 191 | instance forall r. (Real r, Fractional r) => Fractional (IntervalSet r) where 192 | fromRational r = singleton (fromRational r) 193 | recip xs = lift1 recip (delete (Interval.singleton 0) xs) 194 | 195 | instance Ord r => GHCExts.IsList (IntervalSet r) where 196 | type Item (IntervalSet r) = Interval r 197 | fromList = fromList 198 | toList = toList 199 | 200 | -- ----------------------------------------------------------------------- 201 | 202 | -- | whole real number line (-∞, ∞) 203 | whole :: Ord r => IntervalSet r 204 | whole = singleton $ Interval.whole 205 | 206 | -- | empty interval set 207 | empty :: Ord r => IntervalSet r 208 | empty = IntervalSet Map.empty 209 | 210 | -- | single interval 211 | singleton :: Ord r => Interval r -> IntervalSet r 212 | singleton i 213 | | Interval.null i = empty 214 | | otherwise = IntervalSet $ Map.singleton (Interval.lowerBound i) i 215 | 216 | -- ----------------------------------------------------------------------- 217 | 218 | -- | Is the interval set empty? 219 | null :: IntervalSet r -> Bool 220 | null (IntervalSet m) = Map.null m 221 | 222 | -- | Is the element in the interval set? 223 | member :: Ord r => r -> IntervalSet r -> Bool 224 | member x (IntervalSet m) = 225 | case Map.lookupLE (Finite x) m of 226 | Nothing -> False 227 | Just (_,i) -> Interval.member x i 228 | 229 | -- | Is the element not in the interval set? 230 | notMember :: Ord r => r -> IntervalSet r -> Bool 231 | notMember x is = not $ x `member` is 232 | 233 | -- | Is this a subset? 234 | -- @(is1 \``isSubsetOf`\` is2)@ tells whether @is1@ is a subset of @is2@. 235 | isSubsetOf :: Ord r => IntervalSet r -> IntervalSet r -> Bool 236 | isSubsetOf is1 is2 = all (\i1 -> f i1 is2) (toList is1) 237 | where 238 | f i1 (IntervalSet m) = 239 | case Map.lookupLE (Interval.lowerBound i1) m of 240 | Nothing -> False 241 | Just (_,i2) -> Interval.isSubsetOf i1 i2 242 | 243 | -- | Is this a proper subset? (/i.e./ a subset but not equal). 244 | isProperSubsetOf :: Ord r => IntervalSet r -> IntervalSet r -> Bool 245 | isProperSubsetOf is1 is2 = isSubsetOf is1 is2 && is1 /= is2 246 | 247 | -- | convex hull of a set of intervals. 248 | span :: Ord r => IntervalSet r -> Interval r 249 | span (IntervalSet m) = 250 | case Map.minView m of 251 | Nothing -> Interval.empty 252 | Just (i1, _) -> 253 | case Map.maxView m of 254 | Nothing -> Interval.empty 255 | Just (i2, _) -> 256 | Interval.interval (Interval.lowerBound' i1) (Interval.upperBound' i2) 257 | 258 | -- ----------------------------------------------------------------------- 259 | 260 | -- | Complement the interval set. 261 | complement :: Ord r => IntervalSet r -> IntervalSet r 262 | complement (IntervalSet m) = fromAscList $ f (NegInf,Open) (Map.elems m) 263 | where 264 | f prev [] = [ Interval.interval prev (PosInf,Open) ] 265 | f prev (i : is) = 266 | case (Interval.lowerBound' i, Interval.upperBound' i) of 267 | ((lb, in1), (ub, in2)) -> 268 | Interval.interval prev (lb, notB in1) : f (ub, notB in2) is 269 | 270 | -- | Insert a new interval into the interval set. 271 | insert :: Ord r => Interval r -> IntervalSet r -> IntervalSet r 272 | insert i is | Interval.null i = is 273 | insert i (IntervalSet is) = IntervalSet $ Map.unions 274 | [ smaller' 275 | , case fromList $ i : maybeToList m0 ++ maybeToList m1 ++ maybeToList m2 of 276 | IntervalSet m -> m 277 | , larger 278 | ] 279 | where 280 | (smaller, m1, xs) = splitLookupLE (Interval.lowerBound i) is 281 | (_, m2, larger) = splitLookupLE (Interval.upperBound i) xs 282 | 283 | -- A tricky case is when an interval @i@ connects two adjacent 284 | -- members of IntervalSet, e. g., inserting {0} into (whole \\ {0}). 285 | (smaller', m0) = case Map.maxView smaller of 286 | Nothing -> (smaller, Nothing) 287 | Just (v, rest) 288 | | Interval.isConnected v i -> (rest, Just v) 289 | _ -> (smaller, Nothing) 290 | 291 | -- | Delete an interval from the interval set. 292 | delete :: Ord r => Interval r -> IntervalSet r -> IntervalSet r 293 | delete i is | Interval.null i = is 294 | delete i (IntervalSet is) = IntervalSet $ 295 | case splitLookupLE (Interval.lowerBound i) is of 296 | (smaller, m1, xs) -> 297 | case splitLookupLE (Interval.upperBound i) xs of 298 | (_, m2, larger) -> 299 | Map.unions 300 | [ smaller 301 | , case m1 of 302 | Nothing -> Map.empty 303 | Just j -> Map.fromList 304 | [ (Interval.lowerBound k, k) 305 | | i' <- [upTo i, downTo i], let k = i' `Interval.intersection` j, not (Interval.null k) 306 | ] 307 | , if 308 | | Just j <- m2, j' <- downTo i `Interval.intersection` j, not (Interval.null j') -> 309 | Map.singleton (Interval.lowerBound j') j' 310 | | otherwise -> Map.empty 311 | , larger 312 | ] 313 | 314 | -- | union of two interval sets 315 | union :: Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r 316 | union is1@(IntervalSet m1) is2@(IntervalSet m2) = 317 | if Map.size m1 >= Map.size m2 318 | then foldl' (\is i -> insert i is) is1 (toList is2) 319 | else foldl' (\is i -> insert i is) is2 (toList is1) 320 | 321 | -- | union of a list of interval sets 322 | unions :: Ord r => [IntervalSet r] -> IntervalSet r 323 | unions = foldl' union empty 324 | 325 | -- | intersection of two interval sets 326 | intersection :: Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r 327 | intersection is1 is2 = difference is1 (complement is2) 328 | 329 | -- | intersection of a list of interval sets 330 | intersections :: Ord r => [IntervalSet r] -> IntervalSet r 331 | intersections = foldl' intersection whole 332 | 333 | -- | difference of two interval sets 334 | difference :: Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r 335 | difference is1 is2 = 336 | foldl' (\is i -> delete i is) is1 (toList is2) 337 | 338 | -- ----------------------------------------------------------------------- 339 | 340 | -- | Build a interval set from a list of intervals. 341 | fromList :: Ord r => [Interval r] -> IntervalSet r 342 | fromList = IntervalSet . fromAscList' . sortBy (compareLB `on` Interval.lowerBound') 343 | 344 | -- | Build a map from an ascending list of intervals. 345 | -- /The precondition is not checked./ 346 | fromAscList :: Ord r => [Interval r] -> IntervalSet r 347 | fromAscList = IntervalSet . fromAscList' 348 | 349 | fromAscList' :: Ord r => [Interval r] -> Map (Extended r) (Interval r) 350 | fromAscList' = Map.fromDistinctAscList . map (\i -> (Interval.lowerBound i, i)) . f 351 | where 352 | f :: Ord r => [Interval r] -> [Interval r] 353 | f [] = [] 354 | f (x : xs) = g x xs 355 | g x [] = [x | not (Interval.null x)] 356 | g x (y : ys) 357 | | Interval.null x = g y ys 358 | | Interval.isConnected x y = g (x `Interval.hull` y) ys 359 | | otherwise = x : g y ys 360 | 361 | -- | Convert a interval set into a list of intervals. 362 | toList :: Ord r => IntervalSet r -> [Interval r] 363 | toList = toAscList 364 | 365 | -- | Convert a interval set into a list of intervals in ascending order. 366 | toAscList :: Ord r => IntervalSet r -> [Interval r] 367 | toAscList (IntervalSet m) = Map.elems m 368 | 369 | -- | Convert a interval set into a list of intervals in descending order. 370 | toDescList :: Ord r => IntervalSet r -> [Interval r] 371 | toDescList (IntervalSet m) = fmap snd $ Map.toDescList m 372 | 373 | -- ----------------------------------------------------------------------- 374 | 375 | splitLookupLE :: Ord k => k -> Map k v -> (Map k v, Maybe v, Map k v) 376 | splitLookupLE k m = 377 | case Map.spanAntitone (<= k) m of 378 | (lessOrEqual, greaterThan) -> 379 | case Map.maxView lessOrEqual of 380 | Just (v, lessOrEqual') -> (lessOrEqual', Just v, greaterThan) 381 | Nothing -> (lessOrEqual, Nothing, greaterThan) 382 | 383 | compareLB :: Ord r => (Extended r, Boundary) -> (Extended r, Boundary) -> Ordering 384 | compareLB (lb1, lb1in) (lb2, lb2in) = 385 | -- inclusive lower endpoint shuold be considered smaller 386 | (lb1 `compare` lb2) `mappend` (lb2in `compare` lb1in) 387 | 388 | upTo :: Ord r => Interval r -> Interval r 389 | upTo i = 390 | case Interval.lowerBound' i of 391 | (NegInf, _) -> Interval.empty 392 | (PosInf, _) -> Interval.whole 393 | (Finite lb, incl) -> 394 | Interval.interval (NegInf, Open) (Finite lb, notB incl) 395 | 396 | downTo :: Ord r => Interval r -> Interval r 397 | downTo i = 398 | case Interval.upperBound' i of 399 | (PosInf, _) -> Interval.empty 400 | (NegInf, _) -> Interval.whole 401 | (Finite ub, incl) -> 402 | Interval.interval (Finite ub, notB incl) (PosInf, Open) 403 | 404 | notB :: Boundary -> Boundary 405 | notB = \case 406 | Open -> Closed 407 | Closed -> Open 408 | -------------------------------------------------------------------------------- /src/Data/IntegerInterval.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} 2 | {-# LANGUAGE CPP, ScopedTypeVariables #-} 3 | {-# LANGUAGE Safe #-} 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Data.IntegerInterval 7 | -- Copyright : (c) Masahiro Sakai 2011-2014 8 | -- License : BSD-style 9 | -- 10 | -- Maintainer : masahiro.sakai@gmail.com 11 | -- Stability : provisional 12 | -- 13 | -- Interval datatype and interval arithmetic over integers. 14 | -- 15 | -- @since 1.2.0 16 | -- 17 | -- For the purpose of abstract interpretation, it might be convenient to use 18 | -- 'Lattice' instance. See also lattices package 19 | -- (). 20 | -- 21 | ----------------------------------------------------------------------------- 22 | module Data.IntegerInterval 23 | ( 24 | -- * Interval type 25 | IntegerInterval 26 | , module Data.ExtendedReal 27 | , Boundary(..) 28 | 29 | -- * Construction 30 | , interval 31 | , (<=..<=) 32 | , (<..<=) 33 | , (<=..<) 34 | , (<..<) 35 | , whole 36 | , empty 37 | , singleton 38 | 39 | -- * Query 40 | , null 41 | , isSingleton 42 | , member 43 | , notMember 44 | , isSubsetOf 45 | , isProperSubsetOf 46 | , isConnected 47 | , lowerBound 48 | , upperBound 49 | , lowerBound' 50 | , upperBound' 51 | , width 52 | , memberCount 53 | 54 | -- * Universal comparison operators 55 | , (=!), (>!), (/=!) 56 | 57 | -- * Existential comparison operators 58 | , (=?), (>?), (/=?) 59 | 60 | -- * Existential comparison operators that produce witnesses (experimental) 61 | , (=??), (>??), (/=??) 62 | 63 | -- * Combine 64 | , intersection 65 | , intersections 66 | , hull 67 | , hulls 68 | 69 | -- * Map 70 | , mapMonotonic 71 | 72 | -- * Operations 73 | , pickup 74 | , simplestIntegerWithin 75 | 76 | -- * Conversion 77 | , toInterval 78 | , fromInterval 79 | , fromIntervalOver 80 | , fromIntervalUnder 81 | 82 | -- * Intervals relation 83 | , relate 84 | ) where 85 | 86 | #ifdef MIN_VERSION_lattices 87 | import Algebra.Lattice 88 | #endif 89 | import Control.Exception (assert) 90 | import Control.Monad hiding (join) 91 | import Data.ExtendedReal 92 | import Data.Foldable hiding (null) 93 | import Data.Maybe 94 | import Prelude hiding (Foldable(..)) 95 | import Data.IntegerInterval.Internal 96 | import Data.Interval.Internal (Boundary(..)) 97 | import qualified Data.Interval.Internal as Interval 98 | import Data.IntervalRelation 99 | 100 | infix 5 <..<= 101 | infix 5 <=..< 102 | infix 5 <..< 103 | infix 4 =! 107 | infix 4 >! 108 | infix 4 /=! 109 | infix 4 =? 113 | infix 4 >? 114 | infix 4 /=? 115 | infix 4 =?? 119 | infix 4 >?? 120 | infix 4 /=?? 121 | 122 | -- | 'lowerBound' of the interval and whether it is included in the interval. 123 | -- The result is convenient to use as an argument for 'interval'. 124 | lowerBound' :: IntegerInterval -> (Extended Integer, Boundary) 125 | lowerBound' x = 126 | case lowerBound x of 127 | lb@(Finite _) -> (lb, Closed) 128 | lb@_ -> (lb, Open) 129 | 130 | -- | 'upperBound' of the interval and whether it is included in the interval. 131 | -- The result is convenient to use as an argument for 'interval'. 132 | upperBound' :: IntegerInterval -> (Extended Integer, Boundary) 133 | upperBound' x = 134 | case upperBound x of 135 | ub@(Finite _) -> (ub, Closed) 136 | ub@_ -> (ub, Open) 137 | 138 | #ifdef MIN_VERSION_lattices 139 | instance Lattice IntegerInterval where 140 | (\/) = hull 141 | (/\) = intersection 142 | 143 | instance BoundedJoinSemiLattice IntegerInterval where 144 | bottom = empty 145 | 146 | instance BoundedMeetSemiLattice IntegerInterval where 147 | top = whole 148 | #endif 149 | 150 | instance Show IntegerInterval where 151 | showsPrec _ x | null x = showString "empty" 152 | showsPrec p x = 153 | showParen (p > rangeOpPrec) $ 154 | showsPrec (rangeOpPrec+1) (lowerBound x) . 155 | showString " <=..<= " . 156 | showsPrec (rangeOpPrec+1) (upperBound x) 157 | 158 | instance Read IntegerInterval where 159 | readsPrec p r = 160 | (readParen (p > appPrec) $ \s0 -> do 161 | ("interval",s1) <- lex s0 162 | (lb,s2) <- readsPrec (appPrec+1) s1 163 | (ub,s3) <- readsPrec (appPrec+1) s2 164 | return (interval lb ub, s3)) r 165 | ++ 166 | (readParen (p > rangeOpPrec) $ \s0 -> do 167 | (do (lb,s1) <- readsPrec (rangeOpPrec+1) s0 168 | ("<=..<=",s2) <- lex s1 169 | (ub,s3) <- readsPrec (rangeOpPrec+1) s2 170 | return (lb <=..<= ub, s3))) r 171 | ++ 172 | (do ("empty", s) <- lex r 173 | return (empty, s)) 174 | 175 | -- | smart constructor for 'IntegerInterval' 176 | interval 177 | :: (Extended Integer, Boundary) -- ^ lower bound and whether it is included 178 | -> (Extended Integer, Boundary) -- ^ upper bound and whether it is included 179 | -> IntegerInterval 180 | interval (x1,in1) (x2,in2) = 181 | (if in1 == Closed then x1 else x1 + 1) <=..<= (if in2 == Closed then x2 else x2 - 1) 182 | 183 | -- | left-open right-closed interval (@l@,@u@] 184 | (<..<=) 185 | :: Extended Integer -- ^ lower bound @l@ 186 | -> Extended Integer -- ^ upper bound @u@ 187 | -> IntegerInterval 188 | (<..<=) lb ub = (lb+1) <=..<= ub 189 | 190 | -- | left-closed right-open interval [@l@, @u@) 191 | (<=..<) 192 | :: Extended Integer -- ^ lower bound @l@ 193 | -> Extended Integer -- ^ upper bound @u@ 194 | -> IntegerInterval 195 | (<=..<) lb ub = lb <=..<= ub-1 196 | 197 | -- | open interval (@l@, @u@) 198 | (<..<) 199 | :: Extended Integer -- ^ lower bound @l@ 200 | -> Extended Integer -- ^ upper bound @u@ 201 | -> IntegerInterval 202 | (<..<) lb ub = lb+1 <=..<= ub-1 203 | 204 | -- | whole real number line (-∞, ∞) 205 | whole :: IntegerInterval 206 | whole = NegInf <=..<= PosInf 207 | 208 | -- | singleton set [x,x] 209 | singleton :: Integer -> IntegerInterval 210 | singleton x = Finite x <=..<= Finite x 211 | 212 | -- | intersection of two intervals 213 | intersection :: IntegerInterval -> IntegerInterval -> IntegerInterval 214 | intersection x1 x2 = 215 | max (lowerBound x1) (lowerBound x2) <=..<= min (upperBound x1) (upperBound x2) 216 | 217 | -- | intersection of a list of intervals. 218 | intersections :: [IntegerInterval] -> IntegerInterval 219 | intersections = foldl' intersection whole 220 | 221 | -- | convex hull of two intervals 222 | hull :: IntegerInterval -> IntegerInterval -> IntegerInterval 223 | hull x1 x2 224 | | null x1 = x2 225 | | null x2 = x1 226 | hull x1 x2 = 227 | min (lowerBound x1) (lowerBound x2) <=..<= max (upperBound x1) (upperBound x2) 228 | 229 | -- | convex hull of a list of intervals. 230 | hulls :: [IntegerInterval] -> IntegerInterval 231 | hulls = foldl' hull empty 232 | 233 | -- | @mapMonotonic f i@ is the image of @i@ under @f@, where @f@ must be a strict monotone function. 234 | mapMonotonic :: (Integer -> Integer) -> IntegerInterval -> IntegerInterval 235 | mapMonotonic f x = fmap f (lowerBound x) <=..<= fmap f (upperBound x) 236 | 237 | -- | Is the interval empty? 238 | null :: IntegerInterval -> Bool 239 | null x = upperBound x < lowerBound x 240 | 241 | -- | Is the interval single point? 242 | -- 243 | -- @since 2.0.0 244 | isSingleton :: IntegerInterval -> Bool 245 | isSingleton x = lowerBound x == upperBound x 246 | 247 | -- | Is the element in the interval? 248 | member :: Integer -> IntegerInterval -> Bool 249 | member x i = lowerBound i <= Finite x && Finite x <= upperBound i 250 | 251 | -- | Is the element not in the interval? 252 | notMember :: Integer -> IntegerInterval -> Bool 253 | notMember a i = not $ member a i 254 | 255 | -- | Is this a subset? 256 | -- @(i1 \``isSubsetOf`\` i2)@ tells whether @i1@ is a subset of @i2@. 257 | isSubsetOf :: IntegerInterval -> IntegerInterval -> Bool 258 | isSubsetOf i1 i2 = lowerBound i2 <= lowerBound i1 && upperBound i1 <= upperBound i2 259 | 260 | -- | Is this a proper subset? (/i.e./ a subset but not equal). 261 | isProperSubsetOf :: IntegerInterval -> IntegerInterval -> Bool 262 | isProperSubsetOf i1 i2 = i1 /= i2 && i1 `isSubsetOf` i2 263 | 264 | -- | Does the union of two range form a set which is the intersection between the integers and a connected real interval? 265 | isConnected :: IntegerInterval -> IntegerInterval -> Bool 266 | isConnected x y = null x || null y || x ==? y || lb1nearUb2 || ub1nearLb2 267 | where 268 | lb1 = lowerBound x 269 | lb2 = lowerBound y 270 | ub1 = upperBound x 271 | ub2 = upperBound y 272 | 273 | lb1nearUb2 = case (lb1, ub2) of 274 | (Finite lb1Int, Finite ub2Int) -> lb1Int == ub2Int + 1 275 | _ -> False 276 | 277 | ub1nearLb2 = case (ub1, lb2) of 278 | (Finite ub1Int, Finite lb2Int) -> ub1Int + 1 == lb2Int 279 | _ -> False 280 | 281 | -- | Width of a interval. Width of an unbounded interval is @undefined@. 282 | width :: IntegerInterval -> Integer 283 | width x 284 | | null x = 0 285 | | otherwise = 286 | case (lowerBound x, upperBound x) of 287 | (Finite lb, Finite ub) -> ub - lb 288 | _ -> error "Data.IntegerInterval.width: unbounded interval" 289 | 290 | -- | How many integers lie within the (bounded) interval. 291 | -- Equal to @Just (width + 1)@ for non-empty, bounded intervals. 292 | -- The @memberCount@ of an unbounded interval is @Nothing@. 293 | memberCount :: IntegerInterval -> Maybe Integer 294 | memberCount x 295 | | null x = Just 0 296 | | otherwise = 297 | case (lowerBound x, upperBound x) of 298 | (Finite lb, Finite ub) -> Just (ub - lb + 1) 299 | _ -> Nothing 300 | 301 | -- | pick up an element from the interval if the interval is not empty. 302 | pickup :: IntegerInterval -> Maybe Integer 303 | pickup x = 304 | case (lowerBound x, upperBound x) of 305 | (NegInf, PosInf) -> Just 0 306 | (Finite l, _) -> Just l 307 | (_, Finite u) -> Just u 308 | _ -> Nothing 309 | 310 | -- | 'simplestIntegerWithin' returns the simplest rational number within the interval. 311 | -- 312 | -- An integer @y@ is said to be /simpler/ than another @y'@ if 313 | -- 314 | -- * @'abs' y <= 'abs' y'@ 315 | -- 316 | -- (see also 'Data.Ratio.approxRational' and 'Interval.simplestRationalWithin') 317 | simplestIntegerWithin :: IntegerInterval -> Maybe Integer 318 | simplestIntegerWithin i 319 | | null i = Nothing 320 | | 0 IntegerInterval -> Bool 326 | --a IntegerInterval -> Bool 331 | a <=! b = upperBound a <= lowerBound b 332 | 333 | -- | For all @x@ in @X@, @y@ in @Y@. @x '==' y@? 334 | (==!) :: IntegerInterval -> IntegerInterval -> Bool 335 | a ==! b = a <=! b && a >=! b 336 | 337 | -- | For all @x@ in @X@, @y@ in @Y@. @x '/=' y@? 338 | (/=!) :: IntegerInterval -> IntegerInterval -> Bool 339 | a /=! b = null $ a `intersection` b 340 | 341 | -- | For all @x@ in @X@, @y@ in @Y@. @x '>=' y@? 342 | (>=!) :: IntegerInterval -> IntegerInterval -> Bool 343 | (>=!) = flip (<=!) 344 | 345 | -- | For all @x@ in @X@, @y@ in @Y@. @x '>' y@? 346 | (>!) :: IntegerInterval -> IntegerInterval -> Bool 347 | (>!) = flip ( IntegerInterval -> Bool 351 | a IntegerInterval -> Maybe (Integer, Integer) 355 | a IntegerInterval -> Bool 361 | a <=? b = 362 | case lb_a `compare` ub_b of 363 | LT -> True 364 | GT -> False 365 | EQ -> 366 | case lb_a of 367 | NegInf -> False -- b is empty 368 | PosInf -> False -- a is empty 369 | Finite _ -> True 370 | where 371 | lb_a = lowerBound a 372 | ub_b = upperBound b 373 | 374 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@? 375 | (<=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer) 376 | a <=?? b = 377 | case pickup (intersection a b) of 378 | Just x -> return (x,x) 379 | Nothing -> do 380 | guard $ upperBound a <= lowerBound b 381 | x <- pickup a 382 | y <- pickup b 383 | return (x,y) 384 | 385 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@? 386 | (==?) :: IntegerInterval -> IntegerInterval -> Bool 387 | a ==? b = not $ null $ intersection a b 388 | 389 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@? 390 | (==??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer) 391 | a ==?? b = do 392 | x <- pickup (intersection a b) 393 | return (x,x) 394 | 395 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@? 396 | (/=?) :: IntegerInterval -> IntegerInterval -> Bool 397 | a /=? b = not (null a) && not (null b) && not (a == b && isSingleton a) 398 | 399 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@? 400 | (/=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer) 401 | a /=?? b = do 402 | guard $ not $ null a 403 | guard $ not $ null b 404 | guard $ not $ a == b && isSingleton a 405 | if not (isSingleton b) 406 | then f a b 407 | else liftM (\(y,x) -> (x,y)) $ f b a 408 | where 409 | f i j = do 410 | x <- pickup i 411 | y <- msum [pickup (j `intersection` c) | c <- [-inf <..< Finite x, Finite x <..< inf]] 412 | return (x,y) 413 | 414 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@? 415 | (>=?) :: IntegerInterval -> IntegerInterval -> Bool 416 | (>=?) = flip (<=?) 417 | 418 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@? 419 | (>?) :: IntegerInterval -> IntegerInterval -> Bool 420 | (>?) = flip (=' y@? 423 | (>=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer) 424 | (>=??) = flip (<=??) 425 | 426 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@? 427 | (>??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer) 428 | (>??) = flip ( IntegerInterval -> IntegerInterval 437 | scaleInterval _ x | null x = empty 438 | scaleInterval c x = 439 | case compare c 0 of 440 | EQ -> singleton 0 441 | LT -> Finite c * upperBound x <=..<= Finite c * lowerBound x 442 | GT -> Finite c * lowerBound x <=..<= Finite c * upperBound x 443 | 444 | instance Num IntegerInterval where 445 | a + b 446 | | null a || null b = empty 447 | | otherwise = lowerBound a + lowerBound b <=..<= upperBound a + upperBound b 448 | 449 | negate = scaleInterval (-1) 450 | 451 | fromInteger i = singleton (fromInteger i) 452 | 453 | abs x = (x `intersection` nonneg) `hull` (negate x `intersection` nonneg) 454 | where 455 | nonneg = 0 <=..< inf 456 | 457 | signum x = zero `hull` pos `hull` neg 458 | where 459 | zero = if member 0 x then singleton 0 else empty 460 | pos = if null $ (0 <..< inf) `intersection` x 461 | then empty 462 | else singleton 1 463 | neg = if null $ (-inf <..< 0) `intersection` x 464 | then empty 465 | else singleton (-1) 466 | 467 | a * b 468 | | null a || null b = empty 469 | | otherwise = minimum xs <=..<= maximum xs 470 | where 471 | xs = [ mul x1 x2 | x1 <- [lowerBound a, upperBound a], x2 <- [lowerBound b, upperBound b] ] 472 | 473 | mul :: Extended Integer -> Extended Integer -> Extended Integer 474 | mul 0 _ = 0 475 | mul _ 0 = 0 476 | mul x1 x2 = x1*x2 477 | 478 | -- | Convert the interval to 'Interval.Interval' data type. 479 | toInterval :: Real r => IntegerInterval -> Interval.Interval r 480 | toInterval x = Interval.interval 481 | (fmap fromInteger (lowerBound x), Closed) 482 | (fmap fromInteger (upperBound x), Closed) 483 | 484 | -- | Conversion from 'Interval.Interval' data type. 485 | fromInterval :: Interval.Interval Integer -> IntegerInterval 486 | fromInterval i = x1' <=..<= x2' 487 | where 488 | (x1,in1) = Interval.lowerBound' i 489 | (x2,in2) = Interval.upperBound' i 490 | x1' = case in1 of 491 | Interval.Open -> x1 + 1 492 | Interval.Closed -> x1 493 | x2' = case in2 of 494 | Interval.Open -> x2 - 1 495 | Interval.Closed -> x2 496 | 497 | -- | Given a 'Interval.Interval' @I@ over R, compute the smallest 'IntegerInterval' @J@ such that @I ⊆ J@. 498 | fromIntervalOver :: RealFrac r => Interval.Interval r -> IntegerInterval 499 | fromIntervalOver i = fmap floor lb <=..<= fmap ceiling ub 500 | where 501 | (lb, _) = Interval.lowerBound' i 502 | (ub, _) = Interval.upperBound' i 503 | 504 | -- | Given a 'Interval.Interval' @I@ over R, compute the largest 'IntegerInterval' @J@ such that @J ⊆ I@. 505 | fromIntervalUnder :: RealFrac r => Interval.Interval r -> IntegerInterval 506 | fromIntervalUnder i = lb <=..<= ub 507 | where 508 | lb = case Interval.lowerBound' i of 509 | (Finite x, Open) 510 | | fromInteger (ceiling x) == x 511 | -> Finite (ceiling x + 1) 512 | (x, _) -> fmap ceiling x 513 | ub = case Interval.upperBound' i of 514 | (Finite x, Open) 515 | | fromInteger (floor x) == x 516 | -> Finite (floor x - 1) 517 | (x, _) -> fmap floor x 518 | 519 | -- | Computes how two intervals are related according to the @`Data.IntervalRelation.Relation`@ classification 520 | relate :: IntegerInterval -> IntegerInterval -> Relation 521 | relate i1 i2 = 522 | case (i1 `isSubsetOf` i2, i2 `isSubsetOf` i1) of 523 | -- 'i1' ad 'i2' are equal 524 | (True , True ) -> Equal 525 | -- 'i1' is strictly contained in `i2` 526 | (True , False) | lowerBound i1 == lowerBound i2 -> Starts 527 | | upperBound i1 == upperBound i2 -> Finishes 528 | | otherwise -> During 529 | -- 'i2' is strictly contained in `i1` 530 | (False, True ) | lowerBound i1 == lowerBound i2 -> StartedBy 531 | | upperBound i1 == upperBound i2 -> FinishedBy 532 | | otherwise -> Contains 533 | -- neither `i1` nor `i2` is contained in the other 534 | (False, False) -> case ( null (i1 `intersection` i2) 535 | , lowerBound i1 <= lowerBound i2 536 | , i1 `isConnected` i2 537 | ) of 538 | (True , True , True ) -> JustBefore 539 | (True , True , False) -> Before 540 | (True , False, True ) -> JustAfter 541 | (True , False, False) -> After 542 | (False, True , _ ) -> Overlaps 543 | (False, False, _ ) -> OverlappedBy 544 | -------------------------------------------------------------------------------- /src/Data/IntervalMap/Base.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE CPP, LambdaCase, ScopedTypeVariables, TypeFamilies, MultiWayIf, GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | {-# LANGUAGE RoleAnnotations #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.IntervalMap.Base 8 | -- Copyright : (c) Masahiro Sakai 2016 9 | -- License : BSD-style 10 | -- 11 | -- Maintainer : masahiro.sakai@gmail.com 12 | -- Stability : provisional 13 | -- 14 | -- Interval datatype and interval arithmetic. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | module Data.IntervalMap.Base 18 | ( 19 | -- * IntervalMap type 20 | IntervalMap (..) 21 | , module Data.ExtendedReal 22 | 23 | -- * Operators 24 | , (!) 25 | , (\\) 26 | 27 | -- * Query 28 | , null 29 | , member 30 | , notMember 31 | , lookup 32 | , findWithDefault 33 | , span 34 | 35 | -- * Construction 36 | , whole 37 | , empty 38 | , singleton 39 | 40 | -- ** Insertion 41 | , insert 42 | , insertWith 43 | 44 | -- ** Delete\/Update 45 | , delete 46 | , adjust 47 | , update 48 | , alter 49 | 50 | -- * Combine 51 | , union 52 | , unionWith 53 | , unions 54 | , unionsWith 55 | , intersection 56 | , intersectionWith 57 | , difference 58 | 59 | -- * Traversal 60 | , map 61 | , mapKeysMonotonic 62 | 63 | -- * Conversion 64 | , elems 65 | , keys 66 | , assocs 67 | , keysSet 68 | 69 | -- ** List 70 | , fromList 71 | , fromListWith 72 | , toList 73 | 74 | -- ** Ordered List 75 | , toAscList 76 | , toDescList 77 | 78 | -- * Filter 79 | , filter 80 | , split 81 | 82 | -- * Submap 83 | , isSubmapOf 84 | , isSubmapOfBy 85 | , isProperSubmapOf 86 | , isProperSubmapOfBy 87 | ) 88 | where 89 | 90 | import Prelude hiding (null, lookup, map, filter, span, and) 91 | import Control.DeepSeq 92 | import Data.Data 93 | import Data.ExtendedReal 94 | import Data.Hashable 95 | import Data.Foldable hiding (null, toList) 96 | import Data.Map (Map) 97 | import qualified Data.Map as Map 98 | import Data.Maybe 99 | import qualified Data.Semigroup as Semigroup 100 | import Data.Interval (Interval) 101 | import qualified Data.Interval as Interval 102 | import Data.IntervalSet (IntervalSet) 103 | import qualified Data.IntervalSet as IntervalSet 104 | import qualified GHC.Exts as GHCExts 105 | 106 | -- ------------------------------------------------------------------------ 107 | -- The IntervalMap type 108 | 109 | -- | A Map from non-empty, disjoint intervals over k to values a. 110 | -- 111 | -- Unlike 'IntervalSet', 'IntervalMap' never merge adjacent mappings, 112 | -- even if adjacent intervals are connected and mapped to the same value. 113 | newtype IntervalMap r a = IntervalMap (Map (LB r) (Interval r, a)) 114 | deriving 115 | ( Eq 116 | , Ord 117 | -- ^ Note that this Ord is derived and not semantically meaningful. 118 | -- The primary intended use case is to allow using 'IntervalSet' 119 | -- in maps and sets that require ordering. 120 | ) 121 | 122 | type role IntervalMap nominal representational 123 | 124 | instance (Ord k, Show k, Show a) => Show (IntervalMap k a) where 125 | showsPrec p (IntervalMap m) = showParen (p > appPrec) $ 126 | showString "fromList " . 127 | showsPrec (appPrec+1) (Map.elems m) 128 | 129 | instance (Ord k, Read k, Read a) => Read (IntervalMap k a) where 130 | readsPrec p = 131 | (readParen (p > appPrec) $ \s0 -> do 132 | ("fromList",s1) <- lex s0 133 | (xs,s2) <- readsPrec (appPrec+1) s1 134 | return (fromList xs, s2)) 135 | 136 | appPrec :: Int 137 | appPrec = 10 138 | 139 | -- This instance preserves data abstraction at the cost of inefficiency. 140 | -- We provide limited reflection services for the sake of data abstraction. 141 | 142 | instance (Data k, Data a, Ord k) => Data (IntervalMap k a) where 143 | gfoldl k z x = z fromList `k` toList x 144 | toConstr _ = fromListConstr 145 | gunfold k z c = case constrIndex c of 146 | 1 -> k (z fromList) 147 | _ -> error "gunfold" 148 | dataTypeOf _ = mapDataType 149 | dataCast1 f = gcast1 f 150 | 151 | fromListConstr :: Constr 152 | fromListConstr = mkConstr mapDataType "fromList" [] Prefix 153 | 154 | mapDataType :: DataType 155 | mapDataType = mkDataType "Data.IntervalMap.Base.IntervalMap" [fromListConstr] 156 | 157 | instance (NFData k, NFData a) => NFData (IntervalMap k a) where 158 | rnf (IntervalMap m) = rnf m 159 | 160 | instance (Hashable k, Hashable a) => Hashable (IntervalMap k a) where 161 | hashWithSalt s m = hashWithSalt s (toList m) 162 | 163 | instance Ord k => Monoid (IntervalMap k a) where 164 | mempty = empty 165 | mappend = (Semigroup.<>) 166 | mconcat = unions 167 | 168 | instance Ord k => Semigroup.Semigroup (IntervalMap k a) where 169 | (<>) = union 170 | stimes = Semigroup.stimesIdempotentMonoid 171 | 172 | instance Ord k => GHCExts.IsList (IntervalMap k a) where 173 | type Item (IntervalMap k a) = (Interval k, a) 174 | fromList = fromList 175 | toList = toList 176 | 177 | -- ------------------------------------------------------------------------ 178 | 179 | newtype LB r = LB (Extended r, Interval.Boundary) 180 | deriving (Eq, NFData) 181 | 182 | instance Ord r => Ord (LB r) where 183 | compare (LB (lb1, lb1in)) (LB (lb2, lb2in)) = 184 | -- inclusive lower endpoint shuold be considered smaller 185 | (lb1 `compare` lb2) `mappend` (lb2in `compare` lb1in) 186 | 187 | -- ------------------------------------------------------------------------ 188 | -- Operators 189 | 190 | infixl 9 !,\\ -- 191 | 192 | -- | Find the value at a key. Calls 'error' when the element can not be found. 193 | (!) :: Ord k => IntervalMap k a -> k -> a 194 | IntervalMap m ! k = 195 | case Map.lookupLE (LB (Finite k, Interval.Closed)) m of 196 | Just (_, (i, a)) | k `Interval.member` i -> a 197 | _ -> error "IntervalMap.!: given key is not an element in the map" 198 | 199 | -- | Same as 'difference'. 200 | (\\) :: Ord k => IntervalMap k a -> IntervalMap k b -> IntervalMap k a 201 | m1 \\ m2 = difference m1 m2 202 | 203 | -- ------------------------------------------------------------------------ 204 | -- Query 205 | 206 | -- | Is the map empty? 207 | null :: Ord k => IntervalMap k a -> Bool 208 | null (IntervalMap m) = Map.null m 209 | 210 | -- | Is the key a member of the map? See also 'notMember'. 211 | member :: Ord k => k -> IntervalMap k a -> Bool 212 | member k (IntervalMap m) = 213 | case Map.lookupLE (LB (Finite k, Interval.Closed)) m of 214 | Just (_, (i, _)) -> k `Interval.member` i 215 | Nothing -> False 216 | 217 | -- | Is the key not a member of the map? See also 'member'. 218 | notMember :: Ord k => k -> IntervalMap k a -> Bool 219 | notMember k m = not $ member k m 220 | 221 | -- | Lookup the value at a key in the map. 222 | -- 223 | -- The function will return the corresponding value as @('Just' value)@, 224 | -- or 'Nothing' if the key isn't in the map. 225 | lookup :: Ord k => k -> IntervalMap k a -> Maybe a 226 | lookup k (IntervalMap m) = 227 | case Map.lookupLE (LB (Finite k, Interval.Closed)) m of 228 | Just (_, (i, a)) | k `Interval.member` i -> Just a 229 | _ -> Nothing 230 | 231 | -- | The expression @('findWithDefault' def k map)@ returns 232 | -- the value at key @k@ or returns default value @def@ 233 | -- when the key is not in the map. 234 | findWithDefault :: Ord k => a -> k -> IntervalMap k a -> a 235 | findWithDefault def k (IntervalMap m) = 236 | case Map.lookupLE (LB (Finite k, Interval.Closed)) m of 237 | Just (_, (i, a)) | k `Interval.member` i -> a 238 | _ -> def 239 | 240 | lookupInterval :: Ord k => Interval k -> IntervalMap k a -> Maybe a 241 | lookupInterval i (IntervalMap m) = 242 | case Map.lookupLE (LB (Interval.lowerBound' i)) m of 243 | Just (_, (j, a)) | i `Interval.isSubsetOf` j -> Just a 244 | _ -> Nothing 245 | 246 | -- | convex hull of key intervals. 247 | span :: Ord k => IntervalMap k a -> Interval k 248 | span = IntervalSet.span . keysSet 249 | 250 | -- ------------------------------------------------------------------------ 251 | -- Construction 252 | 253 | -- | The empty map. 254 | empty :: Ord k => IntervalMap k a 255 | empty = IntervalMap Map.empty 256 | 257 | -- | The map that maps whole range of k to a. 258 | whole :: Ord k => a -> IntervalMap k a 259 | whole a = IntervalMap $ Map.singleton (LB (Interval.lowerBound' i)) (i, a) 260 | where 261 | i = Interval.whole 262 | 263 | -- | A map with a single interval. 264 | singleton :: Ord k => Interval k -> a -> IntervalMap k a 265 | singleton i a 266 | | Interval.null i = empty 267 | | otherwise = IntervalMap $ Map.singleton (LB (Interval.lowerBound' i)) (i, a) 268 | 269 | -- ------------------------------------------------------------------------ 270 | -- Insertion 271 | 272 | -- | insert a new key and value in the map. 273 | -- If the key is already present in the map, the associated value is 274 | -- replaced with the supplied value. 275 | insert :: Ord k => Interval k -> a -> IntervalMap k a -> IntervalMap k a 276 | insert i _ m | Interval.null i = m 277 | insert i a m = 278 | case split i m of 279 | (IntervalMap m1, _, IntervalMap m2) -> 280 | IntervalMap $ Map.union m1 (Map.insert (LB (Interval.lowerBound' i)) (i,a) m2) 281 | 282 | 283 | -- | Insert with a function, combining new value and old value. 284 | -- @'insertWith' f key value mp@ will insert the pair (interval, value) into @mp@. 285 | -- If the interval overlaps with existing entries, the value for the entry is replace 286 | -- with @(f new_value old_value)@. 287 | insertWith :: Ord k => (a -> a -> a) -> Interval k -> a -> IntervalMap k a -> IntervalMap k a 288 | insertWith _ i _ m | Interval.null i = m 289 | insertWith f i a m = alter g i m 290 | where 291 | g Nothing = Just a 292 | g (Just a') = Just $ f a a' 293 | 294 | -- ------------------------------------------------------------------------ 295 | -- Delete/Update 296 | 297 | -- | Delete an interval and its value from the map. 298 | -- When the interval does not overlap with the map, the original map is returned. 299 | delete :: Ord k => Interval k -> IntervalMap k a -> IntervalMap k a 300 | delete i m | Interval.null i = m 301 | delete i m = 302 | case split i m of 303 | (IntervalMap m1, _, IntervalMap m2) -> 304 | IntervalMap $ Map.union m1 m2 305 | 306 | -- | Update a value at a specific interval with the result of the provided function. 307 | -- When the interval does not overlatp with the map, the original map is returned. 308 | adjust :: Ord k => (a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a 309 | adjust f = update (Just . f) 310 | 311 | -- | The expression (@'update' f i map@) updates the value @x@ 312 | -- at @i@ (if it is in the map). If (@f x@) is 'Nothing', the element is 313 | -- deleted. If it is (@'Just' y@), the key @i@ is bound to the new value @y@. 314 | update :: Ord k => (a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a 315 | update _ i m | Interval.null i = m 316 | update f i m = 317 | case split i m of 318 | (IntervalMap m1, IntervalMap m2, IntervalMap m3) -> 319 | IntervalMap $ Map.unions [m1, Map.mapMaybe (\(j,a) -> (\b -> (j,b)) <$> f a) m2, m3] 320 | 321 | -- | The expression (@'alter' f i map@) alters the value @x@ at @i@, or absence thereof. 322 | -- 'alter' can be used to insert, delete, or update a value in a 'IntervalMap'. 323 | alter :: Ord k => (Maybe a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a 324 | alter _ i m | Interval.null i = m 325 | alter f i m = 326 | case split i m of 327 | (IntervalMap m1, IntervalMap m2, IntervalMap m3) -> 328 | let m2' = Map.mapMaybe (\(j,a) -> (\b -> (j,b)) <$> f (Just a)) m2 329 | js = IntervalSet.singleton i `IntervalSet.difference` keysSet (IntervalMap m2) 330 | IntervalMap m2'' = 331 | case f Nothing of 332 | Nothing -> empty 333 | Just a -> fromList [(j,a) | j <- IntervalSet.toList js] 334 | in IntervalMap $ Map.unions [m1, m2', m2'', m3] 335 | 336 | -- ------------------------------------------------------------------------ 337 | -- Combine 338 | 339 | -- | The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. 340 | -- It prefers @t1@ when overlapping keys are encountered, 341 | union :: Ord k => IntervalMap k a -> IntervalMap k a -> IntervalMap k a 342 | union m1 m2 = 343 | foldl' (\m (i,a) -> insert i a m) m2 (toList m1) 344 | 345 | -- | Union with a combining function. 346 | unionWith :: Ord k => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a 347 | unionWith f m1 m2 = 348 | foldl' (\m (i,a) -> insertWith f i a m) m2 (toList m1) 349 | 350 | -- | The union of a list of maps: 351 | -- (@'unions' == 'Prelude.foldl' 'union' 'empty'@). 352 | unions :: Ord k => [IntervalMap k a] -> IntervalMap k a 353 | unions = foldl' union empty 354 | 355 | -- | The union of a list of maps, with a combining operation: 356 | -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@). 357 | unionsWith :: Ord k => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a 358 | unionsWith f = foldl' (unionWith f) empty 359 | 360 | -- | Return elements of the first map not existing in the second map. 361 | difference :: Ord k => IntervalMap k a -> IntervalMap k b -> IntervalMap k a 362 | difference m1 m2 = foldl' (\m i -> delete i m) m1 (IntervalSet.toList (keysSet m2)) 363 | 364 | -- | Intersection of two maps. 365 | -- Return data in the first map for the keys existing in both maps. 366 | intersection :: Ord k => IntervalMap k a -> IntervalMap k a -> IntervalMap k a 367 | intersection = intersectionWith const 368 | 369 | -- | Intersection with a combining function. 370 | intersectionWith :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c 371 | intersectionWith f im1@(IntervalMap m1) im2@(IntervalMap m2) 372 | | Map.size m1 >= Map.size m2 = g f im1 im2 373 | | otherwise = g (flip f) im2 im1 374 | where 375 | g :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c 376 | g h jm1 (IntervalMap m3) = IntervalMap $ Map.unions $ go jm1 (Map.elems m3) 377 | where 378 | go _ [] = [] 379 | go im ((i,b) : xs) = 380 | case split i im of 381 | (_, IntervalMap m, jm2) -> 382 | Map.map (\(j, a) -> (j, h a b)) m : go jm2 xs 383 | 384 | -- ------------------------------------------------------------------------ 385 | -- Traversal 386 | 387 | instance Ord k => Functor (IntervalMap k) where 388 | fmap = map 389 | 390 | instance Ord k => Foldable (IntervalMap k) where 391 | foldMap f (IntervalMap m) = foldMap (\(_,a) -> f a) m 392 | 393 | instance Ord k => Traversable (IntervalMap k) where 394 | traverse f (IntervalMap m) = IntervalMap <$> traverse (\(i,a) -> (\b -> (i,b)) <$> f a) m 395 | 396 | -- | Map a function over all values in the map. 397 | map :: (a -> b) -> IntervalMap k a -> IntervalMap k b 398 | map f (IntervalMap m) = IntervalMap $ Map.map (\(i, a) -> (i, f a)) m 399 | 400 | -- | @'mapKeysMonotonic' f s@ is the map obtained by applying @f@ to each key of @s@. 401 | -- @f@ must be strictly monotonic. 402 | -- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. 403 | mapKeysMonotonic :: forall k1 k2 a. (Ord k1, Ord k2) => (k1 -> k2) -> IntervalMap k1 a -> IntervalMap k2 a 404 | mapKeysMonotonic f = fromList . fmap g . toList 405 | where 406 | g :: (Interval k1, a) -> (Interval k2, a) 407 | g (i, a) = (Interval.mapMonotonic f i, a) 408 | 409 | -- ------------------------------------------------------------------------ 410 | 411 | -- | Return all elements of the map in the ascending order of their keys. 412 | elems :: IntervalMap k a -> [a] 413 | elems (IntervalMap m) = [a | (_,a) <- Map.elems m] 414 | 415 | -- | Return all keys of the map in ascending order. Subject to list 416 | keys :: IntervalMap k a -> [Interval k] 417 | keys (IntervalMap m) = [i | (i,_) <- Map.elems m] 418 | 419 | -- | An alias for 'toAscList'. Return all key\/value pairs in the map 420 | -- in ascending key order. 421 | assocs :: IntervalMap k a -> [(Interval k, a)] 422 | assocs = toAscList 423 | 424 | -- | The set of all keys of the map. 425 | keysSet :: Ord k => IntervalMap k a -> IntervalSet k 426 | keysSet (IntervalMap m) = IntervalSet.fromAscList [i | (i,_) <- Map.elems m] 427 | 428 | -- | Convert the map to a list of key\/value pairs. 429 | toList :: IntervalMap k a -> [(Interval k, a)] 430 | toList = toAscList 431 | 432 | -- | Convert the map to a list of key/value pairs where the keys are in ascending order. 433 | toAscList :: IntervalMap k a -> [(Interval k, a)] 434 | toAscList (IntervalMap m) = Map.elems m 435 | 436 | -- | Convert the map to a list of key/value pairs where the keys are in descending order. 437 | toDescList :: IntervalMap k a -> [(Interval k, a)] 438 | toDescList (IntervalMap m) = fmap snd $ Map.toDescList m 439 | 440 | -- | Build a map from a list of key\/value pairs. 441 | -- If the list contains more than one value for the same key, the last value 442 | -- for the key is retained. 443 | fromList :: Ord k => [(Interval k, a)] -> IntervalMap k a 444 | fromList = foldl' (\m (i,a) -> insert i a m) empty 445 | 446 | -- | Build a map from a list of key\/value pairs with a combining function. 447 | fromListWith :: Ord k => (a -> a -> a) -> [(Interval k, a)] -> IntervalMap k a 448 | fromListWith f = foldl' (\m (i,a) -> insertWith f i a m) empty 449 | 450 | -- ------------------------------------------------------------------------ 451 | -- Filter 452 | 453 | -- | Filter all values that satisfy some predicate. 454 | filter :: Ord k => (a -> Bool) -> IntervalMap k a -> IntervalMap k a 455 | filter p (IntervalMap m) = IntervalMap $ Map.filter (\(_,a) -> p a) m 456 | 457 | -- | The expression (@'split' i map@) is a triple @(map1,map2,map3)@ where 458 | -- the keys in @map1@ are smaller than @i@, the keys in @map2@ are included in @i@, and the keys in @map3@ are larger than @i@. 459 | split :: Ord k => Interval k -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a, IntervalMap k a) 460 | split i (IntervalMap m) = 461 | case splitLookupLE (LB (Interval.lowerBound' i)) m of 462 | (smaller, m1, xs) -> 463 | case splitLookupLE (LB (Interval.upperBound i, Interval.Closed)) xs of 464 | (middle, m2, larger) -> 465 | ( IntervalMap $ 466 | case m1 of 467 | Nothing -> Map.empty 468 | Just (j,b) -> 469 | let k = Interval.intersection (upTo i) j 470 | in if Interval.null k 471 | then smaller 472 | else Map.insert (LB (Interval.lowerBound' k)) (k,b) smaller 473 | , IntervalMap $ Map.unions $ middle : 474 | [ Map.singleton (LB (Interval.lowerBound' k)) (k, b) 475 | | (j, b) <- maybeToList m1 ++ maybeToList m2 476 | , let k = Interval.intersection i j 477 | , not (Interval.null k) 478 | ] 479 | , IntervalMap $ Map.unions $ larger : 480 | [ Map.singleton (LB (Interval.lowerBound' k)) (k, b) 481 | | (j, b) <- maybeToList m1 ++ maybeToList m2 482 | , let k = Interval.intersection (downTo i) j 483 | , not (Interval.null k) 484 | ] 485 | ) 486 | 487 | -- ------------------------------------------------------------------------ 488 | -- Submap 489 | 490 | -- | This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). 491 | isSubmapOf :: (Ord k, Eq a) => IntervalMap k a -> IntervalMap k a -> Bool 492 | isSubmapOf = isSubmapOfBy (==) 493 | 494 | -- | The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if 495 | -- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when 496 | -- applied to their respective values. 497 | isSubmapOfBy :: Ord k => (a -> b -> Bool) -> IntervalMap k a -> IntervalMap k b -> Bool 498 | isSubmapOfBy f m1 m2 = and $ 499 | [ case lookupInterval i m2 of 500 | Nothing -> False 501 | Just b -> f a b 502 | | (i,a) <- toList m1 ] 503 | 504 | -- | Is this a proper submap? (ie. a submap but not equal). 505 | -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). 506 | isProperSubmapOf :: (Ord k, Eq a) => IntervalMap k a -> IntervalMap k a -> Bool 507 | isProperSubmapOf = isProperSubmapOfBy (==) 508 | 509 | -- | Is this a proper submap? (ie. a submap but not equal). 510 | -- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when 511 | -- @m1@ and @m2@ are not equal, 512 | -- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when 513 | -- applied to their respective values. 514 | isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> IntervalMap k a -> IntervalMap k b -> Bool 515 | isProperSubmapOfBy f m1 m2 = 516 | isSubmapOfBy f m1 m2 && 517 | keysSet m1 `IntervalSet.isProperSubsetOf` keysSet m2 518 | 519 | -- ------------------------------------------------------------------------ 520 | 521 | splitLookupLE :: Ord k => k -> Map k v -> (Map k v, Maybe v, Map k v) 522 | splitLookupLE k m = 523 | case Map.splitLookup k m of 524 | (smaller, Just v, larger) -> (smaller, Just v, larger) 525 | (smaller, Nothing, larger) -> 526 | case Map.maxView smaller of 527 | Just (v, smaller') -> (smaller', Just v, larger) 528 | Nothing -> (smaller, Nothing, larger) 529 | 530 | upTo :: Ord r => Interval r -> Interval r 531 | upTo i = 532 | case Interval.lowerBound' i of 533 | (NegInf, _) -> Interval.empty 534 | (PosInf, _) -> Interval.whole 535 | (Finite lb, incl) -> 536 | Interval.interval (NegInf, Interval.Open) (Finite lb, notB incl) 537 | 538 | downTo :: Ord r => Interval r -> Interval r 539 | downTo i = 540 | case Interval.upperBound' i of 541 | (PosInf, _) -> Interval.empty 542 | (NegInf, _) -> Interval.whole 543 | (Finite ub, incl) -> 544 | Interval.interval (Finite ub, notB incl) (PosInf, Interval.Open) 545 | 546 | notB :: Interval.Boundary -> Interval.Boundary 547 | notB = \case 548 | Interval.Open -> Interval.Closed 549 | Interval.Closed -> Interval.Open 550 | -------------------------------------------------------------------------------- /test/TestIntervalSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, TemplateHaskell, ScopedTypeVariables #-} 2 | module TestIntervalSet (intervalSetTestGroup) where 3 | 4 | #ifdef MIN_VERSION_lattices 5 | import qualified Algebra.Lattice as L 6 | #endif 7 | import Control.Applicative ((<$>)) 8 | import Control.Arrow (first) 9 | import Control.DeepSeq 10 | import Control.Monad 11 | import Data.Generics.Schemes 12 | import Data.Hashable 13 | import qualified Data.List as L 14 | import Data.Maybe 15 | import Data.Monoid 16 | import Data.Ratio 17 | import Data.Typeable (cast) 18 | 19 | import Test.Tasty 20 | import Test.Tasty.QuickCheck 21 | import Test.Tasty.HUnit 22 | import Test.Tasty.TH 23 | 24 | import Data.Interval ( Interval, Extended (..), (<=..<=), (<=..<), (<..<=), (<..<) ) 25 | import qualified Data.Interval as Interval 26 | import Data.IntervalSet (IntervalSet) 27 | import qualified Data.IntervalSet as IntervalSet 28 | 29 | {-------------------------------------------------------------------- 30 | empty 31 | --------------------------------------------------------------------} 32 | 33 | prop_empty_is_bottom = 34 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 35 | IntervalSet.isSubsetOf IntervalSet.empty a 36 | 37 | prop_null_empty = 38 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 39 | IntervalSet.null a == (a == IntervalSet.empty) 40 | 41 | case_null_empty = 42 | IntervalSet.null (IntervalSet.empty :: IntervalSet Rational) @?= True 43 | 44 | {-------------------------------------------------------------------- 45 | whole 46 | --------------------------------------------------------------------} 47 | 48 | prop_whole_is_top = 49 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 50 | IntervalSet.isSubsetOf a IntervalSet.whole 51 | 52 | case_nonnull_top = 53 | IntervalSet.null (IntervalSet.whole :: IntervalSet Rational) @?= False 54 | 55 | {-------------------------------------------------------------------- 56 | singleton 57 | --------------------------------------------------------------------} 58 | 59 | prop_singleton_member = 60 | forAll arbitrary $ \r -> 61 | IntervalSet.member (r::Rational) (fromRational r) 62 | 63 | prop_singleton_nonnull = 64 | forAll arbitrary $ \r1 -> 65 | not $ IntervalSet.null $ fromRational (r1::Rational) 66 | 67 | case_singleton_1 = 68 | IntervalSet.singleton Interval.empty @?= (IntervalSet.empty :: IntervalSet Rational) 69 | 70 | {-------------------------------------------------------------------- 71 | complement 72 | --------------------------------------------------------------------} 73 | 74 | prop_complement_involution = 75 | forAll arbitrary $ \(s :: IntervalSet Rational) -> 76 | IntervalSet.complement (IntervalSet.complement s) == s 77 | 78 | prop_complement_union = 79 | forAll arbitrary $ \(is :: IntervalSet Rational) -> 80 | IntervalSet.union is (IntervalSet.complement is) == IntervalSet.whole 81 | 82 | prop_complement_intersection = 83 | forAll arbitrary $ \(is :: IntervalSet Rational) -> 84 | IntervalSet.intersection is (IntervalSet.complement is) == IntervalSet.empty 85 | 86 | {-------------------------------------------------------------------- 87 | fromList 88 | --------------------------------------------------------------------} 89 | 90 | case_fromList_minus_one_to_one_without_zero = xs @?= xs 91 | where 92 | xs = show (IntervalSet.fromList [ (-1 <..< 0 :: Interval Rational), 0 <..<1 ]) 93 | 94 | case_fromList_connected = 95 | IntervalSet.fromList [ (0 <=..< 1 :: Interval Rational), 1 <=..<2 ] 96 | @?= IntervalSet.fromList [ 0 <=..<2 ] 97 | 98 | {-------------------------------------------------------------------- 99 | insert 100 | --------------------------------------------------------------------} 101 | 102 | prop_insert_Interval_whole = 103 | forAll arbitrary $ \(i :: Interval Rational) -> 104 | IntervalSet.insert i IntervalSet.whole == IntervalSet.whole 105 | 106 | prop_insert_whole_IntervalSet = 107 | forAll arbitrary $ \(is :: IntervalSet Rational) -> 108 | IntervalSet.insert Interval.whole is == IntervalSet.whole 109 | 110 | prop_insert_comm = 111 | forAll arbitrary $ \(is :: IntervalSet Rational) -> 112 | forAll arbitrary $ \(i1 :: Interval Rational) -> 113 | forAll arbitrary $ \(i2 :: Interval Rational) -> 114 | IntervalSet.insert i1 (IntervalSet.insert i2 is) 115 | == 116 | IntervalSet.insert i2 (IntervalSet.insert i1 is) 117 | 118 | case_insert_connected = 119 | IntervalSet.insert (1 <=..< 2 :: Interval Rational) (IntervalSet.fromList [ 0 <=..< 1, 2 <=..< 3 ]) 120 | @?= IntervalSet.singleton (0 <=..< 3) 121 | 122 | case_insert_zero = 123 | IntervalSet.insert zero (IntervalSet.complement $ IntervalSet.singleton zero) @?= IntervalSet.whole 124 | where 125 | zero :: Interval Rational 126 | zero = 0 <=..<= 0 127 | 128 | case_insert_zero_negative = 129 | IntervalSet.insert zero negative @?= nonPositive 130 | where 131 | zero :: Interval Rational 132 | zero = 0 <=..<= 0 133 | negative :: IntervalSet Rational 134 | negative = IntervalSet.singleton $ NegInf <..< 0 135 | nonPositive :: IntervalSet Rational 136 | nonPositive = IntervalSet.singleton $ NegInf <..<= 0 137 | 138 | {-------------------------------------------------------------------- 139 | delete 140 | --------------------------------------------------------------------} 141 | 142 | prop_delete_Interval_empty = 143 | forAll arbitrary $ \(i :: Interval Rational) -> 144 | IntervalSet.delete i IntervalSet.empty == IntervalSet.empty 145 | 146 | prop_delete_empty_IntervalSet = 147 | forAll arbitrary $ \(is :: IntervalSet Rational) -> 148 | IntervalSet.delete Interval.empty is == is 149 | 150 | prop_delete_comm = 151 | forAll arbitrary $ \(is :: IntervalSet Rational) -> 152 | forAll arbitrary $ \(i1 :: Interval Rational) -> 153 | forAll arbitrary $ \(i2 :: Interval Rational) -> 154 | IntervalSet.delete i1 (IntervalSet.delete i2 is) 155 | == 156 | IntervalSet.delete i2 (IntervalSet.delete i1 is) 157 | 158 | case_delete_connected = 159 | IntervalSet.delete (1 <=..< 2) (IntervalSet.fromList [ 0 <=..< 3 :: Interval Rational ]) 160 | @?= (IntervalSet.fromList [ 0 <=..< 1, 2 <=..< 3 ]) 161 | 162 | {-------------------------------------------------------------------- 163 | Intersection 164 | --------------------------------------------------------------------} 165 | 166 | prop_intersection_comm = 167 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 168 | forAll arbitrary $ \b -> 169 | IntervalSet.intersection a b == IntervalSet.intersection b a 170 | 171 | prop_intersection_assoc = 172 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 173 | forAll arbitrary $ \b -> 174 | forAll arbitrary $ \c -> 175 | IntervalSet.intersection a (IntervalSet.intersection b c) == 176 | IntervalSet.intersection (IntervalSet.intersection a b) c 177 | 178 | prop_intersection_unitL = 179 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 180 | IntervalSet.intersection IntervalSet.whole a == a 181 | 182 | prop_intersection_unitR = 183 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 184 | IntervalSet.intersection a IntervalSet.whole == a 185 | 186 | prop_intersection_empty = 187 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 188 | IntervalSet.intersection a IntervalSet.empty == IntervalSet.empty 189 | 190 | prop_intersection_isSubsetOf_integer = 191 | forAll arbitrary $ \(a :: IntervalSet Integer) -> 192 | forAll arbitrary $ \b -> 193 | IntervalSet.isSubsetOf (IntervalSet.intersection a b) a 194 | 195 | prop_intersection_isSubsetOf = 196 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 197 | forAll arbitrary $ \b -> 198 | IntervalSet.isSubsetOf (IntervalSet.intersection a b) a 199 | 200 | prop_intersection_isSubsetOf_equiv_integer = 201 | forAll arbitrary $ \(a :: IntervalSet Integer) -> 202 | forAll arbitrary $ \b -> 203 | (IntervalSet.intersection a b == a) 204 | == IntervalSet.isSubsetOf a b 205 | 206 | prop_intersection_isSubsetOf_equiv = 207 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 208 | forAll arbitrary $ \b -> 209 | (IntervalSet.intersection a b == a) 210 | == IntervalSet.isSubsetOf a b 211 | 212 | case_intersections_empty_list = 213 | IntervalSet.intersections [] @?= (IntervalSet.whole :: IntervalSet Rational) 214 | 215 | prop_intersections_singleton_list = 216 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 217 | IntervalSet.intersections [a] == a 218 | 219 | prop_intersections_two_elems = 220 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 221 | forAll arbitrary $ \b -> 222 | IntervalSet.intersections [a,b] == IntervalSet.intersection a b 223 | 224 | {-------------------------------------------------------------------- 225 | Union 226 | --------------------------------------------------------------------} 227 | 228 | prop_union_comm = 229 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 230 | forAll arbitrary $ \b -> 231 | IntervalSet.union a b == IntervalSet.union b a 232 | 233 | prop_union_assoc = 234 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 235 | forAll arbitrary $ \b -> 236 | forAll arbitrary $ \c -> 237 | IntervalSet.union a (IntervalSet.union b c) == 238 | IntervalSet.union (IntervalSet.union a b) c 239 | 240 | prop_union_unitL = 241 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 242 | IntervalSet.union IntervalSet.empty a == a 243 | 244 | prop_union_unitR = 245 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 246 | IntervalSet.union a IntervalSet.empty == a 247 | 248 | prop_union_whole = 249 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 250 | IntervalSet.union a IntervalSet.whole == IntervalSet.whole 251 | 252 | prop_union_isSubsetOf_integer = 253 | forAll arbitrary $ \(a :: IntervalSet Integer) -> 254 | forAll arbitrary $ \b -> 255 | IntervalSet.isSubsetOf a (IntervalSet.union a b) 256 | 257 | prop_union_isSubsetOf = 258 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 259 | forAll arbitrary $ \b -> 260 | IntervalSet.isSubsetOf a (IntervalSet.union a b) 261 | 262 | prop_union_isSubsetOf_equiv_integer = 263 | forAll arbitrary $ \(a :: IntervalSet Integer) -> 264 | forAll arbitrary $ \b -> 265 | (IntervalSet.union a b == b) 266 | == IntervalSet.isSubsetOf a b 267 | 268 | prop_union_isSubsetOf_equiv = 269 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 270 | forAll arbitrary $ \b -> 271 | (IntervalSet.union a b == b) 272 | == IntervalSet.isSubsetOf a b 273 | 274 | case_unions_empty_list = 275 | IntervalSet.unions [] @?= (IntervalSet.empty :: IntervalSet Rational) 276 | 277 | prop_unions_singleton_list = 278 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 279 | IntervalSet.unions [a] == a 280 | 281 | prop_unions_two_elems = 282 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 283 | forAll arbitrary $ \b -> 284 | IntervalSet.unions [a,b] == IntervalSet.union a b 285 | 286 | prop_union_intersection_duality = 287 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 288 | forAll arbitrary $ \b -> 289 | IntervalSet.complement (IntervalSet.union a b) == 290 | IntervalSet.intersection (IntervalSet.complement a) (IntervalSet.complement b) 291 | 292 | {-------------------------------------------------------------------- 293 | span 294 | --------------------------------------------------------------------} 295 | 296 | prop_span_integer = 297 | forAll arbitrary $ \(a :: IntervalSet Integer) -> 298 | a `IntervalSet.isSubsetOf` IntervalSet.singleton (IntervalSet.span a) 299 | 300 | prop_span = 301 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 302 | a `IntervalSet.isSubsetOf` IntervalSet.singleton (IntervalSet.span a) 303 | 304 | case_span_empty = 305 | IntervalSet.span IntervalSet.empty @?= (Interval.empty :: Interval Rational) 306 | 307 | case_span_whole = 308 | IntervalSet.span IntervalSet.whole @?= (Interval.whole :: Interval Rational) 309 | 310 | case_span_without_zero = 311 | IntervalSet.span (IntervalSet.complement $ IntervalSet.singleton $ 0 <=..<= 0) @?= 312 | (Interval.whole :: Interval Rational) 313 | 314 | case_span_1 = 315 | IntervalSet.span (IntervalSet.fromList [0 <=..< 10, 20 <..< PosInf]) @?= 316 | 0 <=..< PosInf 317 | 318 | {-------------------------------------------------------------------- 319 | member 320 | --------------------------------------------------------------------} 321 | 322 | prop_member = 323 | forAll arbitrary $ \(r :: Rational) (is :: IntervalSet Rational) -> 324 | r `IntervalSet.member` is == 325 | any (r `Interval.member`) (IntervalSet.toList is) 326 | 327 | prop_member_empty = 328 | forAll arbitrary $ \(r :: Rational) -> 329 | not (r `IntervalSet.member` IntervalSet.empty) 330 | 331 | prop_member_singleton = 332 | forAll arbitrary $ \(r1 :: Rational) (r2 :: Rational) -> 333 | r1 `IntervalSet.member` IntervalSet.singleton (Interval.singleton r2) == 334 | (r1 == r2) 335 | 336 | prop_notMember_empty = 337 | forAll arbitrary $ \(r :: Rational) -> 338 | r `IntervalSet.notMember` IntervalSet.empty 339 | 340 | {-------------------------------------------------------------------- 341 | isSubsetOf 342 | --------------------------------------------------------------------} 343 | 344 | case_isSubsetOf_1 = IntervalSet.isSubsetOf a b @?= False 345 | where 346 | a = IntervalSet.singleton (NegInf <..<= 2) 347 | b = IntervalSet.singleton (NegInf <..<= 1) 348 | 349 | case_isSubsetOf_2 = IntervalSet.isSubsetOf a b @?= False 350 | where 351 | a = IntervalSet.singleton (1 <=..< PosInf) 352 | b = IntervalSet.singleton (2 <=..< PosInf) 353 | 354 | case_isSubsetOf_3 = IntervalSet.isSubsetOf a b @?= False 355 | where 356 | a = IntervalSet.singleton (0 <=..< 1) 357 | b = IntervalSet.singleton (2 <..< PosInf) 358 | 359 | case_isSubsetOf_4 = IntervalSet.isSubsetOf a b @?= False 360 | where 361 | a = IntervalSet.singleton (0 <=..<= 1) 362 | b = IntervalSet.singleton (2 <..< PosInf) 363 | 364 | case_isSubsetOf_5 = IntervalSet.isSubsetOf a b @?= False 365 | where 366 | a = IntervalSet.singleton (0 <..< 1) 367 | b = IntervalSet.singleton (2 <=..< PosInf) 368 | 369 | case_isSubsetOf_6 = IntervalSet.isSubsetOf a b @?= False 370 | where 371 | a = IntervalSet.singleton (0 <..< 1) 372 | b = IntervalSet.singleton (2 <..< PosInf) 373 | 374 | case_isSubsetOf_7 = IntervalSet.isSubsetOf a b @?= False 375 | where 376 | a = IntervalSet.singleton (0 <..<= 1) 377 | b = IntervalSet.fromList [NegInf <..<= 0, 1 <=..< PosInf] 378 | 379 | case_isSubsetOf_8 = IntervalSet.isSubsetOf a b @?= False 380 | where 381 | a = IntervalSet.singleton (0 <..< 1) 382 | b = IntervalSet.fromList [NegInf <..< 0, 1 <=..< PosInf] 383 | 384 | case_isSubsetOf_9 = IntervalSet.isSubsetOf a b @?= True 385 | where 386 | a = IntervalSet.singleton (-3 <..< 1) 387 | b = IntervalSet.singleton (-4 <..< 2) 388 | 389 | case_isSubsetOf_10 = IntervalSet.isSubsetOf a b @?= True 390 | where 391 | a = IntervalSet.singleton (14 <=..<= 16) 392 | b = IntervalSet.singleton (-8 <=..< PosInf) 393 | 394 | case_isSubsetOf_11 = IntervalSet.isSubsetOf a b @?= False 395 | where 396 | a = IntervalSet.singleton (0 <=..<= 1) 397 | b = IntervalSet.fromList [0 <=..<= 0, 1 <=..< PosInf] 398 | 399 | prop_isSubsetOf_reflexive = 400 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 401 | a `IntervalSet.isSubsetOf` a 402 | 403 | prop_isProperSubsetOf_irreflexive = 404 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 405 | not (a `IntervalSet.isProperSubsetOf` a) 406 | 407 | prop_isSubsetOf_empty = 408 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 409 | IntervalSet.empty `IntervalSet.isSubsetOf` a 410 | 411 | prop_isSubsetOf_whole = 412 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 413 | a `IntervalSet.isSubsetOf` IntervalSet.whole 414 | 415 | {-------------------------------------------------------------------- 416 | toList / fromList 417 | --------------------------------------------------------------------} 418 | 419 | prop_fromList_toList_id = 420 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 421 | IntervalSet.fromList (IntervalSet.toList a) == a 422 | 423 | prop_fromAscList_toAscList_id = 424 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 425 | IntervalSet.fromAscList (IntervalSet.toAscList a) == a 426 | 427 | case_toDescList_simple = xs @?= xs 428 | where 429 | xs = IntervalSet.toDescList $ 430 | IntervalSet.fromList [NegInf <..< Finite (-1), Finite 1 <..< PosInf] 431 | 432 | prop_toAscList_toDescList = 433 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 434 | IntervalSet.toDescList a == reverse (IntervalSet.toAscList a) 435 | 436 | {-------------------------------------------------------------------- 437 | Eq 438 | --------------------------------------------------------------------} 439 | 440 | prop_Eq_reflexive = 441 | forAll arbitrary $ \(i :: IntervalSet Rational) -> 442 | i == i 443 | 444 | {-------------------------------------------------------------------- 445 | Lattice 446 | --------------------------------------------------------------------} 447 | 448 | #ifdef MIN_VERSION_lattices 449 | 450 | prop_Lattice_Leq_welldefined = 451 | forAll arbitrary $ \(a :: IntervalSet Rational) (b :: IntervalSet Rational) -> 452 | a `L.meetLeq` b == a `L.joinLeq` b 453 | 454 | prop_top = 455 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 456 | a `L.joinLeq` L.top 457 | 458 | prop_bottom = 459 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 460 | L.bottom `L.joinLeq` a 461 | 462 | #else 463 | 464 | prop_Lattice_Leq_welldefined = True 465 | prop_top = True 466 | prop_bottom = True 467 | 468 | #endif 469 | 470 | {-------------------------------------------------------------------- 471 | Show / Read 472 | --------------------------------------------------------------------} 473 | 474 | prop_show_read_invariance = 475 | forAll arbitrary $ \(i :: IntervalSet Rational) -> 476 | i == read (show i) 477 | 478 | {-------------------------------------------------------------------- 479 | NFData 480 | --------------------------------------------------------------------} 481 | 482 | prop_rnf = 483 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 484 | rnf a == () 485 | 486 | {-------------------------------------------------------------------- 487 | Hashable 488 | --------------------------------------------------------------------} 489 | 490 | prop_hash = 491 | forAll arbitrary $ \(i :: IntervalSet Rational) -> 492 | hash i `seq` True 493 | 494 | {-------------------------------------------------------------------- 495 | Monoid 496 | --------------------------------------------------------------------} 497 | 498 | prop_monoid_assoc = 499 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 500 | forAll arbitrary $ \b -> 501 | forAll arbitrary $ \c -> 502 | a <> (b <> c) == (a <> b) <> c 503 | 504 | prop_monoid_unitL = 505 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 506 | mempty <> a == a 507 | 508 | prop_monoid_unitR = 509 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 510 | a <> mempty == a 511 | 512 | {-------------------------------------------------------------------- 513 | Num 514 | --------------------------------------------------------------------} 515 | 516 | prop_scale_empty = 517 | forAll arbitrary $ \r -> 518 | fromRational (r::Rational) * IntervalSet.empty == IntervalSet.empty 519 | 520 | prop_add_comm = 521 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 522 | forAll arbitrary $ \b -> 523 | a + b == b + a 524 | 525 | prop_add_assoc = 526 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 527 | forAll arbitrary $ \b -> 528 | forAll arbitrary $ \c -> 529 | a + (b + c) == (a + b) + c 530 | 531 | prop_add_unitL = 532 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 533 | IntervalSet.singleton 0 + a == a 534 | 535 | prop_add_unitR = 536 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 537 | a + IntervalSet.singleton 0 == a 538 | 539 | prop_add_member = 540 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 541 | forAll arbitrary $ \b -> 542 | and [ (x+y) `IntervalSet.member` (a+b) 543 | | x <- maybeToList $ pickup a 544 | , y <- maybeToList $ pickup b 545 | ] 546 | 547 | prop_mult_comm = 548 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 549 | forAll arbitrary $ \b -> 550 | a * b == b * a 551 | 552 | prop_mult_assoc = 553 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 554 | forAll arbitrary $ \b -> 555 | forAll arbitrary $ \c -> 556 | a * (b * c) == (a * b) * c 557 | 558 | prop_mult_unitL = 559 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 560 | IntervalSet.singleton 1 * a == a 561 | 562 | prop_mult_unitR = 563 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 564 | a * IntervalSet.singleton 1 == a 565 | 566 | prop_mult_dist = 567 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 568 | forAll arbitrary $ \b -> 569 | forAll arbitrary $ \c -> 570 | (a * (b + c)) `IntervalSet.isSubsetOf` (a * b + a * c) 571 | 572 | prop_mult_empty = 573 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 574 | IntervalSet.empty * a == IntervalSet.empty 575 | 576 | prop_mult_zero = 577 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 578 | not (IntervalSet.null a) ==> IntervalSet.singleton 0 * a == IntervalSet.singleton 0 579 | 580 | prop_mult_member = 581 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 582 | forAll arbitrary $ \b -> 583 | and [ (x*y) `IntervalSet.member` (a*b) 584 | | x <- maybeToList $ pickup a 585 | , y <- maybeToList $ pickup b 586 | ] 587 | 588 | prop_abs_signum = 589 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 590 | abs (signum a) `IntervalSet.isSubsetOf` IntervalSet.singleton (0 <=..<= 1) 591 | 592 | prop_negate_negate = 593 | forAll arbitrary $ \(a :: IntervalSet Rational) -> 594 | negate (negate a) == a 595 | 596 | {-------------------------------------------------------------------- 597 | Fractional 598 | --------------------------------------------------------------------} 599 | 600 | prop_recip_singleton = 601 | forAll arbitrary $ \r -> 602 | let n = fromIntegral (numerator r) 603 | d = fromIntegral (denominator r) 604 | in fromRational n / fromRational d == (fromRational (r::Rational) :: IntervalSet Rational) 605 | 606 | prop_recip (a :: IntervalSet Rational) = 607 | recip (recip a) === IntervalSet.delete (Interval.singleton 0) a 608 | 609 | {- ------------------------------------------------------------------ 610 | Data 611 | ------------------------------------------------------------------ -} 612 | 613 | case_Data = everywhere f i @?= (IntervalSet.singleton (1 <=..<= 2) :: IntervalSet Integer) 614 | where 615 | i :: IntervalSet Integer 616 | i = IntervalSet.singleton (0 <=..<= 1) 617 | f x 618 | | Just (y :: Integer) <- cast x = fromJust $ cast (y + 1) 619 | | otherwise = x 620 | 621 | {-------------------------------------------------------------------- 622 | Generators 623 | --------------------------------------------------------------------} 624 | 625 | instance Arbitrary Interval.Boundary where 626 | arbitrary = arbitraryBoundedEnum 627 | 628 | instance Arbitrary r => Arbitrary (Extended r) where 629 | arbitrary = 630 | oneof 631 | [ pure NegInf 632 | , pure PosInf 633 | , fmap Finite arbitrary 634 | ] 635 | 636 | instance (Arbitrary r, Ord r) => Arbitrary (Interval r) where 637 | arbitrary = 638 | Interval.interval <$> arbitrary <*> arbitrary 639 | 640 | instance (Arbitrary r, Ord r) => Arbitrary (IntervalSet r) where 641 | arbitrary = do 642 | tabStops <- L.sort <$> arbitrary 643 | let is = IntervalSet.fromList $ go tabStops 644 | b <- arbitrary 645 | pure $ if b then is else IntervalSet.complement is 646 | where 647 | go [] = [] 648 | go [(x, LT)] = [Finite x <..< PosInf] 649 | go [(x, GT)] = [Finite x <=..< PosInf] 650 | go ((x, EQ) : rest) = Interval.singleton x : go rest 651 | go ((x, LT) : (y, LT) : rest) = (Finite x <..< Finite y) : go rest 652 | go ((x, LT) : (y, GT) : rest) = (Finite x <..<= Finite y) : go rest 653 | go ((x, GT) : (y, LT) : rest) = (Finite x <=..< Finite y) : go rest 654 | go ((x, GT) : (y, GT) : rest) = (Finite x <=..<= Finite y) : go rest 655 | go ((x, LT) : (y, EQ) : rest) = (Finite x <..< Finite y) : go ((y, LT) : rest) 656 | go ((x, GT) : (y, EQ) : rest) = (Finite x <=..< Finite y) : go ((y, LT) : rest) 657 | 658 | intervals :: Gen (Interval Rational) 659 | intervals = arbitrary 660 | 661 | pos :: Interval Rational 662 | pos = 0 <..< PosInf 663 | 664 | neg :: Interval Rational 665 | neg = NegInf <..< 0 666 | 667 | nonpos :: Interval Rational 668 | nonpos = NegInf <..<= 0 669 | 670 | nonneg :: Interval Rational 671 | nonneg = 0 <=..< PosInf 672 | 673 | pickup :: (Ord r, Real r, Fractional r) => IntervalSet r -> Maybe r 674 | pickup xs = do 675 | x <- listToMaybe (IntervalSet.toList xs) 676 | Interval.pickup x 677 | 678 | ------------------------------------------------------------------------ 679 | -- Test harness 680 | 681 | intervalSetTestGroup = $(testGroupGenerator) 682 | -------------------------------------------------------------------------------- /src/Data/Interval.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} 2 | {-# LANGUAGE CPP, LambdaCase, ScopedTypeVariables #-} 3 | {-# LANGUAGE Safe #-} 4 | {-# LANGUAGE RoleAnnotations #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.Interval 8 | -- Copyright : (c) Masahiro Sakai 2011-2013, Andrew Lelechenko 2020 9 | -- License : BSD-style 10 | -- 11 | -- Maintainer : masahiro.sakai@gmail.com 12 | -- Stability : provisional 13 | -- 14 | -- Interval datatype and interval arithmetic. 15 | -- 16 | -- Unlike the intervals package (), 17 | -- this module provides both open and closed intervals and is intended to be used 18 | -- with 'Rational'. 19 | -- 20 | -- For the purpose of abstract interpretation, it might be convenient to use 21 | -- 'Lattice' instance. See also lattices package 22 | -- (). 23 | -- 24 | ----------------------------------------------------------------------------- 25 | module Data.Interval 26 | ( 27 | -- * Interval type 28 | Interval 29 | , module Data.ExtendedReal 30 | , Boundary(..) 31 | 32 | -- * Construction 33 | , interval 34 | , (<=..<=) 35 | , (<..<=) 36 | , (<=..<) 37 | , (<..<) 38 | , whole 39 | , empty 40 | , singleton 41 | 42 | -- * Query 43 | , null 44 | , isSingleton 45 | , extractSingleton 46 | , member 47 | , notMember 48 | , isSubsetOf 49 | , isProperSubsetOf 50 | , isConnected 51 | , lowerBound 52 | , upperBound 53 | , lowerBound' 54 | , upperBound' 55 | , width 56 | 57 | -- * Universal comparison operators 58 | , (=!), (>!), (/=!) 59 | 60 | -- * Existential comparison operators 61 | , (=?), (>?), (/=?) 62 | 63 | -- * Existential comparison operators that produce witnesses (experimental) 64 | , (=??), (>??), (/=??) 65 | 66 | -- * Combine 67 | , intersection 68 | , intersections 69 | , hull 70 | , hulls 71 | 72 | -- * Map 73 | , mapMonotonic 74 | 75 | -- * Operations 76 | , pickup 77 | , simplestRationalWithin 78 | 79 | -- * Intervals relation 80 | , relate 81 | ) where 82 | 83 | #ifdef MIN_VERSION_lattices 84 | import Algebra.Lattice 85 | #endif 86 | import Control.Exception (assert) 87 | import Control.Monad hiding (join) 88 | import Data.ExtendedReal 89 | import Data.Foldable hiding (null) 90 | import Data.Interval.Internal 91 | import Data.IntervalRelation 92 | import Data.Maybe 93 | import Data.Monoid 94 | import Data.Ratio 95 | import Prelude hiding (Foldable(..)) 96 | 97 | infix 5 <=..<= 98 | infix 5 <..<= 99 | infix 5 <=..< 100 | infix 5 <..< 101 | infix 4 =! 105 | infix 4 >! 106 | infix 4 /=! 107 | infix 4 =? 111 | infix 4 >? 112 | infix 4 /=? 113 | infix 4 =?? 117 | infix 4 >?? 118 | infix 4 /=?? 119 | 120 | #ifdef MIN_VERSION_lattices 121 | instance (Ord r) => Lattice (Interval r) where 122 | (\/) = hull 123 | (/\) = intersection 124 | 125 | instance (Ord r) => BoundedJoinSemiLattice (Interval r) where 126 | bottom = empty 127 | 128 | instance (Ord r) => BoundedMeetSemiLattice (Interval r) where 129 | top = whole 130 | #endif 131 | 132 | instance (Ord r, Show r) => Show (Interval r) where 133 | showsPrec _ x | null x = showString "empty" 134 | showsPrec p i = 135 | showParen (p > rangeOpPrec) $ 136 | showsPrec (rangeOpPrec+1) lb . 137 | showChar ' ' . showString op . showChar ' ' . 138 | showsPrec (rangeOpPrec+1) ub 139 | where 140 | (lb, in1) = lowerBound' i 141 | (ub, in2) = upperBound' i 142 | op = sign in1 ++ ".." ++ sign in2 143 | sign = \case 144 | Open -> "<" 145 | Closed -> "<=" 146 | 147 | instance (Ord r, Read r) => Read (Interval r) where 148 | readsPrec p r = 149 | (readParen (p > appPrec) $ \s0 -> do 150 | ("interval",s1) <- lex s0 151 | (lb,s2) <- readsPrec (appPrec+1) s1 152 | (ub,s3) <- readsPrec (appPrec+1) s2 153 | return (interval lb ub, s3)) r 154 | ++ 155 | (readParen (p > rangeOpPrec) $ \s0 -> do 156 | (do (l,s1) <- readsPrec (rangeOpPrec+1) s0 157 | (op',s2) <- lex s1 158 | op <- 159 | case op' of 160 | "<=..<=" -> return (<=..<=) 161 | "<..<=" -> return (<..<=) 162 | "<=..<" -> return (<=..<) 163 | "<..<" -> return (<..<) 164 | _ -> [] 165 | (u,s3) <- readsPrec (rangeOpPrec+1) s2 166 | return (op l u, s3))) r 167 | ++ 168 | (do ("empty", s) <- lex r 169 | return (empty, s)) 170 | 171 | -- | Lower endpoint (/i.e./ greatest lower bound) of the interval. 172 | -- 173 | -- * 'lowerBound' of the empty interval is 'PosInf'. 174 | -- 175 | -- * 'lowerBound' of a left unbounded interval is 'NegInf'. 176 | -- 177 | -- * 'lowerBound' of an interval may or may not be a member of the interval. 178 | lowerBound :: Interval r -> Extended r 179 | lowerBound = fst . lowerBound' 180 | 181 | -- | Upper endpoint (/i.e./ least upper bound) of the interval. 182 | -- 183 | -- * 'upperBound' of the empty interval is 'NegInf'. 184 | -- 185 | -- * 'upperBound' of a right unbounded interval is 'PosInf'. 186 | -- 187 | -- * 'upperBound' of an interval may or may not be a member of the interval. 188 | upperBound :: Interval r -> Extended r 189 | upperBound = fst . upperBound' 190 | 191 | -- | closed interval [@l@,@u@] 192 | (<=..<=) 193 | :: (Ord r) 194 | => Extended r -- ^ lower bound @l@ 195 | -> Extended r -- ^ upper bound @u@ 196 | -> Interval r 197 | (<=..<=) lb ub = interval (lb, Closed) (ub, Closed) 198 | 199 | -- | left-open right-closed interval (@l@,@u@] 200 | (<..<=) 201 | :: (Ord r) 202 | => Extended r -- ^ lower bound @l@ 203 | -> Extended r -- ^ upper bound @u@ 204 | -> Interval r 205 | (<..<=) lb ub = interval (lb, Open) (ub, Closed) 206 | 207 | -- | left-closed right-open interval [@l@, @u@) 208 | (<=..<) 209 | :: (Ord r) 210 | => Extended r -- ^ lower bound @l@ 211 | -> Extended r -- ^ upper bound @u@ 212 | -> Interval r 213 | (<=..<) lb ub = interval (lb, Closed) (ub, Open) 214 | 215 | -- | open interval (@l@, @u@) 216 | (<..<) 217 | :: (Ord r) 218 | => Extended r -- ^ lower bound @l@ 219 | -> Extended r -- ^ upper bound @u@ 220 | -> Interval r 221 | (<..<) lb ub = interval (lb, Open) (ub, Open) 222 | 223 | -- | whole real number line (-∞, ∞) 224 | whole :: Ord r => Interval r 225 | whole = interval (NegInf, Open) (PosInf, Open) 226 | 227 | -- | singleton set [x,x] 228 | singleton :: Ord r => r -> Interval r 229 | singleton x = interval (Finite x, Closed) (Finite x, Closed) 230 | 231 | -- | intersection of two intervals 232 | intersection :: forall r. Ord r => Interval r -> Interval r -> Interval r 233 | intersection i1 i2 = interval 234 | (maxLB (lowerBound' i1) (lowerBound' i2)) 235 | (minUB (upperBound' i1) (upperBound' i2)) 236 | where 237 | maxLB :: (Extended r, Boundary) -> (Extended r, Boundary) -> (Extended r, Boundary) 238 | maxLB (x1,in1) (x2,in2) = 239 | ( max x1 x2 240 | , case x1 `compare` x2 of 241 | EQ -> in1 `min` in2 242 | LT -> in2 243 | GT -> in1 244 | ) 245 | minUB :: (Extended r, Boundary) -> (Extended r, Boundary) -> (Extended r, Boundary) 246 | minUB (x1,in1) (x2,in2) = 247 | ( min x1 x2 248 | , case x1 `compare` x2 of 249 | EQ -> in1 `min` in2 250 | LT -> in1 251 | GT -> in2 252 | ) 253 | 254 | -- | intersection of a list of intervals. 255 | -- 256 | -- @since 0.6.0 257 | intersections :: Ord r => [Interval r] -> Interval r 258 | intersections = foldl' intersection whole 259 | 260 | -- | convex hull of two intervals 261 | hull :: forall r. Ord r => Interval r -> Interval r -> Interval r 262 | hull x1 x2 263 | | null x1 = x2 264 | | null x2 = x1 265 | hull i1 i2 = interval 266 | (minLB (lowerBound' i1) (lowerBound' i2)) 267 | (maxUB (upperBound' i1) (upperBound' i2)) 268 | where 269 | maxUB :: (Extended r, Boundary) -> (Extended r, Boundary) -> (Extended r, Boundary) 270 | maxUB (x1,in1) (x2,in2) = 271 | ( max x1 x2 272 | , case x1 `compare` x2 of 273 | EQ -> in1 `max` in2 274 | LT -> in2 275 | GT -> in1 276 | ) 277 | minLB :: (Extended r, Boundary) -> (Extended r, Boundary) -> (Extended r, Boundary) 278 | minLB (x1,in1) (x2,in2) = 279 | ( min x1 x2 280 | , case x1 `compare` x2 of 281 | EQ -> in1 `max` in2 282 | LT -> in1 283 | GT -> in2 284 | ) 285 | 286 | -- | convex hull of a list of intervals. 287 | -- 288 | -- @since 0.6.0 289 | hulls :: Ord r => [Interval r] -> Interval r 290 | hulls = foldl' hull empty 291 | 292 | -- | Is the interval empty? 293 | null :: Ord r => Interval r -> Bool 294 | null i = 295 | case x1 `compare` x2 of 296 | EQ -> assert (in1 == Closed && in2 == Closed) False 297 | LT -> False 298 | GT -> True 299 | where 300 | (x1, in1) = lowerBound' i 301 | (x2, in2) = upperBound' i 302 | 303 | -- | Is the interval single point? 304 | -- 305 | -- @since 2.0.0 306 | isSingleton :: Ord r => Interval r -> Bool 307 | isSingleton = isJust . extractSingleton 308 | 309 | -- | If the interval is a single point, return this point. 310 | -- 311 | -- @since 2.1.0 312 | extractSingleton :: Ord r => Interval r -> Maybe r 313 | extractSingleton i = case (lowerBound' i, upperBound' i) of 314 | ((Finite l, Closed), (Finite u, Closed)) 315 | | l == u -> Just l 316 | _ -> Nothing 317 | 318 | -- | Is the element in the interval? 319 | member :: Ord r => r -> Interval r -> Bool 320 | member x i = condLB && condUB 321 | where 322 | (x1, in1) = lowerBound' i 323 | (x2, in2) = upperBound' i 324 | condLB = case in1 of 325 | Open -> x1 < Finite x 326 | Closed -> x1 <= Finite x 327 | condUB = case in2 of 328 | Open -> Finite x < x2 329 | Closed -> Finite x <= x2 330 | 331 | -- | Is the element not in the interval? 332 | notMember :: Ord r => r -> Interval r -> Bool 333 | notMember a i = not $ member a i 334 | 335 | -- | Is this a subset? 336 | -- @(i1 \``isSubsetOf`\` i2)@ tells whether @i1@ is a subset of @i2@. 337 | isSubsetOf :: Ord r => Interval r -> Interval r -> Bool 338 | isSubsetOf i1 i2 = testLB (lowerBound' i1) (lowerBound' i2) && testUB (upperBound' i1) (upperBound' i2) 339 | where 340 | testLB (x1,in1) (x2,in2) = 341 | case x1 `compare` x2 of 342 | GT -> True 343 | LT -> False 344 | EQ -> in1 <= in2 345 | testUB (x1,in1) (x2,in2) = 346 | case x1 `compare` x2 of 347 | LT -> True 348 | GT -> False 349 | EQ -> in1 <= in2 350 | 351 | -- | Is this a proper subset? (/i.e./ a subset but not equal). 352 | isProperSubsetOf :: Ord r => Interval r -> Interval r -> Bool 353 | isProperSubsetOf i1 i2 = i1 /= i2 && i1 `isSubsetOf` i2 354 | 355 | -- | Does the union of two range form a connected set? 356 | -- 357 | -- @since 1.3.0 358 | isConnected :: Ord r => Interval r -> Interval r -> Bool 359 | isConnected x y 360 | | null x = True 361 | | null y = True 362 | | otherwise = x ==? y || (lb1==ub2 && (lb1in == Closed || ub2in == Closed)) || (ub1==lb2 && (ub1in == Closed || lb2in == Closed)) 363 | where 364 | (lb1,lb1in) = lowerBound' x 365 | (lb2,lb2in) = lowerBound' y 366 | (ub1,ub1in) = upperBound' x 367 | (ub2,ub2in) = upperBound' y 368 | 369 | -- | Width of a interval. Width of an unbounded interval is @undefined@. 370 | width :: (Num r, Ord r) => Interval r -> r 371 | width x 372 | | null x = 0 373 | | otherwise = case (fst (lowerBound' x), fst (upperBound' x)) of 374 | (Finite l, Finite u) -> u - l 375 | _ -> error "Data.Interval.width: unbounded interval" 376 | 377 | -- | pick up an element from the interval if the interval is not empty. 378 | pickup :: (Real r, Fractional r) => Interval r -> Maybe r 379 | pickup i = case (lowerBound' i, upperBound' i) of 380 | ((NegInf,_), (PosInf,_)) -> Just 0 381 | ((Finite x1, in1), (PosInf,_)) -> Just $ case in1 of 382 | Open -> x1 + 1 383 | Closed -> x1 384 | ((NegInf,_), (Finite x2, in2)) -> Just $ case in2 of 385 | Open -> x2 - 1 386 | Closed -> x2 387 | ((Finite x1, in1), (Finite x2, in2)) -> 388 | case x1 `compare` x2 of 389 | GT -> Nothing 390 | LT -> Just $ (x1+x2) / 2 391 | EQ -> if in1 == Closed && in2 == Closed then Just x1 else Nothing 392 | _ -> Nothing 393 | 394 | -- | 'simplestRationalWithin' returns the simplest rational number within the interval. 395 | -- 396 | -- A rational number @y@ is said to be /simpler/ than another @y'@ if 397 | -- 398 | -- * @'abs' ('numerator' y) <= 'abs' ('numerator' y')@, and 399 | -- 400 | -- * @'denominator' y <= 'denominator' y'@. 401 | -- 402 | -- (see also 'approxRational') 403 | -- 404 | -- @since 0.4.0 405 | simplestRationalWithin :: RealFrac r => Interval r -> Maybe Rational 406 | simplestRationalWithin i | null i = Nothing 407 | simplestRationalWithin i 408 | | 0 (a -> b) -> Interval a -> Interval b 423 | mapMonotonic f i = interval (fmap f lb, in1) (fmap f ub, in2) 424 | where 425 | (lb, in1) = lowerBound' i 426 | (ub, in2) = upperBound' i 427 | 428 | mapAntiMonotonic :: (Ord a, Ord b) => (a -> b) -> Interval a -> Interval b 429 | mapAntiMonotonic f i 430 | | null i = empty 431 | | otherwise = interval (fmap f ub, in2) (fmap f lb, in1) 432 | where 433 | (lb, in1) = lowerBound' i 434 | (ub, in2) = upperBound' i 435 | 436 | -- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@? 437 | ( Interval r -> Interval r -> Bool 438 | a True 441 | GT -> False 442 | EQ -> 443 | case ub_a of 444 | NegInf -> True -- a is empty, so it holds vacuously 445 | PosInf -> True -- b is empty, so it holds vacuously 446 | Finite _ -> in1 == Open || in2 == Open 447 | where 448 | (ub_a, in1) = upperBound' a 449 | (lb_b, in2) = lowerBound' b 450 | 451 | -- | For all @x@ in @X@, @y@ in @Y@. @x '<=' y@? 452 | (<=!) :: Ord r => Interval r -> Interval r -> Bool 453 | a <=! b = upperBound a <= lowerBound b 454 | 455 | -- | For all @x@ in @X@, @y@ in @Y@. @x '==' y@? 456 | (==!) :: Ord r => Interval r -> Interval r -> Bool 457 | a ==! b = a <=! b && a >=! b 458 | 459 | -- | For all @x@ in @X@, @y@ in @Y@. @x '/=' y@? 460 | -- 461 | -- @since 1.0.1 462 | (/=!) :: Ord r => Interval r -> Interval r -> Bool 463 | a /=! b = null $ a `intersection` b 464 | 465 | -- | For all @x@ in @X@, @y@ in @Y@. @x '>=' y@? 466 | (>=!) :: Ord r => Interval r -> Interval r -> Bool 467 | (>=!) = flip (<=!) 468 | 469 | -- | For all @x@ in @X@, @y@ in @Y@. @x '>' y@? 470 | (>!) :: Ord r => Interval r -> Interval r -> Bool 471 | (>!) = flip ( Interval r -> Interval r -> Bool 475 | a Interval r -> Interval r -> Maybe (r,r) 484 | a do 489 | x <- pickup a 490 | y <- pickup b 491 | return (x,y) 492 | Just z -> do 493 | let x:y:_ = take 2 $ 494 | maybeToList (pickup (intersection a (-inf <..< Finite z))) ++ 495 | [z] ++ 496 | maybeToList (pickup (intersection b (Finite z <..< inf))) 497 | return (x,y) 498 | 499 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@? 500 | (<=?) :: Ord r => Interval r -> Interval r -> Bool 501 | a <=? b = 502 | case lb_a `compare` ub_b of 503 | LT -> True 504 | GT -> False 505 | EQ -> 506 | case lb_a of 507 | NegInf -> False -- b is empty 508 | PosInf -> False -- a is empty 509 | Finite _ -> in1 == Closed && in2 == Closed 510 | where 511 | (lb_a, in1) = lowerBound' a 512 | (ub_b, in2) = upperBound' b 513 | 514 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@? 515 | -- 516 | -- @since 1.0.0 517 | (<=??) :: (Real r, Fractional r) => Interval r -> Interval r -> Maybe (r,r) 518 | a <=?? b = 519 | case pickup (intersection a b) of 520 | Just x -> return (x,x) 521 | Nothing -> do 522 | guard $ upperBound a <= lowerBound b 523 | x <- pickup a 524 | y <- pickup b 525 | return (x,y) 526 | 527 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@? 528 | -- 529 | -- @since 1.0.0 530 | (==?) :: Ord r => Interval r -> Interval r -> Bool 531 | a ==? b = not $ null $ intersection a b 532 | 533 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@? 534 | -- 535 | -- @since 1.0.0 536 | (==??) :: (Real r, Fractional r) => Interval r -> Interval r -> Maybe (r,r) 537 | a ==?? b = do 538 | x <- pickup (intersection a b) 539 | return (x,x) 540 | 541 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@? 542 | -- 543 | -- @since 1.0.1 544 | (/=?) :: Ord r => Interval r -> Interval r -> Bool 545 | a /=? b = not (null a) && not (null b) && not (a == b && isSingleton a) 546 | 547 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@? 548 | -- 549 | -- @since 1.0.1 550 | (/=??) :: (Real r, Fractional r) => Interval r -> Interval r -> Maybe (r,r) 551 | a /=?? b = do 552 | guard $ not $ null a 553 | guard $ not $ null b 554 | guard $ not $ a == b && isSingleton a 555 | if not (isSingleton b) 556 | then f a b 557 | else liftM (\(y,x) -> (x,y)) $ f b a 558 | where 559 | f i j = do 560 | x <- pickup i 561 | y <- msum [pickup (j `intersection` c) | c <- [-inf <..< Finite x, Finite x <..< inf]] 562 | return (x,y) 563 | 564 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@? 565 | (>=?) :: Ord r => Interval r -> Interval r -> Bool 566 | (>=?) = flip (<=?) 567 | 568 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@? 569 | (>?) :: Ord r => Interval r -> Interval r -> Bool 570 | (>?) = flip (=' y@? 573 | -- 574 | -- @since 1.0.0 575 | (>=??) :: (Real r, Fractional r) => Interval r -> Interval r -> Maybe (r,r) 576 | (>=??) = flip (<=??) 577 | 578 | -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@? 579 | -- 580 | -- @since 1.0.0 581 | (>??) :: (Real r, Fractional r) => Interval r -> Interval r -> Maybe (r,r) 582 | (>??) = flip ( r -> Interval r -> Interval r 591 | scaleInterval c x 592 | | null x = empty 593 | | otherwise = case compare c 0 of 594 | EQ -> singleton 0 595 | LT -> interval (scaleInf' c ub) (scaleInf' c lb) 596 | GT -> interval (scaleInf' c lb) (scaleInf' c ub) 597 | where 598 | lb = lowerBound' x 599 | ub = upperBound' x 600 | 601 | -- | When results of 'abs' or 'signum' do not form a connected interval, 602 | -- a convex hull is returned instead. 603 | instance (Num r, Ord r) => Num (Interval r) where 604 | a + b 605 | | null a || null b = empty 606 | | otherwise = interval (f (lowerBound' a) (lowerBound' b)) (g (upperBound' a) (upperBound' b)) 607 | where 608 | f (Finite x1, in1) (Finite x2, in2) = (Finite (x1+x2), in1 `min` in2) 609 | f (NegInf,_) _ = (-inf, Open) 610 | f _ (NegInf,_) = (-inf, Open) 611 | f _ _ = error "Interval.(+) should not happen" 612 | 613 | g (Finite x1, in1) (Finite x2, in2) = (Finite (x1+x2), in1 `min` in2) 614 | g (PosInf,_) _ = (inf, Open) 615 | g _ (PosInf,_) = (inf, Open) 616 | g _ _ = error "Interval.(+) should not happen" 617 | 618 | negate = scaleInterval (-1) 619 | 620 | fromInteger i = singleton (fromInteger i) 621 | 622 | abs x = (x `intersection` nonneg) `hull` (negate x `intersection` nonneg) 623 | where 624 | nonneg = 0 <=..< inf 625 | 626 | signum x = zero `hull` pos `hull` neg 627 | where 628 | zero = if member 0 x then singleton 0 else empty 629 | pos = if null $ (0 <..< inf) `intersection` x 630 | then empty 631 | else singleton 1 632 | neg = if null $ (-inf <..< 0) `intersection` x 633 | then empty 634 | else singleton (-1) 635 | 636 | a * b 637 | | null a || null b = empty 638 | | otherwise = interval lb3 ub3 639 | where 640 | xs = [ mulInf' x1 x2 | x1 <- [lowerBound' a, upperBound' a], x2 <- [lowerBound' b, upperBound' b] ] 641 | ub3 = maximumBy cmpUB xs 642 | lb3 = minimumBy cmpLB xs 643 | 644 | -- | 'recip' returns 'whole' when 0 is an interior point. 645 | -- Otherwise @recip (recip xs)@ equals to @xs@ without 0. 646 | instance forall r. (Real r, Fractional r) => Fractional (Interval r) where 647 | fromRational r = singleton (fromRational r) 648 | recip a 649 | | null a = empty 650 | | a == 0 = empty 651 | | 0 `member` a && 0 /= lowerBound a && 0 /= upperBound a = whole 652 | | otherwise = interval lb3 ub3 653 | where 654 | ub3 = maximumBy cmpUB xs 655 | lb3 = minimumBy cmpLB xs 656 | xs = [recipLB (lowerBound' a), recipUB (upperBound' a)] 657 | 658 | -- | When results of 'tan' or '**' do not form a connected interval, 659 | -- a convex hull is returned instead. 660 | instance (RealFrac r, Floating r) => Floating (Interval r) where 661 | pi = singleton pi 662 | 663 | exp = intersection (0 <..< PosInf) . mapMonotonic exp 664 | log a = interval (logB (lowerBound' b)) (logB (upperBound' b)) 665 | where 666 | b = intersection (0 <..< PosInf) a 667 | 668 | sqrt = mapMonotonic sqrt . intersection (0 <=..< PosInf) 669 | 670 | a ** b = hulls (posBase : negBasePosPower : negBaseNegPower : zeroPower ++ zeroBase) 671 | where 672 | posBase = exp (log a * b) 673 | zeroPower = [ 1 | 0 `member` b, not (null a) ] 674 | zeroBase = [ 0 | 0 `member` a, not (null (b `intersection` (0 <..< PosInf))) ] 675 | negBasePosPower = positiveIntegralPowersOfNegativeValues 676 | (a `intersection` (NegInf <..< 0)) 677 | (b `intersection` (0 <..< PosInf)) 678 | negBaseNegPower = positiveIntegralPowersOfNegativeValues 679 | (recip (a `intersection` (NegInf <..< 0))) 680 | (negate (b `intersection` (NegInf <..< 0))) 681 | 682 | cos a = case lowerBound' a of 683 | (NegInf, _) -> -1 <=..<= 1 684 | (PosInf, _) -> empty 685 | (Finite lb, in1) -> case upperBound' a of 686 | (NegInf, _) -> empty 687 | (PosInf, _) -> -1 <=..<= 1 688 | (Finite ub, in2) 689 | | ub - lb > 2 * pi -> -1 <=..<= 1 690 | | clb == -1 && ub - lb == 2 * pi && in1 == Open && in2 == Open -> -1 <..<= 1 691 | | clb == 1 && ub - lb == 2 * pi && in1 == Open && in2 == Open -> -1 <=..< 1 692 | | ub - lb == 2 * pi -> -1 <=..<= 1 693 | 694 | | lbNorth, ubNorth, clb >= cub -> interval (cub, in2) (clb, in1) 695 | | lbNorth, ubNorth -> -1 <=..<= 1 696 | | lbNorth -> interval (-1, Closed) $ case clb `compare` cub of 697 | LT -> (cub, in2) 698 | EQ -> (cub, in1 `max` in2) 699 | GT -> (clb, in1) 700 | | ubNorth -> (`interval` (1, Closed)) $ case clb `compare` cub of 701 | LT -> (clb, in1) 702 | EQ -> (clb, in1 `max` in2) 703 | GT -> (cub, in2) 704 | | clb > cub -> -1 <=..<= 1 705 | | otherwise -> interval (clb, in1) (cub, in2) 706 | where 707 | mod2pi x = let y = x / (2 * pi) in y - fromInteger (floor y) 708 | -- is lower bound in the northern half-plane [0,pi)? 709 | lbNorth = (mod2pi lb, in1) < (1 / 2, Closed) 710 | -- is upper bound in the northern half-plane [0,pi)? 711 | ubNorth = (mod2pi ub, in2) < (1 / 2, Closed) 712 | clb = Finite (cos lb) 713 | cub = Finite (cos ub) 714 | 715 | acos = mapAntiMonotonic acos . intersection (-1 <=..<= 1) 716 | 717 | sin a = cos (pi / 2 - a) 718 | asin = mapMonotonic asin . intersection (-1 <=..<= 1) 719 | 720 | tan a = case lowerBound' a of 721 | (NegInf, _) -> whole 722 | (PosInf, _) -> empty 723 | (Finite lb, in1) -> case upperBound' a of 724 | (NegInf, _) -> empty 725 | (PosInf, _) -> whole 726 | (Finite ub, in2) 727 | | ub - lb > pi -> whole 728 | -- the next case corresponds to (tan lb, +inf) + (-inf, tan ub) 729 | -- with tan lb == tan ub, but a convex hull is returned instead 730 | | ub - lb == pi && in1 == Open && in2 == Open && modpi lb /= 1/2 -> whole 731 | | ub - lb == pi -> whole 732 | | tan lb <= tan ub -> interval (Finite $ tan lb, in1) (Finite $ tan ub, in2) 733 | -- the next case corresponds to (tan lb, +inf) + (-inf, tan ub), 734 | -- but a convex hull is returned instead 735 | | otherwise -> whole 736 | where 737 | modpi x = let y = x / pi in y - fromInteger (floor y) 738 | 739 | atan = intersection (Finite (-pi / 2) <=..<= Finite (pi / 2)) . mapMonotonic atan 740 | 741 | sinh = mapMonotonic sinh 742 | asinh = mapMonotonic asinh 743 | 744 | cosh = mapMonotonic cosh . abs 745 | acosh = mapMonotonic acosh . intersection (1 <=..< PosInf) 746 | 747 | tanh = intersection (-1 <..< 1) . mapMonotonic tanh 748 | atanh a = interval (atanhB (lowerBound' b)) (atanhB (upperBound' b)) 749 | where 750 | b = intersection (-1 <..< 1) a 751 | 752 | positiveIntegralPowersOfNegativeValues 753 | :: RealFrac r => Interval r -> Interval r -> Interval r 754 | positiveIntegralPowersOfNegativeValues a b 755 | | null a || null b = empty 756 | | Just ub <- mub, lb > ub = empty 757 | | Just ub <- mub, lb == ub = a ^ lb 758 | -- cases below connects two intervals (a ^ k, 0) + (0, a ^ k')) 759 | -- into a single convex hull 760 | | lowerBound a >= -1 = hull (a ^ lb) (a ^ (lb + 1)) 761 | | Just ub <- mub = hull (a ^ ub) (a ^ (ub - 1)) 762 | | Nothing <- mub = whole 763 | where 764 | -- Similar to Data.IntegerInterval.fromIntervalUnder 765 | lb :: Integer 766 | lb = case lowerBound' b of 767 | (Finite x, Open) 768 | | fromInteger (ceiling x) == x 769 | -> ceiling x + 1 770 | (Finite x, _) -> ceiling x 771 | _ -> 0 -- PosInf is not expected, because b is not null 772 | mub :: Maybe Integer 773 | mub = case upperBound' b of 774 | (Finite x, Open) 775 | | fromInteger (floor x) == x 776 | -> Just $ floor x - 1 777 | (Finite x, _) -> Just $ floor x 778 | _ -> Nothing -- NegInf is not expected, because b is not null 779 | 780 | cmpUB, cmpLB :: Ord r => (Extended r, Boundary) -> (Extended r, Boundary) -> Ordering 781 | cmpUB (x1,in1) (x2,in2) = compare x1 x2 `mappend` compare in1 in2 782 | cmpLB (x1,in1) (x2,in2) = compare x1 x2 `mappend` compare in2 in1 783 | 784 | scaleInf' :: (Num r, Ord r) => r -> (Extended r, Boundary) -> (Extended r, Boundary) 785 | scaleInf' a (x1, in1) = (scaleEndPoint a x1, in1) 786 | 787 | scaleEndPoint :: (Num r, Ord r) => r -> Extended r -> Extended r 788 | scaleEndPoint a e = 789 | case a `compare` 0 of 790 | EQ -> 0 791 | GT -> 792 | case e of 793 | NegInf -> NegInf 794 | Finite b -> Finite (a*b) 795 | PosInf -> PosInf 796 | LT -> 797 | case e of 798 | NegInf -> PosInf 799 | Finite b -> Finite (a*b) 800 | PosInf -> NegInf 801 | 802 | mulInf' :: (Num r, Ord r) => (Extended r, Boundary) -> (Extended r, Boundary) -> (Extended r, Boundary) 803 | mulInf' (0, Closed) _ = (0, Closed) 804 | mulInf' _ (0, Closed) = (0, Closed) 805 | mulInf' (x1,in1) (x2,in2) = (x1*x2, in1 `min` in2) 806 | 807 | recipLB :: (Fractional r, Ord r) => (Extended r, Boundary) -> (Extended r, Boundary) 808 | recipLB (0, _) = (PosInf, Open) 809 | recipLB (x1, in1) = (recip x1, in1) 810 | 811 | recipUB :: (Fractional r, Ord r) => (Extended r, Boundary) -> (Extended r, Boundary) 812 | recipUB (0, _) = (NegInf, Open) 813 | recipUB (x1, in1) = (recip x1, in1) 814 | 815 | logB :: (Floating r, Ord r) => (Extended r, Boundary) -> (Extended r, Boundary) 816 | logB (NegInf, in1) = (Finite $ log (log 0), in1) 817 | logB (Finite 0, _) = (NegInf, Open) 818 | logB (Finite x1, in1) = (Finite $ log x1, in1) 819 | logB (PosInf, in1) = (PosInf, in1) 820 | 821 | atanhB :: (Floating r, Ord r) => (Extended r, Boundary) -> (Extended r, Boundary) 822 | atanhB (NegInf, in1) = (Finite $ atanh (-1/0), in1) 823 | atanhB (Finite (-1), _) = (NegInf, Open) 824 | atanhB (Finite 1, _) = (PosInf, Open) 825 | atanhB (Finite x1, in1) = (Finite $ atanh x1, in1) 826 | atanhB (PosInf, in1) = (Finite $ atanh (1/0), in1) 827 | 828 | -- | Computes how two intervals are related according to the @`Data.IntervalRelation.Relation`@ classification 829 | relate :: Ord r => Interval r -> Interval r -> Relation 830 | relate i1 i2 = 831 | case (i1 `isSubsetOf` i2, i2 `isSubsetOf` i1) of 832 | -- 'i1' ad 'i2' are equal 833 | (True , True ) -> Equal 834 | -- 'i1' is strictly contained in `i2` 835 | (True , False) | compareBound (lowerBound' i1) (lowerBound' i2) == EQ -> Starts 836 | | compareBound (upperBound' i1) (upperBound' i2) == EQ -> Finishes 837 | | otherwise -> During 838 | -- 'i2' is strictly contained in `i1` 839 | (False, True ) | compareBound (lowerBound' i1) (lowerBound' i2) == EQ -> StartedBy 840 | | compareBound (upperBound' i1) (upperBound' i2) == EQ -> FinishedBy 841 | | otherwise -> Contains 842 | -- neither `i1` nor `i2` is contained in the other 843 | (False, False) -> case ( null (i1 `intersection` i2) 844 | , compareBound (upperBound' i1) (upperBound' i2) <= EQ 845 | , i1 `isConnected` i2 846 | ) of 847 | (True , True , True ) -> JustBefore 848 | (True , True , False) -> Before 849 | (True , False, True ) -> JustAfter 850 | (True , False, False) -> After 851 | (False, True , _ ) -> Overlaps 852 | (False, False, _ ) -> OverlappedBy 853 | where 854 | compareBound :: Ord r => (Extended r, Boundary) -> (Extended r, Boundary) -> Ordering 855 | compareBound (PosInf, _) (PosInf, _) = EQ 856 | compareBound (PosInf, _) _ = GT 857 | compareBound (NegInf, _) (NegInf, _) = EQ 858 | compareBound (NegInf, _) _ = LT 859 | compareBound a b = compare a b 860 | -------------------------------------------------------------------------------- /test/TestIntegerInterval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, TemplateHaskell, ScopedTypeVariables #-} 2 | module TestIntegerInterval (integerIntervalTestGroup) where 3 | 4 | #ifdef MIN_VERSION_lattices 5 | import qualified Algebra.Lattice as L 6 | #endif 7 | import Control.DeepSeq 8 | import Control.Monad 9 | import Data.Generics.Schemes 10 | import Data.Hashable 11 | import Data.Maybe 12 | import Data.Ratio 13 | import Data.Typeable (cast) 14 | 15 | import Test.Tasty 16 | import Test.Tasty.QuickCheck 17 | import Test.Tasty.HUnit 18 | import Test.Tasty.TH 19 | 20 | import Data.IntegerInterval 21 | ( IntegerInterval, Extended (..), (<=..<=), (<=..<), (<..<=), (<..<) 22 | , (=!), (>!), (/=!) 23 | , (=?), (>?), (/=?) 24 | , (=??), (>??), (/=??) 25 | ) 26 | import qualified Data.IntegerInterval as IntegerInterval 27 | import Data.Interval (Interval) 28 | import qualified Data.Interval as Interval 29 | import Data.IntervalRelation 30 | 31 | {-------------------------------------------------------------------- 32 | empty 33 | --------------------------------------------------------------------} 34 | 35 | prop_empty_is_bottom = 36 | forAll integerIntervals $ \a -> 37 | IntegerInterval.isSubsetOf IntegerInterval.empty a 38 | 39 | prop_null_empty = 40 | forAll integerIntervals $ \a -> 41 | IntegerInterval.null a == (a == IntegerInterval.empty) 42 | 43 | case_null_empty = 44 | IntegerInterval.null (IntegerInterval.empty :: IntegerInterval) @?= True 45 | 46 | {-------------------------------------------------------------------- 47 | whole 48 | --------------------------------------------------------------------} 49 | 50 | prop_whole_is_top = 51 | forAll integerIntervals $ \a -> 52 | IntegerInterval.isSubsetOf a IntegerInterval.whole 53 | 54 | case_nonnull_top = 55 | IntegerInterval.null (IntegerInterval.whole :: IntegerInterval) @?= False 56 | 57 | {-------------------------------------------------------------------- 58 | singleton 59 | --------------------------------------------------------------------} 60 | 61 | -- prop_singleton_isSingleton = 62 | -- forAll arbitrary $ \x -> 63 | -- IntegerInterval.isSingleton (IntegerInterval.singleton x) 64 | 65 | prop_singleton_member = 66 | forAll arbitrary $ \r -> 67 | IntegerInterval.member (r::Integer) (IntegerInterval.singleton r) 68 | 69 | prop_singleton_member_intersection = 70 | forAll integerIntervals $ \a -> 71 | forAll arbitrary $ \r -> 72 | let b = IntegerInterval.singleton r 73 | in IntegerInterval.member (r::Integer) a 74 | ==> IntegerInterval.intersection a b == b 75 | 76 | prop_singleton_nonnull = 77 | forAll arbitrary $ \r1 -> 78 | not $ IntegerInterval.null $ IntegerInterval.singleton (r1::Integer) 79 | 80 | prop_distinct_singleton_intersection = 81 | forAll arbitrary $ \r1 -> 82 | forAll arbitrary $ \r2 -> 83 | (r1::Integer) /= r2 ==> 84 | IntegerInterval.intersection (IntegerInterval.singleton r1) (IntegerInterval.singleton r2) 85 | == IntegerInterval.empty 86 | 87 | {-------------------------------------------------------------------- 88 | Intersection 89 | --------------------------------------------------------------------} 90 | 91 | prop_intersection_comm = 92 | forAll integerIntervals $ \a -> 93 | forAll integerIntervals $ \b -> 94 | IntegerInterval.intersection a b == IntegerInterval.intersection b a 95 | 96 | prop_intersection_assoc = 97 | forAll integerIntervals $ \a -> 98 | forAll integerIntervals $ \b -> 99 | forAll integerIntervals $ \c -> 100 | IntegerInterval.intersection a (IntegerInterval.intersection b c) == 101 | IntegerInterval.intersection (IntegerInterval.intersection a b) c 102 | 103 | prop_intersection_unitL = 104 | forAll integerIntervals $ \a -> 105 | IntegerInterval.intersection IntegerInterval.whole a == a 106 | 107 | prop_intersection_unitR = 108 | forAll integerIntervals $ \a -> 109 | IntegerInterval.intersection a IntegerInterval.whole == a 110 | 111 | prop_intersection_empty = 112 | forAll integerIntervals $ \a -> 113 | IntegerInterval.intersection a IntegerInterval.empty == IntegerInterval.empty 114 | 115 | prop_intersection_isSubsetOf = 116 | forAll integerIntervals $ \a -> 117 | forAll integerIntervals $ \b -> 118 | IntegerInterval.isSubsetOf (IntegerInterval.intersection a b) a 119 | 120 | prop_intersection_isSubsetOf_equiv = 121 | forAll integerIntervals $ \a -> 122 | forAll integerIntervals $ \b -> 123 | (IntegerInterval.intersection a b == a) 124 | == IntegerInterval.isSubsetOf a b 125 | 126 | case_intersections_empty_list = IntegerInterval.intersections [] @?= (IntegerInterval.whole :: IntegerInterval) 127 | 128 | prop_intersections_singleton_list = 129 | forAll integerIntervals $ \a -> IntegerInterval.intersections [a] == a 130 | 131 | prop_intersections_two_elems = 132 | forAll integerIntervals $ \a -> 133 | forAll integerIntervals $ \b -> 134 | IntegerInterval.intersections [a,b] == IntegerInterval.intersection a b 135 | 136 | {-------------------------------------------------------------------- 137 | Hull 138 | --------------------------------------------------------------------} 139 | 140 | prop_hull_comm = 141 | forAll integerIntervals $ \a -> 142 | forAll integerIntervals $ \b -> 143 | IntegerInterval.hull a b == IntegerInterval.hull b a 144 | 145 | prop_hull_assoc = 146 | forAll integerIntervals $ \a -> 147 | forAll integerIntervals $ \b -> 148 | forAll integerIntervals $ \c -> 149 | IntegerInterval.hull a (IntegerInterval.hull b c) == 150 | IntegerInterval.hull (IntegerInterval.hull a b) c 151 | 152 | prop_hull_unitL = 153 | forAll integerIntervals $ \a -> 154 | IntegerInterval.hull IntegerInterval.empty a == a 155 | 156 | prop_hull_unitR = 157 | forAll integerIntervals $ \a -> 158 | IntegerInterval.hull a IntegerInterval.empty == a 159 | 160 | prop_hull_whole = 161 | forAll integerIntervals $ \a -> 162 | IntegerInterval.hull a IntegerInterval.whole == IntegerInterval.whole 163 | 164 | prop_hull_isSubsetOf = 165 | forAll integerIntervals $ \a -> 166 | forAll integerIntervals $ \b -> 167 | IntegerInterval.isSubsetOf a (IntegerInterval.hull a b) 168 | 169 | prop_hull_isSubsetOf_equiv = 170 | forAll integerIntervals $ \a -> 171 | forAll integerIntervals $ \b -> 172 | (IntegerInterval.hull a b == b) 173 | == IntegerInterval.isSubsetOf a b 174 | 175 | case_hulls_empty_list = IntegerInterval.hulls [] @?= (IntegerInterval.empty :: IntegerInterval) 176 | 177 | prop_hulls_singleton_list = 178 | forAll integerIntervals $ \a -> IntegerInterval.hulls [a] == a 179 | 180 | prop_hulls_two_elems = 181 | forAll integerIntervals $ \a -> 182 | forAll integerIntervals $ \b -> 183 | IntegerInterval.hulls [a,b] == IntegerInterval.hull a b 184 | 185 | {-------------------------------------------------------------------- 186 | member 187 | --------------------------------------------------------------------} 188 | 189 | prop_member_isSubsetOf = 190 | forAll arbitrary $ \r -> 191 | forAll integerIntervals $ \a -> 192 | IntegerInterval.member r a == IntegerInterval.isSubsetOf (IntegerInterval.singleton r) a 193 | 194 | prop_notMember_empty = 195 | forAll arbitrary $ \r -> 196 | r `IntegerInterval.notMember` IntegerInterval.empty 197 | 198 | {-------------------------------------------------------------------- 199 | isSubsetOf, isProperSubsetOf 200 | --------------------------------------------------------------------} 201 | 202 | prop_isSubsetOf_refl = 203 | forAll integerIntervals $ \a -> 204 | IntegerInterval.isSubsetOf a a 205 | 206 | prop_isSubsetOf_trans = 207 | forAll integerIntervals $ \a -> 208 | forAll integerIntervals $ \b -> 209 | forAll integerIntervals $ \c -> 210 | IntegerInterval.isSubsetOf a b && IntegerInterval.isSubsetOf b c 211 | ==> IntegerInterval.isSubsetOf a c 212 | 213 | -- prop_isSubsetOf_antisym = 214 | -- forAll integerIntervals $ \a -> 215 | -- forAll integerIntervals $ \b -> 216 | -- IntegerInterval.isSubsetOf a b && IntegerInterval.isSubsetOf b a 217 | -- ==> a == b 218 | 219 | prop_isProperSubsetOf_not_refl = 220 | forAll integerIntervals $ \a -> 221 | not (a `IntegerInterval.isProperSubsetOf` a) 222 | 223 | -- too slow 224 | -- prop_isProperSubsetOf_trans = 225 | -- forAll integerIntervals $ \a -> 226 | -- forAll (liftM (IntegerInterval.intersection a) integerIntervals) $ \b -> 227 | -- forAll (liftM (IntegerInterval.intersection b) integerIntervals) $ \c -> 228 | -- IntegerInterval.isProperSubsetOf c b && IntegerInterval.isProperSubsetOf b a 229 | -- ==> IntegerInterval.isProperSubsetOf c a 230 | 231 | case_isProperSubsetOf = 232 | (0 <=..<= 1) `IntegerInterval.isProperSubsetOf` (0 <=..<= 2) @?= True 233 | 234 | {-- ----------------------------------------------------------------- 235 | isConnected 236 | ----------------------------------------------------------------- --} 237 | 238 | prop_isConnected_reflexive = 239 | forAll integerIntervals $ \a -> 240 | a `IntegerInterval.isConnected` a 241 | 242 | prop_isConnected_symmetric = 243 | forAll integerIntervals $ \a -> 244 | forAll integerIntervals $ \b -> 245 | (a `IntegerInterval.isConnected` b) == (b `IntegerInterval.isConnected` a) 246 | 247 | {-------------------------------------------------------------------- 248 | simplestIntegerWithin 249 | --------------------------------------------------------------------} 250 | 251 | prop_simplestIntegerWithin_member = 252 | forAll integerIntervals $ \a -> 253 | case IntegerInterval.simplestIntegerWithin a of 254 | Nothing -> True 255 | Just x -> x `IntegerInterval.member` a 256 | 257 | prop_simplestIntegerWithin_singleton = 258 | forAll arbitrary $ \x -> 259 | IntegerInterval.simplestIntegerWithin (IntegerInterval.singleton x) == Just x 260 | 261 | case_simplestIntegerWithin_empty = 262 | IntegerInterval.simplestIntegerWithin IntegerInterval.empty @?= Nothing 263 | 264 | {-------------------------------------------------------------------- 265 | width 266 | --------------------------------------------------------------------} 267 | 268 | case_width_null = 269 | IntegerInterval.width IntegerInterval.empty @?= 0 270 | 271 | case_width_positive = 272 | IntegerInterval.width (0 <=..< 10) @?= 9 273 | 274 | prop_width_singleton = 275 | forAll arbitrary $ \x -> 276 | IntegerInterval.width (IntegerInterval.singleton x) == 0 277 | 278 | {-------------------------------------------------------------------- 279 | memberCount 280 | --------------------------------------------------------------------} 281 | 282 | case_memberCount_null = 283 | IntegerInterval.memberCount IntegerInterval.empty @?= Just 0 284 | 285 | case_memberCount_positive = 286 | IntegerInterval.memberCount (0 <=..< 10) @?= Just 10 287 | 288 | prop_memberCount_singleton = 289 | forAll arbitrary $ \x -> 290 | IntegerInterval.memberCount (IntegerInterval.singleton x) == Just 1 291 | 292 | {-------------------------------------------------------------------- 293 | map 294 | --------------------------------------------------------------------} 295 | 296 | case_mapMonotonic = 297 | IntegerInterval.mapMonotonic (+1) (0 <=..< 10) @?= ((1 <=..<11) :: IntegerInterval) 298 | 299 | {-------------------------------------------------------------------- 300 | pickup 301 | --------------------------------------------------------------------} 302 | 303 | prop_pickup_member_null = 304 | forAll integerIntervals $ \a -> 305 | case IntegerInterval.pickup a of 306 | Nothing -> IntegerInterval.null a 307 | Just x -> IntegerInterval.member x a 308 | 309 | case_pickup_empty = 310 | IntegerInterval.pickup (IntegerInterval.empty :: IntegerInterval) @?= Nothing 311 | 312 | case_pickup_whole = 313 | isJust (IntegerInterval.pickup (IntegerInterval.whole :: IntegerInterval)) @?= True 314 | 315 | prop_pickup_singleton = 316 | forAll arbitrary $ \x -> 317 | IntegerInterval.pickup (IntegerInterval.singleton x) == Just x 318 | 319 | {-------------------------------------------------------------------- 320 | relate 321 | --------------------------------------------------------------------} 322 | 323 | prop_relate_equals = 324 | forAll integerIntervals $ \a -> 325 | IntegerInterval.relate a a == Equal 326 | 327 | prop_relate_empty_contained_in_non_empty = 328 | forAll (integerIntervals `suchThat` (not . IntegerInterval.null)) $ \a -> 329 | IntegerInterval.relate a IntegerInterval.empty == Contains 330 | 331 | prop_relate_detects_before = 332 | forAll (nonEmptyIntegerIntervalPairs (\_ ub1 lb2 _ -> ub1 < lb2 - 1)) $ \(a, b) -> 333 | IntegerInterval.relate a b == Before 334 | 335 | prop_relate_detects_just_before = 336 | forAll (arbitrary `suchThat` \(b1, b2, i) -> b1 <= Finite i && Finite (i + 1) <= b2) $ 337 | \(b1, b2, i) -> 338 | IntegerInterval.relate (b1 <=..<= Finite i) (Finite (i + 1) <=..<= b2) == JustBefore 339 | 340 | prop_relate_two_intervals_overlap = 341 | forAll (nonEmptyIntegerIntervalPairs (\lb1 ub1 lb2 ub2 -> lb1 < lb2 && lb2 < ub1 && ub1 < ub2)) $ \(a, b) -> 342 | IntegerInterval.relate a b == Overlaps 343 | 344 | prop_relate_interval_starts_another = 345 | forAll (nonEmptyIntegerIntervalPairs (\lb1 ub1 lb2 ub2 -> lb1 == lb2 && ub1 < ub2)) $ \(a, b) -> 346 | IntegerInterval.relate a b == Starts 347 | 348 | prop_relate_interval_finishes_another = 349 | forAll (nonEmptyIntegerIntervalPairs (\lb1 ub1 lb2 ub2 -> lb1 > lb2 && ub1 == ub2)) $ \(a, b) -> 350 | IntegerInterval.relate a b == Finishes 351 | 352 | prop_relate_interval_contains_another = 353 | forAll (nonEmptyIntegerIntervalPairs (\lb1 ub1 lb2 ub2 -> lb1 < lb2 && ub1 > ub2)) $ \(a, b) -> 354 | IntegerInterval.relate a b == Contains 355 | 356 | {-------------------------------------------------------------------- 357 | Comparison 358 | --------------------------------------------------------------------} 359 | 360 | case_lt_all_1 = (a not (IntegerInterval.null a) ==> not (a not (IntegerInterval.null a) ==> a <=? a 431 | 432 | prop_ne_all_not_refl = 433 | forAll integerIntervals $ \a -> not (IntegerInterval.null a) ==> not (a /=! a) 434 | 435 | prop_lt_all_singleton = 436 | forAll arbitrary $ \a -> 437 | forAll arbitrary $ \b -> 438 | (a::Integer) < b ==> IntegerInterval.singleton a 442 | not $ IntegerInterval.singleton (a::Integer) 446 | forAll arbitrary $ \b -> 447 | (a::Integer) <= b ==> IntegerInterval.singleton a <=! IntegerInterval.singleton b 448 | 449 | prop_le_all_singleton_2 = 450 | forAll arbitrary $ \a -> 451 | IntegerInterval.singleton (a::Integer) <=! IntegerInterval.singleton a 452 | 453 | prop_eq_all_singleton = 454 | forAll arbitrary $ \a -> 455 | IntegerInterval.singleton (a::Integer) ==! IntegerInterval.singleton a 456 | 457 | prop_ne_all_singleton = 458 | forAll arbitrary $ \a -> 459 | forAll arbitrary $ \b -> 460 | (a::Integer) /= b ==> IntegerInterval.singleton a /=! IntegerInterval.singleton b 461 | 462 | prop_ne_all_singleton_2 = 463 | forAll arbitrary $ \a -> 464 | not $ IntegerInterval.singleton (a::Integer) /=! IntegerInterval.singleton a 465 | 466 | prop_lt_some_singleton = 467 | forAll arbitrary $ \a -> 468 | forAll arbitrary $ \b -> 469 | (a::Integer) < b ==> IntegerInterval.singleton a 473 | not $ IntegerInterval.singleton (a::Integer) 477 | forAll arbitrary $ \b -> 478 | (a::Integer) <= b ==> IntegerInterval.singleton a <=? IntegerInterval.singleton b 479 | 480 | prop_le_some_singleton_2 = 481 | forAll arbitrary $ \a -> 482 | IntegerInterval.singleton (a::Integer) <=? IntegerInterval.singleton a 483 | 484 | prop_eq_some_singleton = 485 | forAll arbitrary $ \a -> 486 | IntegerInterval.singleton (a::Integer) ==? IntegerInterval.singleton a 487 | 488 | prop_lt_all_empty = 489 | forAll integerIntervals $ \a -> a IntegerInterval.empty a <=! IntegerInterval.empty 496 | 497 | prop_le_all_empty_2 = 498 | forAll integerIntervals $ \a -> IntegerInterval.empty <=! a 499 | 500 | prop_eq_all_empty = 501 | forAll integerIntervals $ \a -> a ==! IntegerInterval.empty 502 | 503 | prop_ne_all_empty = 504 | forAll integerIntervals $ \a -> a /=! IntegerInterval.empty 505 | 506 | prop_lt_some_empty = 507 | forAll integerIntervals $ \a -> not (a not (IntegerInterval.empty not (a <=? IntegerInterval.empty) 514 | 515 | prop_le_some_empty_2 = 516 | forAll integerIntervals $ \a -> not (IntegerInterval.empty <=? a) 517 | 518 | prop_eq_some_empty = 519 | forAll integerIntervals $ \a -> not (a ==? IntegerInterval.empty) 520 | 521 | prop_intersect_le_some = 522 | forAll integerIntervals $ \a -> 523 | forAll integerIntervals $ \b -> 524 | not (IntegerInterval.null (IntegerInterval.intersection a b)) 525 | ==> a <=? b 526 | 527 | prop_intersect_eq_some = 528 | forAll integerIntervals $ \a -> 529 | forAll integerIntervals $ \b -> 530 | not (IntegerInterval.null (IntegerInterval.intersection a b)) 531 | ==> a ==? b 532 | 533 | prop_le_some_witness = 534 | forAll integerIntervals $ \a -> 535 | forAll integerIntervals $ \b -> 536 | case a <=?? b of 537 | Nothing -> 538 | forAll arbitrary $ \(x,y) -> 539 | not (IntegerInterval.member x a && IntegerInterval.member y b && x <= y) 540 | Just (x,y) -> 541 | IntegerInterval.member x a .&&. IntegerInterval.member y b .&&. x <= y 542 | 543 | prop_lt_some_witness = 544 | forAll integerIntervals $ \a -> 545 | forAll integerIntervals $ \b -> 546 | case a 548 | forAll arbitrary $ \(x,y) -> 549 | not (IntegerInterval.member x a && IntegerInterval.member y b && x < y) 550 | Just (x,y) -> 551 | IntegerInterval.member x a .&&. IntegerInterval.member y b .&&. x < y 552 | 553 | prop_eq_some_witness = 554 | forAll integerIntervals $ \a -> 555 | forAll integerIntervals $ \b -> 556 | case a ==?? b of 557 | Nothing -> 558 | forAll arbitrary $ \x -> 559 | not (IntegerInterval.member x a && IntegerInterval.member x b) 560 | Just (x,y) -> 561 | IntegerInterval.member x a .&&. IntegerInterval.member y b .&&. x == y 562 | 563 | prop_ne_some_witness = 564 | forAll integerIntervals $ \a -> 565 | forAll integerIntervals $ \b -> 566 | case a /=?? b of 567 | Nothing -> 568 | forAll arbitrary $ \x -> 569 | forAll arbitrary $ \y -> 570 | not (IntegerInterval.member x a && IntegerInterval.member y b && x /= y) 571 | Just (x,y) -> 572 | IntegerInterval.member x a .&&. IntegerInterval.member y b .&&. x /= y 573 | 574 | case_ne_some_witness_test1 = do 575 | let i1 = 0 576 | i2 = 0 <=..<= 1 577 | case i1 /=?? i2 of 578 | Nothing -> assertFailure "should not be Nothing" 579 | Just (a,b) -> do 580 | unless (a `IntegerInterval.member` i1) $ assertFailure (show a ++ "is not a member of " ++ show i1) 581 | unless (b `IntegerInterval.member` i2) $ assertFailure (show b ++ "is not a member of " ++ show i2) 582 | unless (a /= b) $ assertFailure (show a ++ " /= " ++ show b ++ " failed") 583 | 584 | case_ne_some_witness_test2 = do 585 | let i1 = 0 <=..<= 1 586 | i2 = 1 587 | case i1 /=?? i2 of 588 | Nothing -> assertFailure "should not be Nothing" 589 | Just (a,b) -> do 590 | unless (a `IntegerInterval.member` i1) $ assertFailure (show a ++ "is not a member of " ++ show i1) 591 | unless (b `IntegerInterval.member` i2) $ assertFailure (show b ++ "is not a member of " ++ show i2) 592 | unless (a /= b) $ assertFailure (show a ++ " /= " ++ show b ++ " failed") 593 | 594 | prop_le_some_witness_forget = 595 | forAll integerIntervals $ \a -> 596 | forAll integerIntervals $ \b -> 597 | isJust (a <=?? b) == (a <=? b) 598 | 599 | prop_lt_some_witness_forget = 600 | forAll integerIntervals $ \a -> 601 | forAll integerIntervals $ \b -> 602 | isJust (a 606 | forAll integerIntervals $ \b -> 607 | isJust (a ==?? b) == (a ==? b) 608 | 609 | prop_ne_some_witness_forget = 610 | forAll integerIntervals $ \a -> 611 | forAll integerIntervals $ \b -> 612 | isJust (a /=?? b) == (a /=? b) 613 | 614 | {-------------------------------------------------------------------- 615 | Num 616 | --------------------------------------------------------------------} 617 | 618 | prop_scale_empty = 619 | forAll arbitrary $ \r -> 620 | IntegerInterval.singleton (r::Integer) * IntegerInterval.empty == IntegerInterval.empty 621 | 622 | prop_add_comm = 623 | forAll integerIntervals $ \a -> 624 | forAll integerIntervals $ \b -> 625 | a + b == b + a 626 | 627 | prop_add_assoc = 628 | forAll integerIntervals $ \a -> 629 | forAll integerIntervals $ \b -> 630 | forAll integerIntervals $ \c -> 631 | a + (b + c) == (a + b) + c 632 | 633 | prop_add_unitL = 634 | forAll integerIntervals $ \a -> 635 | IntegerInterval.singleton 0 + a == a 636 | 637 | prop_add_unitR = 638 | forAll integerIntervals $ \a -> 639 | a + IntegerInterval.singleton 0 == a 640 | 641 | prop_add_member = 642 | forAll integerIntervals $ \a -> 643 | forAll integerIntervals $ \b -> 644 | and [ (x+y) `IntegerInterval.member` (a+b) 645 | | x <- maybeToList $ IntegerInterval.pickup a 646 | , y <- maybeToList $ IntegerInterval.pickup b 647 | ] 648 | 649 | prop_mult_comm = 650 | forAll integerIntervals $ \a -> 651 | forAll integerIntervals $ \b -> 652 | a * b == b * a 653 | 654 | prop_mult_assoc = 655 | forAll integerIntervals $ \a -> 656 | forAll integerIntervals $ \b -> 657 | forAll integerIntervals $ \c -> 658 | a * (b * c) == (a * b) * c 659 | 660 | prop_mult_unitL = 661 | forAll integerIntervals $ \a -> 662 | IntegerInterval.singleton 1 * a == a 663 | 664 | prop_mult_unitR = 665 | forAll integerIntervals $ \a -> 666 | a * IntegerInterval.singleton 1 == a 667 | 668 | prop_mult_dist = 669 | forAll integerIntervals $ \a -> 670 | forAll integerIntervals $ \b -> 671 | forAll integerIntervals $ \c -> 672 | (a * (b + c)) `IntegerInterval.isSubsetOf` (a * b + a * c) 673 | 674 | prop_mult_empty = 675 | forAll integerIntervals $ \a -> 676 | IntegerInterval.empty * a == IntegerInterval.empty 677 | 678 | prop_mult_zero = 679 | forAll integerIntervals $ \a -> 680 | not (IntegerInterval.null a) ==> IntegerInterval.singleton 0 * a == IntegerInterval.singleton 0 681 | 682 | prop_mult_member = 683 | forAll integerIntervals $ \a -> 684 | forAll integerIntervals $ \b -> 685 | and [ (x*y) `IntegerInterval.member` (a*b) 686 | | x <- maybeToList $ IntegerInterval.pickup a 687 | , y <- maybeToList $ IntegerInterval.pickup b 688 | ] 689 | 690 | case_mult_test1 = ival1 * ival2 @?= ival3 691 | where 692 | ival1 :: IntegerInterval 693 | ival1 = 1 <=..<= 2 694 | ival2 = 1 <=..<= 2 695 | ival3 = 1 <=..<= 4 696 | 697 | case_mult_test2 = ival1 * ival2 @?= ival3 698 | where 699 | ival1 :: IntegerInterval 700 | ival1 = 1 <=..<= 2 701 | ival2 = 1 <..< 2 702 | ival3 = IntegerInterval.empty 703 | 704 | case_mult_test3 = ival1 * ival2 @?= ival3 705 | where 706 | ival1 :: IntegerInterval 707 | ival1 = 1 <..< 2 708 | ival2 = 1 <..< 2 709 | ival3 = IntegerInterval.empty 710 | 711 | case_mult_test4 = ival1 * ival2 @?= ival3 712 | where 713 | ival1 :: IntegerInterval 714 | ival1 = 2 <..< PosInf 715 | ival2 = 3 <..< PosInf 716 | ival3 = 11 <..< PosInf 717 | 718 | case_mult_test5 = ival1 * ival2 @?= ival3 719 | where 720 | ival1 :: IntegerInterval 721 | ival1 = NegInf <..< (-3) 722 | ival2 = NegInf <..< (-2) 723 | ival3 = 11 <..< PosInf 724 | 725 | case_mult_test6 = ival1 * ival2 @?= ival3 726 | where 727 | ival1 :: IntegerInterval 728 | ival1 = 2 <..< PosInf 729 | ival2 = NegInf <..< (-2) 730 | ival3 = NegInf <..< (-8) 731 | 732 | prop_abs_signum = 733 | forAll integerIntervals $ \a -> 734 | abs (signum a) `IntegerInterval.isSubsetOf` (0 <=..<= 1) 735 | 736 | prop_negate_negate = 737 | forAll integerIntervals $ \a -> 738 | negate (negate a) == a 739 | 740 | {-------------------------------------------------------------------- 741 | Lattice 742 | --------------------------------------------------------------------} 743 | 744 | #ifdef MIN_VERSION_lattices 745 | 746 | prop_Lattice_Leq_welldefined = 747 | forAll integerIntervals $ \a b -> 748 | a `L.meetLeq` b == a `L.joinLeq` b 749 | 750 | prop_top = 751 | forAll integerIntervals $ \a -> 752 | a `L.joinLeq` L.top 753 | 754 | prop_bottom = 755 | forAll integerIntervals $ \a -> 756 | L.bottom `L.joinLeq` a 757 | 758 | #else 759 | 760 | prop_Lattice_Leq_welldefined = True 761 | prop_top = True 762 | prop_bottom = True 763 | 764 | #endif 765 | 766 | {-------------------------------------------------------------------- 767 | Read 768 | --------------------------------------------------------------------} 769 | 770 | prop_show_read_invariance = 771 | forAll integerIntervals $ \i -> do 772 | i == read (show i) 773 | 774 | case_read_old = 775 | read "interval (Finite 0, Closed) (PosInf, Open)" @?= IntegerInterval.interval (Finite 0, Interval.Closed) (PosInf, Interval.Open) 776 | 777 | {-------------------------------------------------------------------- 778 | NFData 779 | --------------------------------------------------------------------} 780 | 781 | prop_rnf = 782 | forAll integerIntervals $ \a -> 783 | rnf a == () 784 | 785 | {-------------------------------------------------------------------- 786 | Hashable 787 | --------------------------------------------------------------------} 788 | 789 | prop_hash = 790 | forAll integerIntervals $ \i -> 791 | hash i `seq` True 792 | 793 | {- ------------------------------------------------------------------ 794 | Data 795 | ------------------------------------------------------------------ -} 796 | 797 | case_Data = everywhere f i @?= (1 <=..<= 2 :: IntegerInterval) 798 | where 799 | i :: IntegerInterval 800 | i = 0 <=..<= 1 801 | f x 802 | | Just (y :: Integer) <- cast x = fromJust $ cast (y + 1) 803 | | otherwise = x 804 | 805 | {-------------------------------------------------------------------- 806 | Conversion between Interval and IntegerInterval 807 | --------------------------------------------------------------------} 808 | 809 | prop_fromInterval_toInterval = 810 | forAll integerIntervals $ \i -> 811 | IntegerInterval.fromInterval (IntegerInterval.toInterval i) == i 812 | 813 | prop_fromIntervalOver_toInterval = 814 | forAll integerIntervals $ \i -> 815 | IntegerInterval.fromIntervalOver (IntegerInterval.toInterval i :: Interval Rational) == i 816 | 817 | prop_fromIntervalUnder_toInterval = 818 | forAll integerIntervals $ \i -> 819 | IntegerInterval.fromIntervalUnder (IntegerInterval.toInterval i :: Interval Rational) == i 820 | 821 | prop_fromIntervalOver_toInterval_adjoint = 822 | forAll intervals $ \a -> 823 | forAll integerIntervals $ \b -> 824 | IntegerInterval.fromIntervalOver a `IntegerInterval.isSubsetOf` b 825 | == a `Interval.isSubsetOf` IntegerInterval.toInterval b 826 | 827 | prop_toInterval_fromIntervalUnder_adjoint = 828 | forAll integerIntervals $ \a -> 829 | forAll intervals $ \b -> 830 | IntegerInterval.toInterval a `Interval.isSubsetOf` b 831 | == a `IntegerInterval.isSubsetOf` IntegerInterval.fromIntervalUnder b 832 | 833 | prop_toInterval_fromInterval = 834 | forAll arbitrary $ \(i :: Interval Integer) -> 835 | IntegerInterval.toInterval (IntegerInterval.fromInterval i) `Interval.isSubsetOf` i 836 | 837 | case_fromIntervalUnder_test1 = 838 | IntegerInterval.fromIntervalUnder ((0.5::Extended Rational) Interval.<=..<= 1.5) @?= IntegerInterval.singleton 1 839 | 840 | case_fromIntervalUnder_test2 = 841 | IntegerInterval.fromIntervalUnder ((0::Extended Rational) Interval.<..< 2) @?= IntegerInterval.singleton 1 842 | 843 | {-------------------------------------------------------------------- 844 | Generators 845 | --------------------------------------------------------------------} 846 | 847 | instance Arbitrary Interval.Boundary where 848 | arbitrary = arbitraryBoundedEnum 849 | 850 | instance Arbitrary r => Arbitrary (Extended r) where 851 | arbitrary = 852 | oneof 853 | [ return NegInf 854 | , return PosInf 855 | , liftM Finite arbitrary 856 | ] 857 | 858 | instance (Arbitrary r, Ord r) => Arbitrary (Interval.Interval r) where 859 | arbitrary = do 860 | lb <- arbitrary 861 | ub <- arbitrary 862 | return $ Interval.interval lb ub 863 | 864 | instance Arbitrary IntegerInterval where 865 | arbitrary = do 866 | lb <- arbitrary 867 | ub <- arbitrary 868 | return $ IntegerInterval.interval lb ub 869 | 870 | integerIntervals :: Gen IntegerInterval 871 | integerIntervals = arbitrary 872 | 873 | nonEmptyIntegerIntervalPairs 874 | :: ( Extended Integer 875 | -> Extended Integer 876 | -> Extended Integer 877 | -> Extended Integer 878 | -> Bool) 879 | -> Gen (IntegerInterval, IntegerInterval) 880 | nonEmptyIntegerIntervalPairs boundariesComparer = ap (fmap (,) integerIntervals) integerIntervals `suchThat` 881 | (\(i1, i2) -> 882 | (not . IntegerInterval.null $ i1) && 883 | (not . IntegerInterval.null $ i2) && 884 | boundariesComparer 885 | (IntegerInterval.lowerBound i1) 886 | (IntegerInterval.upperBound i1) 887 | (IntegerInterval.lowerBound i2) 888 | (IntegerInterval.upperBound i2) 889 | ) 890 | 891 | intervals :: Gen (Interval.Interval Rational) 892 | intervals = arbitrary 893 | 894 | pos :: IntegerInterval 895 | pos = 0 <..< PosInf 896 | 897 | neg :: IntegerInterval 898 | neg = NegInf <..< 0 899 | 900 | nonpos :: IntegerInterval 901 | nonpos = NegInf <..<= 0 902 | 903 | nonneg :: IntegerInterval 904 | nonneg = 0 <=..< PosInf 905 | 906 | ------------------------------------------------------------------------ 907 | -- Test harness 908 | 909 | integerIntervalTestGroup = $(testGroupGenerator) 910 | -------------------------------------------------------------------------------- /test/TestIntervalMap.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} 2 | {-# LANGUAGE CPP, TemplateHaskell, ScopedTypeVariables #-} 3 | module TestIntervalMap (intervalMapTestGroup) where 4 | 5 | import Control.DeepSeq 6 | import Control.Exception (evaluate) 7 | import Control.Monad 8 | import Data.Functor.Identity 9 | import qualified Data.Foldable as F 10 | import Data.Generics.Schemes 11 | import Data.Hashable 12 | import Data.Maybe 13 | import Data.Typeable (cast) 14 | 15 | import Test.ChasingBottoms.IsBottom 16 | import Test.QuickCheck.Function 17 | import Test.Tasty 18 | import Test.Tasty.QuickCheck 19 | import Test.Tasty.HUnit 20 | import Test.Tasty.TH 21 | 22 | import Data.Interval ( Interval, Extended (..), (<=..<=), (<=..<), (<..<=), (<..<), ( 36 | IML.isSubmapOf IML.empty a 37 | 38 | prop_null_empty :: Property 39 | prop_null_empty = 40 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 41 | IML.null a == (a == IML.empty) 42 | 43 | case_null_empty :: Assertion 44 | case_null_empty = 45 | IML.null (IML.empty :: IntervalMap Rational Integer) @?= True 46 | 47 | {-------------------------------------------------------------------- 48 | whole 49 | --------------------------------------------------------------------} 50 | 51 | case_nonnull_whole :: Assertion 52 | case_nonnull_whole = 53 | IML.null (IML.whole 0 :: IntervalMap Rational Integer) @?= False 54 | 55 | prop_whole_Lazy_Strict :: Property 56 | prop_whole_Lazy_Strict = do 57 | forAll arbitrary $ \(a :: Integer) -> 58 | (IML.whole a :: IntervalMap Rational Integer) == IMS.whole a 59 | 60 | case_whole_nonstrict :: Assertion 61 | case_whole_nonstrict = do 62 | _ <- evaluate (IML.whole bottom :: IntervalMap Rational Integer) 63 | return () 64 | 65 | case_whole_strict :: Assertion 66 | case_whole_strict = 67 | isBottom (IMS.whole bottom :: IntervalMap Rational Integer) @?= True 68 | 69 | {-------------------------------------------------------------------- 70 | singleton 71 | --------------------------------------------------------------------} 72 | 73 | prop_singleton_insert :: Property 74 | prop_singleton_insert = do 75 | forAll arbitrary $ \(i :: Interval Rational) -> 76 | forAll arbitrary $ \(a :: Integer) -> 77 | IML.singleton i a == IML.insert i a IML.empty 78 | 79 | prop_singleton_Lazy_Strict :: Property 80 | prop_singleton_Lazy_Strict = do 81 | forAll arbitrary $ \(i :: Interval Rational) -> 82 | forAll arbitrary $ \(a :: Integer) -> 83 | IML.singleton i a == IMS.singleton i a 84 | 85 | case_singleton_nonstrict :: Assertion 86 | case_singleton_nonstrict = do 87 | _ <- evaluate (IML.singleton 0 bottom :: IntervalMap Rational Integer) 88 | return () 89 | 90 | case_singleton_strict :: Assertion 91 | case_singleton_strict = 92 | isBottom (IMS.singleton 0 bottom :: IntervalMap Rational Integer) @?= True 93 | 94 | {-------------------------------------------------------------------- 95 | insert 96 | --------------------------------------------------------------------} 97 | 98 | prop_insert_whole :: Property 99 | prop_insert_whole = 100 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 101 | forAll arbitrary $ \a -> 102 | IML.insert Interval.whole a m == IML.whole a 103 | 104 | prop_insert_empty :: Property 105 | prop_insert_empty = 106 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 107 | forAll arbitrary $ \a -> 108 | IML.insert Interval.empty a m == m 109 | 110 | prop_insert_comm :: Property 111 | prop_insert_comm = 112 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 113 | forAll arbitrary $ \(i1,a1) -> 114 | forAll arbitrary $ \(i2,a2) -> 115 | Interval.null (Interval.intersection i1 i2) 116 | ==> 117 | (IML.insert i1 a1 (IML.insert i2 a2 m) == IML.insert i2 a2 (IML.insert i1 a1 m)) 118 | 119 | prop_insert_isSubmapOf :: Property 120 | prop_insert_isSubmapOf = 121 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 122 | forAll arbitrary $ \i -> 123 | forAll arbitrary $ \a -> 124 | IML.isSubmapOf (IML.singleton i a) (IML.insert i a m) 125 | 126 | prop_insert_member :: Property 127 | prop_insert_member = 128 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 129 | forAll arbitrary $ \i -> 130 | forAll arbitrary $ \a -> 131 | case Interval.pickup i of 132 | Just k -> IML.member k (IML.insert i a m) 133 | Nothing -> True 134 | 135 | prop_insert_lookup :: Property 136 | prop_insert_lookup = 137 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 138 | forAll arbitrary $ \i -> 139 | forAll arbitrary $ \a -> 140 | case Interval.pickup i of 141 | Just k -> IML.lookup k (IML.insert i a m) == Just a 142 | Nothing -> True 143 | 144 | prop_insert_bang :: Property 145 | prop_insert_bang = 146 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 147 | forAll arbitrary $ \i -> 148 | forAll arbitrary $ \a -> 149 | case Interval.pickup i of 150 | Just k -> IML.insert i a m IML.! k == a 151 | Nothing -> True 152 | 153 | prop_insert_Lazy_Strict :: Property 154 | prop_insert_Lazy_Strict = 155 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 156 | forAll arbitrary $ \i -> 157 | forAll arbitrary $ \a -> 158 | IML.insert i a m == IMS.insert i a m 159 | 160 | prop_insert_nonstrict :: Property 161 | prop_insert_nonstrict = 162 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 163 | forAll arbitrary $ \i -> 164 | IML.insert i bottom m `seq` True 165 | 166 | prop_insert_strict :: Property 167 | prop_insert_strict = 168 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 169 | forAll arbitrary $ \i -> 170 | isBottom $ IMS.insert i bottom m 171 | 172 | prop_insertWith_Lazy_Strict :: Property 173 | prop_insertWith_Lazy_Strict = 174 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 175 | forAll arbitrary $ \(f :: Fun (Integer,Integer) Integer) -> 176 | forAll arbitrary $ \i -> 177 | forAll arbitrary $ \a -> 178 | IML.insertWith (curry (apply f)) i a m == IMS.insertWith (curry (apply f)) i a m 179 | 180 | case_insertWith_nonstrict :: Assertion 181 | case_insertWith_nonstrict = evaluate (IML.insertWith (\_ _ -> bottom) (3 <=..< 7) 1 m) >> return () 182 | where 183 | m :: IntervalMap Rational Integer 184 | m = IML.singleton (0 <=..< 10) 0 185 | 186 | case_insertWith_strict :: Assertion 187 | case_insertWith_strict = isBottom (IMS.insertWith (\_ _ -> bottom) (3 <=..< 7) 1 m) @?= True 188 | where 189 | m :: IntervalMap Rational Integer 190 | m = IMS.singleton (0 <=..< 10) 0 191 | 192 | {-------------------------------------------------------------------- 193 | delete / update 194 | --------------------------------------------------------------------} 195 | 196 | prop_delete_empty :: Property 197 | prop_delete_empty = 198 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 199 | IML.delete Interval.empty m == m 200 | 201 | prop_delete_whole :: Property 202 | prop_delete_whole = 203 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 204 | IML.delete Interval.whole m == IML.empty 205 | 206 | prop_delete_from_empty :: Property 207 | prop_delete_from_empty = 208 | forAll arbitrary $ \(i :: Interval Rational) -> 209 | IML.delete i (IML.empty :: IntervalMap Rational Integer) == IML.empty 210 | 211 | prop_delete_comm :: Property 212 | prop_delete_comm = 213 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 214 | forAll arbitrary $ \i1 -> 215 | forAll arbitrary $ \i2 -> 216 | IML.delete i1 (IML.delete i2 m) == IML.delete i2 (IML.delete i1 m) 217 | 218 | prop_delete_notMember :: Property 219 | prop_delete_notMember = 220 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 221 | forAll arbitrary $ \i -> 222 | case Interval.pickup i of 223 | Just k -> IML.notMember k (IML.delete i m) 224 | Nothing -> True 225 | 226 | prop_delete_lookup :: Property 227 | prop_delete_lookup = 228 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 229 | forAll arbitrary $ \i -> 230 | case Interval.pickup i of 231 | Just k -> IML.lookup k (IML.delete i m) == Nothing 232 | Nothing -> True 233 | 234 | case_adjust :: Assertion 235 | case_adjust = IML.adjust (+1) (3 <=..< 7) m @?= expected 236 | where 237 | m :: IntervalMap Rational Integer 238 | m = 239 | IML.fromList 240 | [ (0 <=..< 2, 0) 241 | , (2 <=..< 4, 2) 242 | , (4 <=..< 6, 4) 243 | , (6 <=..< 8, 6) 244 | , (8 <=..< 10, 8) 245 | ] 246 | expected = 247 | IML.fromList 248 | [ (0 <=..< 2, 0) 249 | , (2 <=..< 3, 2) 250 | , (3 <=..< 4, 3) 251 | , (4 <=..< 6, 5) 252 | , (6 <=..< 7, 7) 253 | , (7 <=..< 8, 6) 254 | , (8 <=..< 10, 8) 255 | ] 256 | 257 | prop_adjust_Lazy_Strict :: Property 258 | prop_adjust_Lazy_Strict = 259 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 260 | forAll arbitrary $ \(f :: Fun Integer Integer) -> 261 | forAll arbitrary $ \i -> 262 | IML.adjust (apply f) i m == IMS.adjust (apply f) i m 263 | 264 | case_asjust_nonstrict :: Assertion 265 | case_asjust_nonstrict = do 266 | _ <- evaluate $ IML.adjust (\_ -> bottom) (3 <=..< 7) m 267 | return () 268 | where 269 | m :: IntervalMap Rational Integer 270 | m = IML.singleton (0 <=..< 10) 0 271 | 272 | case_asjust_strict :: Assertion 273 | case_asjust_strict = isBottom (IMS.adjust (\_ -> bottom) (3 <=..< 7) m) @?= True 274 | where 275 | m :: IntervalMap Rational Integer 276 | m = IMS.singleton (0 <=..< 10) 0 277 | 278 | prop_alter :: Property 279 | prop_alter = 280 | forAll arbitrary $ \(m :: IntervalMap Rational Int) -> 281 | forAll arbitrary $ \i -> 282 | forAll arbitrary $ \f -> 283 | case Interval.pickup i of 284 | Nothing -> True 285 | Just k -> 286 | IML.lookup k (IML.alter (apply f) i m) == apply f (IML.lookup k m) 287 | 288 | prop_alter_Lazy_Strict :: Property 289 | prop_alter_Lazy_Strict = 290 | forAll arbitrary $ \(m :: IntervalMap Rational Int) -> 291 | forAll arbitrary $ \i -> 292 | forAll arbitrary $ \f -> 293 | IML.alter (apply f) i m == IMS.alter (apply f) i m 294 | 295 | prop_alter_nonstrict :: Property 296 | prop_alter_nonstrict = 297 | forAll arbitrary $ \(m :: IntervalMap Rational Int) -> 298 | forAll arbitrary $ \i -> 299 | not (Interval.null i) 300 | ==> 301 | (IML.alter (\_ -> Just bottom) i m `seq` True) 302 | 303 | prop_alter_strict :: Property 304 | prop_alter_strict = 305 | forAll arbitrary $ \(m :: IntervalMap Rational Int) -> 306 | forAll arbitrary $ \i -> 307 | not (Interval.null i) 308 | ==> 309 | isBottom (IMS.alter (\_ -> Just bottom) i m) 310 | 311 | {-------------------------------------------------------------------- 312 | Union 313 | --------------------------------------------------------------------} 314 | 315 | prop_union_assoc :: Property 316 | prop_union_assoc = 317 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 318 | forAll arbitrary $ \b -> 319 | forAll arbitrary $ \c -> 320 | IML.union a (IML.union b c) == IML.union (IML.union a b) c 321 | 322 | prop_union_unitL :: Property 323 | prop_union_unitL = 324 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 325 | IML.union IML.empty a == a 326 | 327 | prop_union_unitR :: Property 328 | prop_union_unitR = 329 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 330 | IML.union a IML.empty == a 331 | 332 | prop_union_isSubmapOf :: Property 333 | prop_union_isSubmapOf = 334 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 335 | forAll arbitrary $ \b -> 336 | IML.isSubmapOf a (IML.union a b) 337 | 338 | prop_union_isSubmapOf_equiv :: Property 339 | prop_union_isSubmapOf_equiv = 340 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 341 | forAll arbitrary $ \b -> 342 | IML.isSubmapOf (IML.union a b) b 343 | == IML.isSubmapOf a b 344 | 345 | case_unions_empty_list :: Assertion 346 | case_unions_empty_list = 347 | IML.unions [] @?= (IML.empty :: IntervalMap Rational Integer) 348 | 349 | prop_unions_singleton_list :: Property 350 | prop_unions_singleton_list = 351 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 352 | IML.unions [a] == a 353 | 354 | prop_unions_two_elems :: Property 355 | prop_unions_two_elems = 356 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 357 | forAll arbitrary $ \b -> 358 | IML.unions [a,b] == IML.union a b 359 | 360 | case_unionWith :: Assertion 361 | case_unionWith = actual @?= expected 362 | where 363 | actual, expected :: IntervalMap Rational Integer 364 | actual = IML.unionWith (+) (IML.singleton (0 <=..<= 10) 1) (IML.singleton (5 <=..<= 15) 2) 365 | expected = IML.fromList [(0 <=..< 5, 1), (5 <=..<= 10, 3), (10 <..<= 15, 2)] 366 | 367 | prop_unionWith_Lazy_Strict :: Property 368 | prop_unionWith_Lazy_Strict = 369 | forAll arbitrary $ \(a :: IntervalMap Rational Int) -> 370 | forAll arbitrary $ \b -> 371 | forAll arbitrary $ \f -> 372 | IML.unionWith (curry (apply f)) a b == IMS.unionWith (curry (apply f)) a b 373 | 374 | prop_unionWith_nonstrict :: Property 375 | prop_unionWith_nonstrict = 376 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 377 | forAll arbitrary $ \b -> 378 | IML.unionWith (\_ _ -> bottom) a b `seq` True 379 | 380 | prop_unionWith_strict :: Property 381 | prop_unionWith_strict = 382 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 383 | forAll arbitrary $ \b -> 384 | not (IntervalSet.null (IMS.keysSet a `IntervalSet.intersection` IMS.keysSet b)) 385 | ==> 386 | isBottom (IMS.unionWith (\_ _ -> bottom) a b) 387 | 388 | {-------------------------------------------------------------------- 389 | Intersection 390 | --------------------------------------------------------------------} 391 | 392 | prop_intersection_isSubmapOf :: Property 393 | prop_intersection_isSubmapOf = 394 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 395 | forAll arbitrary $ \b -> 396 | IML.isSubmapOf (IML.intersection a b) a 397 | 398 | case_intersectionWith :: Assertion 399 | case_intersectionWith = actual @?= expected 400 | where 401 | actual, expected :: IntervalMap Rational Integer 402 | actual = IML.intersectionWith (+) (IML.singleton (0 <=..< 10) 1) (IML.singleton (5 <..<= 5) 1) 403 | expected = IML.singleton (5 <..< 5) 2 404 | 405 | prop_intersectionWith_Lazy_Strict :: Property 406 | prop_intersectionWith_Lazy_Strict = 407 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 408 | forAll arbitrary $ \(b :: IntervalMap Rational Integer) -> 409 | forAll arbitrary $ \(f :: Fun (Integer,Integer) Integer) -> 410 | IML.intersectionWith (curry (apply f)) a b == IMS.intersectionWith (curry (apply f)) a b 411 | 412 | prop_intersectionWith_nonstrict :: Property 413 | prop_intersectionWith_nonstrict = 414 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 415 | forAll arbitrary $ \(b :: IntervalMap Rational Integer) -> 416 | IML.intersectionWith (\_ _ -> bottom :: Integer) a b `seq` True 417 | 418 | prop_intersectionWith_strict :: Property 419 | prop_intersectionWith_strict = 420 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 421 | forAll arbitrary $ \(b :: IntervalMap Rational Integer) -> 422 | not (IntervalSet.null (IMS.keysSet a `IntervalSet.intersection` IMS.keysSet b)) 423 | ==> 424 | isBottom (IMS.intersectionWith (\_ _ -> bottom :: Integer) a b) 425 | 426 | {-------------------------------------------------------------------- 427 | Difference 428 | --------------------------------------------------------------------} 429 | 430 | prop_difference_isSubmapOf :: Property 431 | prop_difference_isSubmapOf = 432 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 433 | forAll arbitrary $ \(b :: IntervalMap Rational Integer) -> 434 | IML.isSubmapOf (a IML.\\ b) a 435 | 436 | {-------------------------------------------------------------------- 437 | member / lookup 438 | --------------------------------------------------------------------} 439 | 440 | prop_notMember_empty :: Property 441 | prop_notMember_empty = 442 | forAll arbitrary $ \(r::Rational) -> 443 | r `IML.notMember` (IML.empty :: IntervalMap Rational Integer) 444 | 445 | case_findWithDefault_case1 :: Assertion 446 | case_findWithDefault_case1 = IML.findWithDefault "B" 0 m @?= "A" 447 | where 448 | m :: IntervalMap Rational String 449 | m = IML.singleton (0 <=..<1) "A" 450 | 451 | case_findWithDefault_case2 :: Assertion 452 | case_findWithDefault_case2 = IML.findWithDefault "B" 1 m @?= "B" 453 | where 454 | m :: IntervalMap Rational String 455 | m = IML.singleton (0 <=..<1) "A" 456 | 457 | {-------------------------------------------------------------------- 458 | isSubsetOf 459 | --------------------------------------------------------------------} 460 | 461 | prop_isSubmapOf_reflexive :: Property 462 | prop_isSubmapOf_reflexive = 463 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 464 | a `IML.isSubmapOf` a 465 | 466 | prop_isProperSubsetOf_irreflexive :: Property 467 | prop_isProperSubsetOf_irreflexive = 468 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 469 | not (a `IML.isProperSubmapOf` a) 470 | 471 | {-------------------------------------------------------------------- 472 | span 473 | --------------------------------------------------------------------} 474 | 475 | prop_span :: Property 476 | prop_span = 477 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 478 | IML.span a == IntervalSet.span (IML.keysSet a) 479 | 480 | {-------------------------------------------------------------------- 481 | map 482 | --------------------------------------------------------------------} 483 | 484 | case_mapKeysMonotonic :: Assertion 485 | case_mapKeysMonotonic = IML.mapKeysMonotonic (+1) m1 @?= m2 486 | where 487 | m1, m2 :: IntervalMap Rational String 488 | m1 = IML.fromList [(0 <=..< 1, "A"), (2 <..<= 3, "B")] 489 | m2 = IML.fromList [(1 <=..< 2, "A"), (3 <..<= 4, "B")] 490 | 491 | prop_map_Lazy_Strict :: Property 492 | prop_map_Lazy_Strict = 493 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 494 | forAll arbitrary $ \(f :: Fun Integer Integer) -> 495 | IML.map (apply f) m == IMS.map (apply f) m 496 | 497 | prop_map_nonstrict :: Property 498 | prop_map_nonstrict = 499 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 500 | IML.map (const (bottom :: Integer)) a `seq` True 501 | 502 | prop_map_strict :: Property 503 | prop_map_strict = 504 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 505 | not (IMS.null a) 506 | ==> 507 | isBottom (IMS.map (const (bottom :: Integer)) a) 508 | 509 | {-------------------------------------------------------------------- 510 | Functor / Foldable / Traversal 511 | --------------------------------------------------------------------} 512 | 513 | prop_Functor_identity :: Property 514 | prop_Functor_identity = 515 | forAll arbitrary $ \(m :: IntervalMap Rational Int) -> 516 | fmap id m == m 517 | 518 | prop_Functor_compsition :: Property 519 | prop_Functor_compsition = 520 | forAll arbitrary $ \(m :: IntervalMap Rational Int) -> 521 | forAll arbitrary $ \(f :: Fun Int Int) -> 522 | forAll arbitrary $ \(g :: Fun Int Int) -> 523 | fmap (apply f . apply g) m == fmap (apply f) (fmap (apply g) m) 524 | 525 | prop_Foldable_foldMap :: Property 526 | prop_Foldable_foldMap = 527 | forAll arbitrary $ \(m :: IntervalMap Rational Int) -> 528 | forAll arbitrary $ \(f :: Fun Int String) -> 529 | F.foldMap (apply f) m == F.fold (fmap (apply f) m) 530 | 531 | prop_Traversable_identity :: Property 532 | prop_Traversable_identity = 533 | forAll arbitrary $ \(m :: IntervalMap Rational Int) -> 534 | traverse Identity m == Identity m 535 | 536 | {-------------------------------------------------------------------- 537 | toList / fromList 538 | --------------------------------------------------------------------} 539 | 540 | prop_fromList_toList_id :: Property 541 | prop_fromList_toList_id = 542 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 543 | IML.fromList (IML.toList a) == a 544 | 545 | prop_toAscList_toDescList :: Property 546 | prop_toAscList_toDescList = 547 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 548 | IML.toDescList a == reverse (IML.toAscList a) 549 | 550 | case_fromList :: Assertion 551 | case_fromList = actual @?= expected 552 | where 553 | actual, expected :: IntervalMap Rational Integer 554 | actual = IML.fromList [(0 <=..< 10, 1), (5 <..<= 15, 2)] 555 | expected = IML.fromList [(0 <=..<= 5, 1), (5 <..<= 15, 2)] 556 | 557 | case_fromListWith :: Assertion 558 | case_fromListWith = actual @?= expected 559 | where 560 | actual, expected :: IntervalMap Rational Integer 561 | actual = IML.fromListWith (+) [(0 <=..< 10, 1), (5 <..<= 15, 2)] 562 | expected = IML.fromList [(0 <=..<= 5, 1), (5 <..< 10, 3), (10 <=..<= 15, 2)] 563 | 564 | prop_fromList_Lazy_Strict :: Property 565 | prop_fromList_Lazy_Strict = 566 | forAll arbitrary $ \xs -> 567 | (IML.fromList xs :: IntervalMap Rational Integer) == IMS.fromList xs 568 | 569 | case_fromList_nonstrict :: Assertion 570 | case_fromList_nonstrict = evaluate m >> return () 571 | where 572 | m :: IntervalMap Rational Integer 573 | m = IML.fromList [(0 <=..< 10, bottom), (5 <..<= 15, bottom)] 574 | 575 | case_fromList_strict :: Assertion 576 | case_fromList_strict = isBottom m @?= True 577 | where 578 | m :: IntervalMap Rational Integer 579 | m = IMS.fromList [(0 <=..< 10, bottom), (5 <..<= 15, bottom)] 580 | 581 | prop_fromListWith_Lazy_Strict :: Property 582 | prop_fromListWith_Lazy_Strict = 583 | forAll arbitrary $ \xs -> 584 | forAll arbitrary $ \f -> 585 | (IML.fromListWith (curry (apply f)) xs :: IntervalMap Rational Integer) == IMS.fromListWith (curry (apply f)) xs 586 | 587 | case_fromListWith_nonstrict :: Assertion 588 | case_fromListWith_nonstrict = evaluate m >> return () 589 | where 590 | m :: IntervalMap Rational Integer 591 | m = IML.fromListWith (\_ _ -> bottom) [(0 <=..< 10, 1), (5 <..<= 15, 2)] 592 | 593 | case_fromListWith_strict :: Assertion 594 | case_fromListWith_strict = isBottom m @?= True 595 | where 596 | m :: IntervalMap Rational Integer 597 | m = IMS.fromListWith (\_ _ -> bottom) [(0 <=..< 10, 1), (5 <..<= 15, 2)] 598 | 599 | {-------------------------------------------------------------------- 600 | Filter 601 | --------------------------------------------------------------------} 602 | 603 | case_filter :: Assertion 604 | case_filter = actual @?= expected 605 | where 606 | m, expected, actual :: IntervalMap Rational Integer 607 | m = 608 | IML.fromList 609 | [ (2 <..<= 10, 1) 610 | , (10 <..<= 20, 2) 611 | , (20 <..<= 30, 3) 612 | , (30 <..<= 40, 4) 613 | ] 614 | expected = 615 | IML.fromList 616 | [ (10 <..<= 20, 2) 617 | , (30 <..<= 40, 4) 618 | ] 619 | actual = IML.filter even m 620 | 621 | prop_split :: Property 622 | prop_split = 623 | forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> 624 | forAll arbitrary $ \i -> 625 | not (Interval.null i) 626 | ==> 627 | (case IML.split i m of 628 | (m1,m2,m3) -> 629 | and 630 | [ and [j 847 | i == i 848 | 849 | {-------------------------------------------------------------------- 850 | Show / Read 851 | --------------------------------------------------------------------} 852 | 853 | prop_show_read_invariance :: Property 854 | prop_show_read_invariance = 855 | forAll arbitrary $ \(i :: IntervalMap Rational Integer) -> 856 | i == read (show i) 857 | 858 | {-------------------------------------------------------------------- 859 | Monoid 860 | --------------------------------------------------------------------} 861 | 862 | prop_monoid_assoc :: Property 863 | prop_monoid_assoc = 864 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 865 | forAll arbitrary $ \b -> 866 | forAll arbitrary $ \c -> 867 | a <> (b <> c) == (a <> b) <> c 868 | 869 | prop_monoid_unitL :: Property 870 | prop_monoid_unitL = 871 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 872 | IML.empty <> a == a 873 | 874 | prop_monoid_unitR :: Property 875 | prop_monoid_unitR = 876 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 877 | a <> IML.empty == a 878 | 879 | {-------------------------------------------------------------------- 880 | NFData 881 | --------------------------------------------------------------------} 882 | 883 | prop_rnf :: Property 884 | prop_rnf = 885 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 886 | rnf a == () 887 | 888 | {-------------------------------------------------------------------- 889 | Hashable 890 | --------------------------------------------------------------------} 891 | 892 | prop_hash :: Property 893 | prop_hash = 894 | forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> 895 | hash a `seq` True 896 | 897 | {- ------------------------------------------------------------------ 898 | Data 899 | ------------------------------------------------------------------ -} 900 | 901 | case_Data :: Assertion 902 | case_Data = everywhere f i @?= (IML.singleton (1 <=..<= 2) 3 :: IntervalMap Integer Integer) 903 | where 904 | i :: IntervalMap Integer Integer 905 | i = IML.singleton (0 <=..<= 1) 2 906 | f x 907 | | Just (y :: Integer) <- cast x = fromJust $ cast (y + 1) 908 | | otherwise = x 909 | 910 | {-------------------------------------------------------------------- 911 | Generators 912 | --------------------------------------------------------------------} 913 | 914 | instance Arbitrary Interval.Boundary where 915 | arbitrary = arbitraryBoundedEnum 916 | 917 | instance Arbitrary r => Arbitrary (Extended r) where 918 | arbitrary = 919 | oneof 920 | [ return NegInf 921 | , return PosInf 922 | , liftM Finite arbitrary 923 | ] 924 | 925 | instance (Arbitrary r, Ord r) => Arbitrary (Interval r) where 926 | arbitrary = do 927 | lb <- arbitrary 928 | ub <- arbitrary 929 | return $ Interval.interval lb ub 930 | 931 | instance (Arbitrary k, Arbitrary a, Ord k) => Arbitrary (IntervalMap k a) where 932 | arbitrary = IML.fromList <$> listOf arbitrary 933 | 934 | ------------------------------------------------------------------------ 935 | -- Test harness 936 | 937 | intervalMapTestGroup :: TestTree 938 | intervalMapTestGroup = $(testGroupGenerator) 939 | --------------------------------------------------------------------------------