Implement first working version with auto-balancing Search Binary Trees

.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.*
+

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for RangeMap
+
+## 0.1.0.0 -- 2019-09-15
+
+* First draft, supports insertion and retrieval

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.

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

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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