Binary tree indexing

benchmark.hs

let lst = foldl (+++) Empty $ map (Single (Size 1)) [1..100000]
let lst = foldl (++++) Empty $ map (Single (Size 1)) [1..100000]

indexJ 0 lst
indexJ 0 lstu

JoinList.hs

import Sized
import Data.Bits
import Debug.Trace
import Data.Maybe

data JoinList m a = Empty
                   | Single m a
                   | Append m (JoinList m a) (JoinList m a)
   deriving (Eq, Show)

instance Sized m => Sized (JoinList m a) where
    size Empty = Size 0
    size (Single s _) = size s
    size (Append s _ _) = size s


tag :: Monoid m => JoinList m a -> m
tag Empty = mempty
tag (Single m a) = m
tag (Append m _ _) = m


boolFromInt :: Int -> Bool
boolFromInt x | x > 0 = True | otherwise = False

isPowerOf2 :: Int -> Bool
isPowerOf2 n | n == 0 = True | otherwise = not . boolFromInt . (.&.) n $ n - 1

(++++) :: (Sized m, Monoid m) => JoinList m a -> JoinList m a -> JoinList m a
(++++) l r = Append (tag l <> tag r) l r

(+++) :: (Sized m, Monoid m) => JoinList m a -> JoinList m a -> JoinList m a
(+++) Empty x = x
(+++) x Empty = x 
(+++) l@(Single _ _) r@(Single _ _) = Append (tag l <> tag r) l r
(+++) l r@Append{} = r +++ l
(+++) l@(Append s xs ys) r  
  | isPowerOf2 . getSize . size $ s = Append (tag l <> tag r) l r
  | otherwise = Append (tag xs <> tag subAppend) xs subAppend
        where subAppend = ys +++ r 

indexJ :: (Sized b, Monoid b) => Int -> JoinList b a -> Maybe a
indexJ _ Empty = Nothing
indexJ i (Single _ x)
    | i /= 0 = Nothing
    | otherwise = Just x
indexJ i (Append s l r)
  | i < sizeLeft = indexJ i l
  | otherwise = indexJ (i - sizeLeft) r
  where sizeRoot = getSize . size $ s
        sizeLeft = getSize . size . tag $ l

(!!?) :: [a] -> Int -> Maybe a 
[] !!? _ = Nothing
_ !!? i | i < 0 = Nothing 
(x:xs) !!? 0 = Just x 
(x:xs) !!? i = trace "iterate" (xs !!? (i-1))

jlToList :: JoinList m a -> [a]
jlToList Empty = []
jlToList (Single _ a) = [a]
jlToList (Append _ l1 l2) = jlToList l1 ++ jlToList l2

Sized.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}
module Sized where

import Data.Monoid

newtype Size = Size Int
  deriving (Eq, Ord, Show, Num)

getSize :: Size -> Int
getSize (Size i) = i

class Sized a where
  size :: a -> Size

instance Sized Size where
  size = id

-- This instance means that things like
--   (Foo, Size)
--   (Foo, (Bar, Size))
--   ...
-- are all instances of Sized.
instance Sized b => Sized (a,b) where
  size = size . snd

instance Semigroup Size where
    (<>) = (+)
instance Monoid Size where
  mempty  = Size 0
  mappend = (<>)