commit 9a7048ffd7414c3761aca294debe103e732a525c Author: Tissevert Date: Sun Sep 15 16:47:29 2019 +0200 Implement first working version with auto-balancing Search Binary Trees diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..eea5c71 --- /dev/null +++ b/.gitignore @@ -0,0 +1,24 @@ +# ---> Haskell +dist +dist-* +cabal-dev +*.o +*.hi +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* + diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..30e68d8 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for RangeMap + +## 0.1.0.0 -- 2019-09-15 + +* First draft, supports insertion and retrieval diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..42f34d0 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Tissevert + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Tissevert nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"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 COPYRIGHT +OWNER OR CONTRIBUTORS 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/RangeMap.cabal b/RangeMap.cabal new file mode 100644 index 0000000..d52a581 --- /dev/null +++ b/RangeMap.cabal @@ -0,0 +1,26 @@ +cabal-version: >=1.10 +-- Initial package description 'RangeMap.cabal' generated by 'cabal init'. +-- For further documentation, see http://haskell.org/cabal/users-guide/ + +name: RangeMap +version: 0.1.0.0 +synopsis: A library to implement a container similar to Data.Map except it associates values to intervals instead of pure keys +-- description: +homepage: https://git.marvid.fr/tissevert/RangeMap +-- bug-reports: +license: BSD3 +license-file: LICENSE +author: Tissevert +maintainer: tissevert+devel@marvid.fr +-- copyright: +category: Data +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: Data.RangeMap + -- other-modules: + -- other-extensions: + build-depends: base >=4.12 && <4.13 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/RangeMap.hs b/src/Data/RangeMap.hs new file mode 100644 index 0000000..fb85b7e --- /dev/null +++ b/src/Data/RangeMap.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Data.RangeMap ( + HalfLine(..) + , RangeMap + , empty + , get + , line + , segment + , set + ) where + +type Color b = Maybe b +data Branch a b = Branch { + lower :: RangeMap a b + , bound :: a + , weight :: Int + , higher :: RangeMap a b + } deriving (Show, Read) + +data RangeMap a b = + Color (Color b) + | Tree (Branch a b) + deriving (Show, Read) + +empty :: RangeMap a b +empty = Color Nothing + +line :: b -> RangeMap a b +line = Color . Just + +get :: Ord a => RangeMap a b -> a -> Maybe b +get (Color color) _ = color +get (Tree (Branch {lower, bound, higher})) key = + get (if key < bound then lower else higher) key + +data HalfLine a = Above a | Below a + +origin :: HalfLine a -> a +origin (Above a) = a +origin (Below a) = a + +set :: Ord a => HalfLine a -> Color b -> RangeMap a b -> RangeMap a b +set halfLine color (Tree branch@(Branch {lower, bound, higher})) = + if origin halfLine < bound + then + let newLower = set halfLine color lower in + Tree $ balance (branch { + lower = newLower + , weight = weight branch + 1 + }) + else + let newHigher = set halfLine color higher in + Tree $ balance (branch { + higher = newHigher + , weight = weight branch + 1 + }) + +set (Above bound) color rangeMap = Tree (Branch { + lower = rangeMap + , bound + , weight = 0 + , higher = Color color + }) + +set (Below bound) color rangeMap = Tree (Branch { + lower = Color color + , bound + , weight = 0 + , higher = rangeMap + }) + +segment :: (a, a) -> b -> RangeMap a b +segment (from, to) b = Tree (Branch { + lower = empty + , bound = from + , weight = 1 + , higher = Tree (Branch { + lower = line b + , bound = to + , weight = 0 + , higher = empty + }) + }) + +popMax :: Branch a b -> ((a, Color b), RangeMap a b) +popMax (Branch {lower, bound, higher = Color color}) = ((bound, color), lower) +popMax branch@(Branch {higher = Tree higherBranch, weight}) = + let (pair, subTree) = popMax higherBranch in + (pair, Tree (branch {higher = subTree, weight = weight - 1})) + +popMin :: Branch a b -> ((a, Color b), RangeMap a b) +popMin (Branch {lower = Color color, bound, higher}) = ((bound, color), higher) +popMin branch@(Branch {lower = Tree lowerBranch, weight}) = + let (pair, subTree) = popMin lowerBranch in + (pair, Tree (branch {lower = subTree, weight = weight - 1})) + +rotateLeft :: Ord a => Branch a b -> Branch a b +rotateLeft branch@(Branch {higher = Color _}) = branch +rotateLeft branch@(Branch {lower, bound, higher = Tree higherBranch}) = + let ((minBound, color), newHigher) = popMin higherBranch in + branch { + lower = set (Above bound) color lower + , bound = minBound + , higher = newHigher + } + +rotateRight :: Ord a => Branch a b -> Branch a b +rotateRight branch@(Branch {lower = Color _}) = branch +rotateRight branch@(Branch {lower = Tree lowerBranch, bound, higher}) = + let ((maxBound, color), newLower) = popMax lowerBranch in + branch { + lower = newLower + , bound = maxBound + , higher = set (Below bound) color higher + } + +getWeight :: RangeMap a b -> Int +getWeight (Tree (Branch {weight})) = weight +getWeight _ = 0 + +balance :: Ord a => Branch a b -> Branch a b +balance branch@(Branch {lower, bound, higher}) + | lowerWeight - higherWeight > 1 = rotateRight branch + | higherWeight - lowerWeight > 1 = rotateLeft branch + | otherwise = branch + where + lowerWeight = getWeight lower + higherWeight = getWeight higher