SegmentTree 0.1 → 0.2

raw patch · 12 files changed

+428/−324 lines, 12 filesdep +HUnitdep +QuickCheckdep +test-frameworkdep ~basesetup-changednew-component:exe:SegmentTreeTestsnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, QuickCheck, test-framework, test-framework-hunit, test-framework-quickcheck2

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Data/SegmentTree.hs +0/−75
• Data/SegmentTree/Examples.hs +0/−73
• LICENSE +24/−162
• README +2/−0
• SegmentTree.cabal +34/−14
• Setup.hs +1/−0
• src/Data/SegmentTree.hs +158/−0
• src/Data/SegmentTree/Interval.hs +64/−0
• src/Data/SegmentTree/Measured.hs +22/−0
• src/Stabbing/Naive.hs +22/−0
• src/Stabbing/SegmentTree.hs +27/−0
• src/Tests.hs +74/−0

@@ -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

@@ -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

@@ -1,165 +1,27 @@-		   GNU LESSER GENERAL PUBLIC LICENSE-                       Version 3, 29 June 2007-- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>- 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. 

@@ -0,0 +1,2 @@+Configure as "cabal configure -ftest" and run "SegmentTreeTests" for+functional test suite.

@@ -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 <dastapov@gmail.com>+Maintainer: Dmitry Astapov <dastapov@gmail.com>+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

@@ -1,2 +1,3 @@+#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain

@@ -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.+--      <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>+--+-- 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

@@ -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)+

@@ -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+

@@ -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+

@@ -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+

@@ -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