diff --git a/Data/SegmentTree.hs b/Data/SegmentTree.hs
deleted file mode 100644
--- a/Data/SegmentTree.hs
+++ /dev/null
@@ -1,75 +0,0 @@
--- | This module contains the 'SegmentTree' data structure, its
--- constructor and the query function.
---
--- Example Usage:
---
--- @
--- import Data.Monoid
--- import Data.SegmentTree
--- ...
--- st = mkTree $ map Sum [0..10]
--- ...
--- queryTree st (0, 10) == Sum 55
--- queryTree st (5, 10) == Sum 45
--- queryTree st (0, 4) == Sum 10
--- @
-
-module Data.SegmentTree ( SegmentTree(..), mkTree, queryTree ) where
-
-import Data.Monoid
-import Text.Printf
-
-data (Monoid a) => Tree a = Branch a (Tree a) (Tree a) | Leaf a
-
-getCargo (Branch x _ _) = x
-getCargo (Leaf x) = x
-
--- | A 'SegmentTree' is a binary tree and the bounds of its
--- corresponding interval.
-data (Monoid a) => SegmentTree a = SegmentTree (Tree a) (Int, Int)
-
-instance (Monoid a) => Show (SegmentTree a) where
- show (SegmentTree t (l, u)) = unlines $ go t (l, u)
- where
- go (Branch _ lc rc) (l, u) =
- let m = (u-l) `div` 2
- (ls, rs) = (go lc (l, l+m), go rc (l+m+1, u))
- (ls', rs') = (indentTree True ls, indentTree False rs)
- ts = printf "[%d..%d]" l u
- in concat [[ts], ls', rs']
- go (Leaf _) (l, u) = [printf "[%d]" l]
- indentTree _ [] = []
- indentTree True [x] = [printf "|-- %s" x]
- indentTree False [x] = [printf "`-- %s" x]
- indentTree True (x:xs) = indentTree True [x] ++ map ("| "++) xs
- indentTree False (x:xs) = indentTree False [x] ++ map (" "++) xs
-
--- | Build the 'SegmentTree' for the given list. Time: O(n*log n)
-mkTree :: (Monoid a) => [a] -> SegmentTree a
-mkTree xs = SegmentTree (go xs listBounds) listBounds
- where
- listBounds = (0, length xs - 1)
- go ys (l, u)
- -- invariant: head ys == xs !! l
- | l == u = Leaf (head ys)
- | otherwise =
- let m = (u-l) `div` 2
- leftc = go ys (l, l+m)
- rightc = go (drop (m+1) ys) (l+m+1, u)
- in Branch (getCargo leftc `mappend` getCargo rightc)
- leftc rightc
-
--- | Query the 'SegmentTree' for the specified closed interval. Time:
--- O(log n)
-queryTree :: (Monoid a) => SegmentTree a -> (Int, Int) -> a
-queryTree (SegmentTree t (s, e)) (l, u) = go t (s, e)
- where
- -- we're querying for (l, u)
- go t (s, e)
- | (l > e) || (u < s) = mempty
- | (l <= s) && (u >= e) = getCargo t
- | otherwise = let (Branch _ leftc rightc) = t
- m = (e-s) `div` 2
- lv = go leftc (s, s+m)
- rv = go rightc (s+m+1, e)
- in lv `mappend` rv
diff --git a/Data/SegmentTree/Examples.hs b/Data/SegmentTree/Examples.hs
deleted file mode 100644
--- a/Data/SegmentTree/Examples.hs
+++ /dev/null
@@ -1,73 +0,0 @@
--- | Example uses of 'SegmentTree's.
-
-module Data.SegmentTree.Examples
- ( -- * Sum Monoid
- intervalSum
- -- * Any Monoid
- , intervalAny
- -- * GCD Monoid
- , GCD(..), intervalGCD
- -- * String Monoid
- , intervalConcat
- -- * Unwords Monoid
- , Unwords(..), intervalUnwords
- ) where
-
-import Data.SegmentTree
-
-import Data.Monoid
-
--------------
--- Sum monoid
--------------
-
--- | Find the sum of the elements in the interval [l, u].
-intervalSum :: SegmentTree (Sum Int) -> (Int, Int) -> Int
-intervalSum t bds@(l, u) = getSum $ queryTree t bds
-
--------------
--- Any monoid
--------------
-
--- | Find out if any of the elements are True in the interval [l, u].
-intervalAny :: SegmentTree Any -> (Int, Int) -> Bool
-intervalAny t bds@(l, u) = getAny $ queryTree t bds
-
--------------
--- GCD monoid
--------------
-
-newtype (Integral a) => GCD a = GCD { getGCD :: a }
-
-instance (Integral a) => Monoid (GCD a) where
- mempty = GCD $ fromIntegral 1
- (GCD x) `mappend` (GCD y) = GCD $ gcd x y
-
--- | Find the greatest common divisor of the elements in the interval
--- [l, u].
-intervalGCD :: SegmentTree (GCD Int) -> (Int, Int) -> Int
-intervalGCD t bds@(l, u) = getGCD $ queryTree t bds
-
-----------------
--- String monoid
-----------------
-
--- | Concatenate the strings in the interval [l, u].
-intervalConcat :: SegmentTree String -> (Int, Int) -> String
-intervalConcat t bds@(l, u) = queryTree t bds
-
----------------
--- Unwords monoid
----------------
-
-newtype Unwords = Unwords { getUnwords :: String }
-
-instance Monoid Unwords where
- mempty = Unwords ""
- (Unwords "") `mappend` y = y
- x `mappend` (Unwords "") = x
- (Unwords x) `mappend` (Unwords y) = Unwords (x ++ " " ++ y)
-
--- | Unwords the words in the interval [l, u].
-intervalUnwords :: SegmentTree Unwords -> (Int, Int) -> String
-intervalUnwords t bds@(l, u) = getUnwords $ queryTree t bds
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,165 +1,27 @@
- GNU LESSER GENERAL PUBLIC LICENSE
- Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc.
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-
- This version of the GNU Lesser General Public License incorporates
-the terms and conditions of version 3 of the GNU General Public
-License, supplemented by the additional permissions listed below.
-
- 0. Additional Definitions.
-
- As used herein, "this License" refers to version 3 of the GNU Lesser
-General Public License, and the "GNU GPL" refers to version 3 of the GNU
-General Public License.
-
- "The Library" refers to a covered work governed by this License,
-other than an Application or a Combined Work as defined below.
-
- An "Application" is any work that makes use of an interface provided
-by the Library, but which is not otherwise based on the Library.
-Defining a subclass of a class defined by the Library is deemed a mode
-of using an interface provided by the Library.
-
- A "Combined Work" is a work produced by combining or linking an
-Application with the Library. The particular version of the Library
-with which the Combined Work was made is also called the "Linked
-Version".
-
- The "Minimal Corresponding Source" for a Combined Work means the
-Corresponding Source for the Combined Work, excluding any source code
-for portions of the Combined Work that, considered in isolation, are
-based on the Application, and not on the Linked Version.
-
- The "Corresponding Application Code" for a Combined Work means the
-object code and/or source code for the Application, including any data
-and utility programs needed for reproducing the Combined Work from the
-Application, but excluding the System Libraries of the Combined Work.
-
- 1. Exception to Section 3 of the GNU GPL.
-
- You may convey a covered work under sections 3 and 4 of this License
-without being bound by section 3 of the GNU GPL.
-
- 2. Conveying Modified Versions.
-
- If you modify a copy of the Library, and, in your modifications, a
-facility refers to a function or data to be supplied by an Application
-that uses the facility (other than as an argument passed when the
-facility is invoked), then you may convey a copy of the modified
-version:
-
- a) under this License, provided that you make a good faith effort to
- ensure that, in the event an Application does not supply the
- function or data, the facility still operates, and performs
- whatever part of its purpose remains meaningful, or
-
- b) under the GNU GPL, with none of the additional permissions of
- this License applicable to that copy.
-
- 3. Object Code Incorporating Material from Library Header Files.
-
- The object code form of an Application may incorporate material from
-a header file that is part of the Library. You may convey such object
-code under terms of your choice, provided that, if the incorporated
-material is not limited to numerical parameters, data structure
-layouts and accessors, or small macros, inline functions and templates
-(ten or fewer lines in length), you do both of the following:
-
- a) Give prominent notice with each copy of the object code that the
- Library is used in it and that the Library and its use are
- covered by this License.
-
- b) Accompany the object code with a copy of the GNU GPL and this license
- document.
-
- 4. Combined Works.
-
- You may convey a Combined Work under terms of your choice that,
-taken together, effectively do not restrict modification of the
-portions of the Library contained in the Combined Work and reverse
-engineering for debugging such modifications, if you also do each of
-the following:
-
- a) Give prominent notice with each copy of the Combined Work that
- the Library is used in it and that the Library and its use are
- covered by this License.
-
- b) Accompany the Combined Work with a copy of the GNU GPL and this license
- document.
-
- c) For a Combined Work that displays copyright notices during
- execution, include the copyright notice for the Library among
- these notices, as well as a reference directing the user to the
- copies of the GNU GPL and this license document.
-
- d) Do one of the following:
-
- 0) Convey the Minimal Corresponding Source under the terms of this
- License, and the Corresponding Application Code in a form
- suitable for, and under terms that permit, the user to
- recombine or relink the Application with a modified version of
- the Linked Version to produce a modified Combined Work, in the
- manner specified by section 6 of the GNU GPL for conveying
- Corresponding Source.
-
- 1) Use a suitable shared library mechanism for linking with the
- Library. A suitable mechanism is one that (a) uses at run time
- a copy of the Library already present on the user's computer
- system, and (b) will operate properly with a modified version
- of the Library that is interface-compatible with the Linked
- Version.
-
- e) Provide Installation Information, but only if you would otherwise
- be required to provide such information under section 6 of the
- GNU GPL, and only to the extent that such information is
- necessary to install and execute a modified version of the
- Combined Work produced by recombining or relinking the
- Application with a modified version of the Linked Version. (If
- you use option 4d0, the Installation Information must accompany
- the Minimal Corresponding Source and Corresponding Application
- Code. If you use option 4d1, you must provide the Installation
- Information in the manner specified by section 6 of the GNU GPL
- for conveying Corresponding Source.)
-
- 5. Combined Libraries.
-
- You may place library facilities that are a work based on the
-Library side by side in a single library together with other library
-facilities that are not Applications and are not covered by this
-License, and convey such a combined library under terms of your
-choice, if you do both of the following:
-
- a) Accompany the combined library with a copy of the same work based
- on the Library, uncombined with any other library facilities,
- conveyed under the terms of this License.
-
- b) Give prominent notice with the combined library that part of it
- is a work based on the Library, and explaining where to find the
- accompanying uncombined form of the same work.
-
- 6. Revised Versions of the GNU Lesser General Public License.
+Copyright (C) 2010 Dmitry Astapov
- The Free Software Foundation may publish revised and/or new versions
-of the GNU Lesser General Public License from time to time. Such new
-versions will be similar in spirit to the present version, but may
-differ in detail to address new problems or concerns.
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
- Each version is given a distinguishing version number. If the
-Library as you received it specifies that a certain numbered version
-of the GNU Lesser General Public License "or any later version"
-applies to it, you have the option of following the terms and
-conditions either of that published version or of any later version
-published by the Free Software Foundation. If the Library as you
-received it does not specify a version number of the GNU Lesser
-General Public License, you may choose any version of the GNU Lesser
-General Public License ever published by the Free Software Foundation.
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the
+ distribution.
+3. The names of the authors may not be used to endorse or promote
+ products derived from this software without specific prior written
+ permission.
- If the Library as you received it specifies that a proxy can decide
-whether future versions of the GNU Lesser General Public License shall
-apply, that proxy's public statement of acceptance of any version is
-permanent authorization for you to choose that version for the
-Library.
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
+INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
+IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
diff --git a/README b/README
new file mode 100644
--- /dev/null
+++ b/README
@@ -0,0 +1,2 @@
+Configure as "cabal configure -ftest" and run "SegmentTreeTests" for
+functional test suite.
diff --git a/SegmentTree.cabal b/SegmentTree.cabal
--- a/SegmentTree.cabal
+++ b/SegmentTree.cabal
@@ -1,17 +1,37 @@
-Name: SegmentTree
-Version: 0.1
-Cabal-Version: >= 1.2
+Name: SegmentTree
+Version: 0.2
+License: BSD3
+License-File: LICENSE
+Author: Dmitry Astapov
+Maintainer: Dmitry Astapov
+Category: Data
+Stability: beta
+Cabal-Version: >= 1.2
Build-type: Simple
-License: LGPL
-License-File: LICENSE
-Author: Alexandru Scvortov
-Maintainer: scvalex@gmail.com
-Homepage: http://scvalex.github.com/articles/SegmentTree.html
-Category: Data
-Synopsis: Data structure for O(log n) mconcats on list intervals
-Description: The 'SegmentTree' data structure allows for logarithmic
- time accumulations on preprocessed lists of 'Monoid's.
+Synopsis: Data structure for querying the set (or count) of intervals covering given point
+Description: Segment Tree implemented following section 10.3 and 10.4 of
+ Mark de Berg, Otfried Cheong, Marc van Kreveld, Mark Overmars
+ "Computational Geometry, Algorithms and Applications", Third Edition
+ (2008) pp 231-237
+Tested-With: GHC >=6.10.4
+
+Extra-source-files: README
+
+flag test
+ default: False
+
Library
- Build-Depends: base
- Exposed-modules: Data.SegmentTree, Data.SegmentTree.Examples
+ Hs-Source-Dirs: ./src
+ Build-Depends: base >=3 && <=5
+ Exposed-modules: Data.SegmentTree
+ Other-modules: Data.SegmentTree.Interval, Data.SegmentTree.Measured
+
+Executable SegmentTreeTests
+ Hs-Source-Dirs: ./src
+ Main-Is: Tests.hs
+ if flag(test)
+ Build-Depends: base >=3 && <=5, HUnit, QuickCheck >= 2.0.0 , test-framework, test-framework-quickcheck2, test-framework-hunit
+ Other-Modules: Stabbing.Naive Stabbing.SegmentTree
+ else
+ Buildable: False
diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,3 @@
+#!/usr/bin/env runhaskell
import Distribution.Simple
main = defaultMain
diff --git a/src/Data/SegmentTree.hs b/src/Data/SegmentTree.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/SegmentTree.hs
@@ -0,0 +1,158 @@
+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.SegmentTree
+-- Copyright : (c) Dmitry Astapov 2010
+-- License : BSD-style
+-- Maintainer : dastapov@gmail.com
+-- Stability : experimental
+-- Portability : non-portable (MPTCs, etc - see above)
+--
+-- Segment Tree implemented following section 10.3 and 10.4 of
+--
+-- * Mark de Berg, Otfried Cheong, Marc van Kreveld, Mark Overmars
+-- "Computational Geometry, Algorithms and Applications", Third Edition
+-- (2008) pp 231-237
+-- \"Finger trees: a simple general-purpose data structure\",
+-- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
+--
+--
+-- Accumulation of results with monoids following "Monoids and Finger Trees",
+-- http://apfelmus.nfshost.com/articles/monoid-fingertree.html
+--
+-- An amortized running time is given for each operation, with /n/
+-- referring to the number of intervals.
+-----------------------------------------------------------------------------
+
+module Data.SegmentTree ( STree(..), fromList, insert, queryTree, countingQuery, stabbingQuery ) where
+
+import Data.SegmentTree.Interval
+import Data.SegmentTree.Measured
+import Data.List (sort, unfoldr, foldl')
+import Data.Monoid
+import Text.Printf
+
+-- | Segment Tree is a binary tree that stores Interval in each leaf or branch.
+-- By construction (see `leaf' and `branch') intervals in branches should be union
+-- of the intervals from left and right subtrees.
+--
+-- Additionally, each node carries a "tag" of type "t" (which should be monoid).
+-- By supplying different monoids, segment tree could be made to support different types
+-- of stabbing queries: Sum or Integer monoid will give tree that counts hits, and list or
+-- Set monoids will give a tree that returns actual intervals containing point.
+data STree t a = Leaf !t !(Interval a)
+ | Branch !t !(Interval a) !(STree t a) !(STree t a)
+
+instance (Show t, Show a) => Show (STree t a) where
+ show (Leaf t i) = printf "Leaf %s %s" (show t) (show i)
+ show (Branch t i left right) = printf "Branch %s %s (\n %s\n %s)" (show t) (show i) (show left) (show right)
+
+-- Selectors for STree
+tag :: STree t a -> t
+tag (Leaf t _) = t
+tag (Branch t _ _ _) = t
+
+interval (Leaf _ i) = i
+interval (Branch _ i _ _) = i
+
+-- Constructors for STree nodes
+branch :: (Ord a, Measured (Interval a) t) => STree t a -> STree t a -> STree t a
+branch x y = Branch (tag x `mappend` tag y) (merge (interval x) (interval y)) x y
+
+leaf :: (Ord a, Measured (Interval a) t) => Interval a -> STree t a
+leaf a = Leaf (measure a) a
+
+-- Instances that allow creation of useful trees.
+--
+-- Trees for stabbing count queries:
+-- @
+-- STree Integer Rational
+-- STree (Sum Integer) Rational
+-- @
+--
+-- Trees for stabbing queries:
+-- @
+-- STree [Interval Rational] Rational
+-- STree (Set (Interval Rational)) Rational
+-- @
+
+instance Measured (Interval a) [Interval a] where
+ measure x = [x]
+
+instance (Num a, Num b) => Measured (Interval a) (Sum b) where
+ measure _ = Sum 1
+
+-- instance Monoid Integer where
+-- mempty = 0
+-- mappend = (+)
+
+-- | Build the 'SegmentTree' for the given list of pair of points. Time: O(n*log n)
+-- Segment tree is built as follows:
+-- * Supplied list of point pairs define so-called "atomic intervals"
+-- * They are used to build "skeleton" binary tree
+-- * Each supplied interval is then "inserted" into this tree, updating tag values
+-- in tree branches and leaves
+fromList :: (Monoid t, Measured (Interval a) t, Ord a) => [(a,a)] -> STree t a
+fromList pairs = foldl' insert skeleton intervals
+ where
+ -- "intervals" is just an original list of pairs converted to "Interval" datatype
+ intervals = map pair2interval pairs
+ pair2interval (a,b) = Interval Closed (R a) (R b) Closed
+
+ -- "skeleton" tree is a binary tree where each leaf holds some atomic interval (and empty tag)
+ -- and each branch holds union of intervals from its leaves (and empty tag).
+ -- Tree is built from bottom up, by making "leaves" first and then connecting them with branches
+ -- pairwise, until a single root is obtained.
+ ([skeleton]:_) = dropWhile (not.converged) $ iterate (unfoldr connect) leaves
+ leaves = map (Leaf mempty) atomics
+ connect [] = Nothing
+ connect [x,y,z] = Just $ ((x `branch` y) `branch` z, [])
+ connect (x:y:rest) = Just $ (x `branch` y, rest)
+ converged [x] = True
+ converged _ = False
+
+ -- Open "atomic" intervals are formed between the (sorted) endpoints of original intervals.
+ -- Leftmost atomic interval starts from minu infinity, rightmost ends with infinity.
+ -- All endpoints are also converted to closed single-point atomic intervals.
+ -- For details, see book referenced above or wikipedia.
+ atomics = concat (zipWith atomicInterval endpoints (drop 1 endpoints))
+ atomicInterval a PlusInf = [Interval Open a PlusInf Open]
+ atomicInterval a b = [Interval Open a b Open, Interval Closed b b Closed]
+ endpoints = sort $ foldl' (\acc i -> (low i):(high i):acc) [MinusInf,PlusInf] intervals
+
+-- | Insert interval `i' into segment tree, updating tag values as necessary.
+-- Semantics of tags depends on the monoid used (see `fromList')
+insert :: (Ord a, Measured (Interval a) t) => STree t a -> Interval a -> STree t a
+insert leaf@(Leaf t iu) i
+ | iu `subinterval` i = Leaf (t `mappend` (measure i)) iu
+ | otherwise = leaf
+insert (Branch t iu left right) i
+ | iu `subinterval` i = Branch (t `mappend` (measure i)) iu left right
+ | otherwise =
+ let left' = if i `intersects` (interval left) then insert left i else left
+ right' = if i `intersects` (interval right) then insert right i else right
+ in Branch t iu left' right'
+
+-- | Query the segment tree for the specified point. Time: O(log n)
+queryTree :: (Monoid t, Measured (Interval a) t, Ord a) => STree t a -> a -> t
+queryTree t point = go t (R point)
+ where
+ go (Leaf t ivl) point
+ | point `inside` ivl = t
+ | otherwise = mempty
+ go (Branch t ivl left right) point = t `mappend` qleft `mappend` qright
+ where
+ qleft = if point `inside` (interval left) then go left point else mempty
+ qright = if point `inside` (interval right) then go right point else mempty
+
+-- | Convenience wrapper around `queryTree'. Returns count of intervals covering the `point'
+countingQuery :: (Measured (Interval a) (Sum b), Ord a) => STree (Sum b) a -> a -> b
+countingQuery tree point = getSum (queryTree tree point)
+
+-- | Convenience wrapper around `queryTree' to perform stabbing query. Returns list of intevals coverting the point
+stabbingQuery :: (Measured (Interval a) [Interval a], Ord a) => STree [Interval a] a -> a -> [Interval a]
+stabbingQuery = queryTree
+
+-- | Convenience wrapper around `queryTree' to perform stabbing query. Returns set of intevals coverting the point
+-- stabbingSetQuery :: (Measured (Interval a) (Set (Interval a)), Ord a) => STree (Set (Interval a)) a -> a -> Set (Interval a)
+-- stabbingSetQuery = queryTree
diff --git a/src/Data/SegmentTree/Interval.hs b/src/Data/SegmentTree/Interval.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/SegmentTree/Interval.hs
@@ -0,0 +1,64 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Interval
+-- Copyright : (c) Dmitry Astapov 2010
+-- License : BSD-style
+-- Maintainer : dastapov@gmail.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- Simple open and closed intervals
+-----------------------------------------------------------------------------
+
+module Data.SegmentTree.Interval ( R(..)
+ , Interval(..)
+ , Boundary(..)
+ , subinterval, intersects, inside
+ , merge ) where
+
+import Text.Printf
+
+-- | Extension of the type `v' that includes plus and minus infinity
+data R v = MinusInf | R !v | PlusInf deriving (Eq, Ord)
+instance Show v => Show (R v) where
+ show MinusInf = "-Inf"
+ show PlusInf = "+Inf"
+ show (R v) = show v
+
+instance Bounded (R v) where
+ minBound = MinusInf
+ maxBound = PlusInf
+
+-- | An interval. The lower bound should be less than or equal to the higher bound.
+data Boundary = Open | Closed deriving (Eq, Ord)
+data Interval v = Interval { ltype :: ! Boundary
+ , low :: !(R v)
+ , high :: !(R v)
+ , htype :: ! Boundary
+ } deriving (Eq, Ord)
+
+instance Show v => Show (Interval v) where
+ show (Interval o l h c) = printf "%s%s,%s%s" (opening o) (show l) (show h) (closing c)
+ where
+ opening Open = "("
+ opening Closed = "["
+ closing Open = ")"
+ closing Closed = "]"
+
+-- | Checks whether smaller interval is a proper subinterval of a larger interval
+subinterval smaller bigger = low smaller >= low bigger && high smaller <= high bigger
+
+-- | Checks whether two intervals intersect each other
+intersects one two = low one `inside` two || high one `inside` two ||
+ low two `inside` one || high two `inside` one
+
+-- | Checks whether point is inside the interval
+inside p (Interval ltype low high htype) = (cmp ltype) low p && (cmp htype) p high
+ where
+ cmp Open = (<)
+ cmp Closed = (<=)
+
+-- | Merge two intervals that share a common boundary
+merge i1 i2 | i1 <= i2 = Interval (ltype i1) (low i1) (high i2) (htype i2)
+ | otherwise = Interval (ltype i2) (low i2) (high i1) (htype i1)
+
diff --git a/src/Data/SegmentTree/Measured.hs b/src/Data/SegmentTree/Measured.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/SegmentTree/Measured.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Monoid
+-- Copyright : (c) Dmitry Astapov 2010
+-- License : BSD-style
+-- Maintainer : dastapov@gmail.com
+-- Stability : experimental
+-- Portability : non-portable (MPTCs)
+--
+-- Class of types "a" which could be "measured" with values from monoid "t"
+--
+-- Inspired by "Monoids and Finger Trees":
+-- http://apfelmus.nfshost.com/articles/monoid-fingertree.html
+-----------------------------------------------------------------------------
+module Data.SegmentTree.Measured (Measured(..)) where
+
+import Data.Monoid
+
+class Monoid t => Measured a t where
+ measure :: a -> t
+
diff --git a/src/Stabbing/Naive.hs b/src/Stabbing/Naive.hs
new file mode 100644
--- /dev/null
+++ b/src/Stabbing/Naive.hs
@@ -0,0 +1,22 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Squares.BruteForce
+-- Copyright : (c) Dmitry Astapov 2010
+-- License : BSD-style
+-- Maintainer : dastapov@gmail.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- Brute-force stabbing query
+-----------------------------------------------------------------------------
+module Stabbing.Naive (counts) where
+
+import Data.List (genericLength)
+
+-- Naive implementation of stabbing count:
+-- check points against all ranges, count the hits
+counts :: [(Rational, Rational)] -> [Rational] -> [Integer]
+counts ranges points = map (stabCount ranges) points
+ where stabCount ranges point = genericLength $ filter (point `inside`) ranges
+ inside point (lower, upper) = lower <= point && point <= upper
+
diff --git a/src/Stabbing/SegmentTree.hs b/src/Stabbing/SegmentTree.hs
new file mode 100644
--- /dev/null
+++ b/src/Stabbing/SegmentTree.hs
@@ -0,0 +1,27 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Squares.BruteForce
+-- Copyright : (c) Dmitry Astapov 2010
+-- License : BSD-style
+-- Maintainer : dastapov@gmail.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- SegmentTree-based stabbing query
+-----------------------------------------------------------------------------
+module Stabbing.SegmentTree (counts) where
+
+import Data.SegmentTree
+
+-- Optimized stabbing count:
+-- use segment tree parametrized with (Monoid Integer) to count hits for each query point.
+--
+-- For "n" intervals and "m" points:
+-- tree construction takes O(n log n)
+-- each lookup takes O(log n), thus all lookups take O(m log n)
+-- Total complexity: O ((max m n) log n)
+counts :: [(Rational, Rational)] -> [Rational] -> [Integer]
+counts intervals points = map (countingQuery segmentTree) points
+ where
+ segmentTree = fromList intervals
+
diff --git a/src/Tests.hs b/src/Tests.hs
new file mode 100644
--- /dev/null
+++ b/src/Tests.hs
@@ -0,0 +1,74 @@
+import Test.Framework (defaultMain, testGroup)
+import Test.Framework.Providers.HUnit (testCase)
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+
+import Test.QuickCheck
+import Test.HUnit
+
+import Data.List
+
+import qualified Stabbing.Naive as N
+import qualified Stabbing.SegmentTree as ST
+
+main = defaultMain tests
+
+tests = [
+ testGroup "Naive implementation" [
+ testCase "naive_sample" test_naive_sample,
+ testProperty "naive_lower" prop_naive_lower,
+ testProperty "naive_upper" prop_naive_upper,
+ testProperty "naive_center" prop_naive_center
+ ],
+ testGroup "SegmentTree" [
+ testCase "segment_tree_sample" test_segmenttree_sample,
+ testProperty "segment_tree_lower" prop_segmenttree_lower,
+ testProperty "segment_tree_upper" prop_segmenttree_upper,
+ testProperty "segment_tree_center" prop_segmenttree_center
+ ],
+ testGroup "Crosscheck" [
+ testProperty "naive_vs_segmenttree" prop_naive_vs_segmenttree,
+ testProperty "interval_order_oblivious" prop_ivl_order_oblivious,
+ testProperty "point_order_oblivious" prop_pts_order_oblivious
+ ]
+ ]
+
+-- Test sample from the task description
+test_naive_sample = N.counts [(0, 10), (5, 20), (25, 30)] [5, 20, 27, 100] @?= [2, 1, 1, 0]
+test_segmenttree_sample = ST.counts [(0, 10), (5, 20), (25, 30)] [5, 20, 27, 100] @?= [2, 1, 1, 0]
+
+-- List of random intervals could be made from list of random pairs by applying `proper' to them.
+-- `proper' just makes sure that lower bound is <= upper bound for all pairs
+proper = map (\(x,y) -> if x > y then (y,x) else (x,y))
+
+-- Test that point selected from each interval using `pointSelector' scores at least one hit
+prop_at_least_once impl pointSelector pairs =
+ (not (null pairs)) ==>
+ all (>=1) $ impl intervals (map pointSelector intervals)
+ where intervals = proper pairs
+
+-- Test that lower, upper bounds and midpoint of each interval score at least one hit
+prop_naive_lower = prop_at_least_once N.counts fst
+prop_naive_upper = prop_at_least_once N.counts snd
+prop_naive_center = prop_at_least_once N.counts (\(l,u) -> (l+u) / 2)
+prop_segmenttree_lower = prop_at_least_once ST.counts fst
+prop_segmenttree_upper = prop_at_least_once ST.counts snd
+prop_segmenttree_center = prop_at_least_once ST.counts (\(l,u) -> (l+u) / 2)
+
+
+-- Test segment tree against naive implementation
+prop_naive_vs_segmenttree pairs points =
+ (not (null pairs)) ==>
+ N.counts intervals points == ST.counts intervals points
+ where intervals = proper pairs
+
+-- Test that order of intervals does not matter
+prop_ivl_order_oblivious pairs points =
+ (not (null pairs)) ==>
+ N.counts intervals points == ST.counts (reverse intervals) points
+ where intervals = proper pairs
+
+-- Test that order of points does not matter
+prop_pts_order_oblivious pairs points =
+ (not (null pairs)) ==>
+ N.counts intervals points == reverse (ST.counts intervals (reverse points))
+ where intervals = proper pairs