Data structure slides and source code

DenseNat.hs

@@ -0,0 +1,22 @@
+module DenseNat where
+
+data Digit = Zero | One deriving (Show, Ord, Eq, Enum)
+
+type DenseNat = [Digit] -- increasing order of significance
+
+inc :: DenseNat -> DenseNat
+inc []          = [One]
+inc (Zero : ds) = One  : ds
+inc (One  : ds) = Zero : inc ds -- carry
+
+dec :: DenseNat -> DenseNat
+dec [One]       = []
+dec (One  : ds) = Zero : ds
+dec (Zero : ds) = One  : dec ds -- borrow
+
+add :: DenseNat -> DenseNat -> DenseNat
+add ds           []            = ds
+add []           ds            = ds
+add (d    : ds1) (Zero : ds2)  = d    : add ds1 ds2
+add (Zero : ds1) (d    : ds2)  = d    : add ds1 ds2
+add (One  : ds1) (One  : ds2)  = Zero : inc (add ds1 ds2) -- carry

HAMT.hs

@@ -0,0 +1,97 @@
+module HAMT where
+
+import           Data.Bits
+import           Data.Word
+import           Prelude     hiding (lookup, (++))
+
+import           Data.Vector (Vector, singleton, unsafeDrop, unsafeIndex,
+                              unsafeTake, unsafeUpdate, (++))
+
+type Key    = Word
+type Bitmap = Word
+type Shift  = Int
+type Subkey = Int -- we need to use this to do shifts, so an Int it is
+
+data HAMT a = Empty
+            | BitmapIndexed {-# UNPACK #-} !Bitmap !(Vector (HAMT a))
+            | Leaf {-# UNPACK #-} !Key a
+            | Full {-# UNPACK #-} !(Vector (HAMT a))
+    deriving (Show)
+
+
+-- These architecture dependent constants
+
+bitsPerSubkey :: Int
+bitsPerSubkey = floor . logBase 2 . fromIntegral . bitSize $ (undefined :: Word)
+
+subkeyMask :: Bitmap
+subkeyMask = 1 `shiftL` bitsPerSubkey - 1
+
+maskIndex :: Bitmap -> Bitmap -> Int
+maskIndex b m = popCount (b .&. (m - 1))
+
+mask :: Key -> Shift -> Bitmap
+mask k s = shiftL 1 (subkey k s)
+
+{-# INLINE subkey #-}
+subkey :: Key -> Shift -> Int
+subkey k s = fromIntegral $ shiftR k s .&. subkeyMask
+
+empty :: HAMT a
+empty = Empty
+
+lookup :: Key -> HAMT a -> Maybe a
+lookup k t = lookup' k 0 t
+
+lookup' :: Key -> Shift -> HAMT a -> Maybe a
+lookup' k s t
+    = case t of
+        Empty -> Nothing
+        Leaf kx x
+            | k == kx   -> Just x
+            | otherwise -> Nothing
+        BitmapIndexed b v ->
+            let m = mask k s in
+            if b .&. m == 0
+                then Nothing
+                else lookup' k (s+bitsPerSubkey) (unsafeIndex v (maskIndex b m))
+        Full v -> lookup' k (s+bitsPerSubkey) (unsafeIndex v (subkey k s))
+
+insert :: Key -> a -> HAMT a -> HAMT a
+insert k v t = insert' k 0 v t
+
+insert' :: Key -> Shift -> a -> HAMT a -> HAMT a
+insert' kx s x t
+    = case t of
+        Empty -> Leaf kx x
+        Leaf ky y
+            | ky == kx  -> Leaf kx x
+            | otherwise ->
+                insert' kx s x $ BitmapIndexed (mask ky s) (singleton t)
+        BitmapIndexed b v -> {-# SCC "i-Bitmap" #-}
+            let m   = mask kx s
+                i   = maskIndex b m in
+            if b .&. m == 0
+                then let l  = Leaf kx x
+                         v' = unsafeTake i v ++ singleton l ++ unsafeDrop i v
+                         b' = b .|. m in
+                     if b' == 0xFFFFFFFF
+                        then Full v'
+                        else BitmapIndexed b' v'
+                else {-# SCC "i-Bitmap-conflict" #-}
+                    let  st  = unsafeIndex v i
+                         st' = insert' kx (s+bitsPerSubkey) x st
+                         v'  = {-# SCC "i-Bitmap-update" #-}
+                               unsafeUpdate v (singleton (i, st'))
+                     in BitmapIndexed b v'
+        Full v -> {-# SCC "i-Full" #-}
+            let i   = subkey kx s
+                st  = unsafeIndex v i
+                st' = insert' kx (s+bitsPerSubkey) x st
+                v'  = {-# SCC "i-Full-update" #-}
+                      unsafeUpdate v (singleton (i, st'))
+            in Full v'
+
+-- lazy, but that's not necessarily a bad thing
+fromList :: [(Key, a)] -> HAMT a
+fromList = foldl (flip $ uncurry insert) empty

HON.hs

@@ -0,0 +1,216 @@
+module HigherOrderNested where
+
+{- Start with a standard data type
+data Nat = Zero
+         | Succ Nat
+  deriving (Eq, Show)
+-}
+
+-- Decompose it into separate types
+data Zero     = NZero
+  deriving (Eq, Show)
+
+data Succ nat = Succ nat
+  deriving (Eq, Show)
+
+-- And define a nested combining type
+data Nats nat = NNil
+              | NCons nat (Nats (Succ nat))
+  deriving (Eq, Show)
+
+{- Some examples of instances of this type:
+NCons NZero NNil
+NCons NZero (NCons (Succ NZero) NNil)
+NCons NZero (NCons (Succ NZero) (NCons (Succ (Succ NZero)) NNil))
+-}
+
+{- The Stack type, analogous to Nat
+data Stack a = Empty
+             | Push a (Stack a)
+  deriving (Eq, Show)
+-}
+
+-- Decompose to separate types
+data Empty a        = Empty
+  deriving (Eq, Show)
+
+data Push stack a   = Push a (stack a)
+  deriving (Eq, Show)
+
+-- Define a nested combining type
+data Stacks stack a = SNil
+                    | SCons (stack a) (Stacks (Push stack) a)
+  deriving (Eq, Show)
+
+{- Some examples:
+SCons Empty SNil
+SCons Empty (SCons (Push 'a' Empty) SNil)
+SCons Empty (SCons (Push 'a' Empty) (SCons (Push 'a' (Push 'b' Empty)) SNil))
+-}
+
+{- Perfect Binary Leaf Trees
+data Bush a = Leaf a
+            | Fork (Bush a) (Bush a)
+  deriving (Eq, Show)
+-}
+
+-- Decomposed Perfect Binary Leaf Trees
+data Leaf a      = Leaf a
+  deriving (Eq, Show)
+data Fork bush a = Fork (bush a) (bush a)
+  deriving (Eq, Show)
+
+{- Uses a zeroless 1-2 representation to eliminate overhead of numerical
+   nodes with no data.
+
+   Counting: 1, 2, 11, 21, 12, 22, 111, 211, 121, 221, 112, 212, 122, 222
+
+   Note that only the first One constructor can directly store the
+   Leaf type; all others will use Fork^n Leaf, which guarantees that
+   our "Perfect" invariant holds.
+
+   Each recursive instantiation of the type occurs with another level
+   of Fork wrapping the bush type; One uses that level directly, while
+   Two adds an extra Fork level to it.
+-}
+data RandomAccessList bush a
+   = Nil
+   | One (bush a) (RandomAccessList (Fork bush) a)
+   | Two (Fork bush a) (RandomAccessList (Fork bush) a)
+  deriving (Eq, Show)
+
+type IxSequence = RandomAccessList Leaf
+
+-- Consing to the front increments the number with a Leaf as data
+cons :: a -> IxSequence a -> IxSequence a
+cons a = incr (Leaf a)
+
+incr :: bush a
+     -> RandomAccessList bush a
+     -> RandomAccessList bush a
+incr b  Nil         = One b Nil           -- inc 0    = 1
+incr b1 (One b2 ds) = Two (Fork b1 b2) ds -- inc 1..  = 2..
+incr b1 (Two b2 ds) = One b1 (incr b2 ds) -- inc 2d.. = 1(inc d)..
+
+-- This is used to eliminate leading zeros
+zero :: RandomAccessList (Fork bush) a
+     -> RandomAccessList bush a
+zero Nil                   = Nil                -- 0    = 0
+zero (One b ds)            = Two b  (zero ds)   -- 01.. = 20.
+zero (Two (Fork b1 b2) ds) = Two b1 (One b2 ds) -- 02.. = 21.
+
+-- Removing from the front decrements the number and removes a Leaf
+front :: IxSequence a -> (a, IxSequence a)
+front Nil                        = error "IxSequence empty"
+front (One (Leaf a) ds)          = (a, zero ds)  -- dec 1.. = 0..
+front (Two (Fork (Leaf a) b) ts) = (a, One b ts) -- dec 2.. = 1..
+
+fromList :: [a] -> IxSequence a
+fromList = foldr cons Nil
+
+{- A recursive (top-down) solution
+unleaf :: Leaf a -> [a]
+unleaf (Leaf a) = [a]
+
+unfork :: (bush a -> [a]) -> Fork bush a -> [a]
+unfork flatten (Fork l r) = flatten l ++ flatten r
+
+listify :: (bush a -> [a]) -> RandomAccessList bush a -> [a]
+listify _       Nil        = []
+listify flatten (One b ds) = flatten b ++ listify (unfork flatten) ds
+listify flatten (Two b ds) = unfork flatten b ++ listify (unfork flatten) ds
+
+toList :: IxSequence a -> [a]
+toList = listify unleaf
+-}
+
+{- A recursive (top-down) solution with Type Classes
+class Flatten bush where
+  flatten :: bush a -> [a]
+
+instance Flatten Leaf where
+  flatten (Leaf a) = [a]
+
+instance (Flatten bush) => Flatten (Fork bush) where
+  flatten (Fork l r) = flatten l ++ flatten r
+
+listify :: (Flatten bush) => RandomAccessList bush a -> [a]
+listify Nil = []
+listify (One b ds) = flatten b ++ listify ds
+listify (Two b ds) = flatten b ++ listify ds
+
+toList :: IxSequence a -> [a]
+toList = listify
+-}
+
+{- An iterative (bottom-up) solution; linear time bound -}
+listify :: RandomAccessList bush a -> [bush a]
+listify Nil = []
+listify (One b ds) = b : unforks (listify ds)
+listify (Two b ds) = unforks (b : listify ds)
+
+unforks :: [Fork bush a] -> [bush a]
+unforks [] = []
+unforks (Fork b1 b2 : ts) = b1 : b2 : unforks ts
+
+toList :: IxSequence a -> [a]
+toList s = [a | Leaf a <- listify s]
+
+{- Examples:
+
+> fromList[1..5]
+One (Leaf 1)
+    (Two (Fork (Fork (Leaf 2) (Leaf 3))
+               (Fork (Leaf 4) (Leaf 5)))
+         Nil)
+
+12 = 1*1 + 2*2 = 1 + 4 = 5
+
+> fromList [1..20]
+Two (Fork (Leaf 1) (Leaf 2))                                 -- 0, 1
+    (One (Fork (Leaf 3) (Leaf 4))                            -- 2, 3
+         (Two (Fork (Fork (Fork (Leaf 5)  (Leaf 6))          -- 4, 11
+                          (Fork (Leaf 7)  (Leaf 8)))
+                    (Fork (Fork (Leaf 9)  (Leaf 10))
+                          (Fork (Leaf 11) (Leaf 12))))
+              (One  (Fork (Fork (Fork (Leaf 13) (Leaf 14))   -- 12, 19
+                                (Fork (Leaf 15) (Leaf 16)))
+                          (Fork (Fork (Leaf 17) (Leaf 18))
+                                (Fork (Leaf 19) (Leaf 20))))
+                    Nil)))
+
+2121 = 2*1 + 1*2 + 2*4 + 1*8 = 2 + 2 + 8 + 8 = 20
+
+tree size at each rank is d*2^r
+
+-}
+
+{-
+Searching:
+
+lookup 0 (One (Leaf x) _) = x
+lookup 0 (One (Fork t1 t2) ds) = lookup 0 (One )
+
+-}
+
+class FindB bush where
+  findB :: Int -> Int -> bush a -> a
+instance FindB Leaf where
+  findB _ _ (Leaf x) = x
+instance (FindB bush) => FindB (Fork bush) where
+  findB i s (Fork lb rb)
+     | i < s`div`2 = findB i (s`div`2) lb
+     | otherwise   = findB i (s`div`2) rb
+
+find :: Int -> IxSequence a -> a
+find = find' 0
+
+find' :: (FindB bush) => Int -> Int
+     -> RandomAccessList bush a -> a
+find' _ _ Nil   = error "Not found"
+find' r i (One b ds)
+   | i < 2^r   = findB i (2^r) b
+   | otherwise = find' (i-2^r) (r+1) ds
+find' r i (Two b ds)
+   | i < 2*2^r = findB i (2*2^r) b
+   | otherwise = find' (i-2*2^r) (r+1) ds

Nested.hs

@@ -0,0 +1,31 @@
+module Nested where
+
+data Fork t = Fork t t
+  deriving (Show, Eq)
+
+data RandList t = Nil
+                | Zero  (RandList (Fork t))
+                | One t (RandList (Fork t))
+  deriving (Show, Eq)
+
+cons :: a -> RandList a -> RandList a
+cons x  Nil         = One x Nil
+cons x1 (Zero ds)   = One x1 ds
+cons x1 (One x2 ds) = Zero (cons (Fork x1 x2) ds)
+
+front :: RandList a -> (a, RandList a)
+front Nil = error "Empty RandList"
+front (One x Nil) = (x,  Nil)
+front (One x ds)  = (x,  Zero ds)
+front (Zero ds)   = (x1, One x2 ds')
+  where (Fork x1 x2, ds') = front ds
+
+find :: Int -> RandList a -> a
+find 0 Nil = error "Not found"
+find 0 (One x _)  = x
+find i (One _ ds) = find (i-1) (Zero ds)
+find i (Zero ds)  = if i`mod`2 == 0 then x else y
+  where (Fork x y) = find (i`div`2) ds
+
+fromList :: [a] -> RandList a
+fromList = foldr cons Nil

Queue1.hs

@@ -0,0 +1,22 @@
+module Queue1 where
+
+import           StrictList as L
+
+data Queue a = Q { left     :: StrictList a
+                 , leftLen  :: !Int
+                 , right    :: StrictList a
+                 , rightLen :: !Int
+                 } deriving (Show, Eq)
+
+empty :: Queue a
+empty = Q Empty 0 Empty 0
+
+length :: Queue a -> Int
+length (Q _ ll _ rl) = ll + rl
+
+insert :: a -> Queue a -> Queue a
+insert e (Q l ll r rl) = Q l ll (e :$ r) (rl + 1)
+
+remove :: Queue a -> (a, Queue a)
+remove (Q Empty _  r rl) = remove (Q (L.reverse r) rl Empty 0)
+remove (Q l     ll r rl) = (L.head l, Q (L.tail l) (ll - 1) r rl)

Queue2.hs

@@ -0,0 +1,33 @@
+module Queue2 where
+
+import           Prelude hiding (length)
+
+-- Invariant:  |R| <= |L|
+-- Invariant is preserved via the makeQ function
+
+data Queue a = Q { left     :: [a]
+                 , leftLen  :: !Int
+                 , right    :: [a]
+                 , rightLen :: !Int
+                 } deriving (Show, Eq)
+
+empty :: Queue a
+empty = Q [] 0 [] 0
+
+length :: Queue a -> Int
+length (Q _ ll _ rl) = ll + rl
+
+insert :: a -> Queue a -> Queue a
+insert e (Q l ll r rl) = makeQ (Q l ll (e : r) (rl + 1))
+
+remove :: Queue a -> (a, Queue a)
+remove (Q l ll r rl) = (head l, makeQ (Q (tail l) (ll - 1) r rl))
+
+makeQ :: Queue a -> Queue a
+makeQ q@(Q l ll r rl)
+  | rl <= ll  = q
+  | otherwise = Q (rot l r []) (ll + rl) [] 0
+
+rot :: [a] -> [a] -> [a] -> [a]
+rot [] r a = head r : a
+rot l  r a = head l : rot (tail l) (tail r) (head r : a)

Queue2.txt

@@ -0,0 +1,55 @@
+--Load Queue2.hs - lazy rebuilding queue
+:l Queue2.hs
+
+--Start ghc-vis
+:vis
+
+let x = empty
+:view x
+
+--Insert a value - view new queue; we already triggered the reverse
+let y = insert 1 x
+:view y
+
+--Remove the value - forces the evaluation in y, but we discard the new tree
+let (z,_) = remove y
+print z
+:update
+
+--Add another element to y; now there's one in the right list
+let a = insert 2 y
+:view a
+
+--Add one more, and we trigger the swap again
+let b = insert 3 a
+:view b
+
+--We can add 3 more and still not swap
+let c = insert 6 $ insert 5 $ insert 4 b
+:view c
+
+--One more, and now we trigger the swap
+let d = insert 7 c
+:view d
+
+--Let's remove one by one and see how evaluation progresses
+let (e,f) = remove d
+print e
+:view f
+
+let (g,h) = remove f
+print g
+:view h
+
+let (i,j) = remove h
+print i
+:view j
+
+let (k,l) = remove j
+print k
+:view l
+
+let (m,n) = remove l
+print m
+:view n
+

Queue3.hs

@@ -0,0 +1 @@
+module Queue3 where

RB1.hs

@@ -0,0 +1,81 @@
+module RedBlack1 where
+
+{- Version 1, 'untyped' -}
+data Color = R | B deriving Show
+data RB a = E | T Color (RB a) a (RB a) deriving Show
+
+{- Insertion and membership test as by Okasaki -}
+insert :: Ord a => a -> RB a -> RB a
+insert x s =
+  T B a z b
+  where
+    T _ a z b = ins s
+    ins E = T R E x E
+    ins s'@(T B a' y b')
+      | x<y = balance (ins a') y b'
+      | x>y = balance a' y (ins b')
+      | otherwise = s'
+    ins s'@(T R a' y b')
+      | x<y = T R (ins a') y b'
+      | x>y = T R a' y (ins b')
+      | otherwise = s'
+
+member :: Ord a => a -> RB a -> Bool
+member _ E = False
+member x (T _ a y b)
+  | x < y = member x a
+  | x > y = member x b
+  | otherwise = True
+
+{- balance: first equation is new,
+   to make it work with a weaker invariant -}
+balance :: RB a -> a -> RB a -> RB a
+balance (T R a x b) y (T R c z d) = T R (T B a x b) y (T B c z d)
+balance (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d)
+balance (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d)
+balance a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d)
+balance a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d)
+balance a x b = T B a x b
+
+{- deletion a la SMK -}
+delete :: Ord a => a -> RB a -> RB a
+delete x t =
+  case del t of {T _ a y b -> T B a y b; _ -> E}
+  where
+    del E = E
+    del (T _ a y b)
+      | x<y = delformLeft a y b
+      | x>y = delformRight a y b
+      | otherwise = app a b
+    delformLeft a@(T B _ _ _) y b = balleft (del a) y b
+    delformLeft a y b = T R (del a) y b
+    delformRight a y b@(T B _ _ _) = balright a y (del b)
+    delformRight a y b = T R a y (del b)
+
+balleft :: RB a -> a -> RB a -> RB a
+balleft (T R a x b) y c = T R (T B a x b) y c
+balleft bl x (T B a y b) = balance bl x (T R a y b)
+balleft bl x (T R (T B a y b) z c) = T R (T B bl x a) y (balance b z (sub1 c))
+
+balright :: RB a -> a -> RB a -> RB a
+balright a x (T R b y c) = T R a x (T B b y c)
+balright (T B a x b) y bl = balance (T R a x b) y bl
+balright (T R a x (T B b y c)) z bl = T R (balance (sub1 a) x b) y (T B c z bl)
+
+sub1 :: RB a -> RB a
+sub1 (T B a x b) = T R a x b
+sub1 _ = error "invariance violation"
+
+app :: RB a -> RB a -> RB a
+app E x = x
+app x E = x
+app (T R a x b) (T R c y d) =
+  case app b c of
+    T R b' z c' -> T R(T R a x b') z (T R c' y d)
+    bc -> T R a x (T R bc y d)
+app (T B a x b) (T B c y d) =
+  case app b c of
+    T R b' z c' -> T R(T B a x b') z (T B c' y d)
+    bc -> balleft a x (T B bc y d)
+app a (T R b x c) = T R (app a b) x c
+app (T R a x b) c = T R a x (app b c)

RB2.hs

@@ -0,0 +1,179 @@
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module RedBlack2 where
+
+data Unit a = E deriving Show
+type Tr t a = (t a,a,t a)
+data Red t a = C (t a) | R (Tr t a)
+
+instance (Show (t a), Show a) => Show (Red t a)
+ where showsPrec _ (C t) = shows t
+       showsPrec _ (R(a,b,c)) =
+         ("R("++) . shows a . (","++) . shows b . (","++) . shows c . (")"++)
+
+data AddLayer t a = B(Tr(Red t) a) deriving Show
+
+data RB t a = Base (t a) | Next (RB (AddLayer t) a)
+
+instance (Show (t a),Show a) => Show (RB t a)
+    where
+    show (Base t) = show t
+    show (Next t) = show t
+
+type Tree a = RB Unit a
+empty :: Tree a
+empty = Base E
+
+type RR t a = Red (Red t) a
+type RL t a = Red (AddLayer t) a
+
+member :: Ord a => a -> Tree a -> Bool
+member x t = rbmember x t (const False)
+
+rbmember :: Ord a => a -> RB t a -> (t a->Bool) -> Bool
+rbmember _ (Base t) m = m t
+rbmember x (Next u) m = rbmember x u (bmem x m)
+
+bmem :: Ord a => a -> (t a->Bool) -> AddLayer t a -> Bool
+bmem x m (B(l,y,r))
+ | x<y = rmem x m l
+ | x>y = rmem x m r
+ | otherwise = True
+
+rmem :: Ord a => a -> (t a->Bool) -> Red t a->Bool
+rmem _ m (C t) = m t
+rmem x m (R(l,y,r))
+ | x<y = m l
+ | x>y = m r
+ | otherwise = True
+
+insert :: Ord a => a -> Tree a -> Tree a
+insert = rbinsert
+
+class Insertion t where ins :: Ord a => a -> t a -> Red t a
+instance Insertion Unit where ins x E = R(E,x,E)
+
+rbinsert :: (Ord a,Insertion t) => a -> RB t a -> RB t a
+rbinsert x (Next t) = Next (rbinsert x t)
+rbinsert x (Base t) = blacken(ins x t)
+
+blacken :: Red t a -> RB t a
+blacken (C u) = Base u
+blacken (R(a,x,b)) = Next(Base(B(C a,x,C b)))
+
+balanceL :: RR t a -> a -> Red t a -> RL t a
+balanceL (R(R(a,x,b),y,c)) z d = R(B(C a,x,C b),y,B(c,z,d))
+balanceL (R(a,x,R(b,y,c))) z d = R(B(a,x,C b),y,B(C c,z,d))
+balanceL (R(C a,x,C b)) z d = C(B(R(a,x,b),z,d))
+balanceL (C a) x b = C(B(a,x,b))
+
+balanceR :: Red t a -> a -> RR t a -> RL t a
+balanceR a x (R(R(b,y,c),z,d)) = R(B(a,x,C b),y,B(C c,z,d))
+balanceR a x (R(b,y,R(c,z,d))) = R(B(a,x,b),y,B(C c,z,C d))
+balanceR a x (R(C b,y,C c)) = C(B(a,x,R(b,y,c)))
+balanceR a x (C b) = C(B(a,x,b))
+
+instance Insertion t => Insertion (AddLayer t) where
+  ins x t@(B(l,y,r))
+    | x<y = balance(ins x l) y (C r)
+    | x>y = balance(C l) y (ins x r)
+    | otherwise = C t
+instance Insertion t => Insertion (Red t) where
+  ins x (C t) = C(ins x t)
+  ins x t@(R(a,y,b))
+    | x<y = R(ins x a,y,C b)
+    | x>y = R(C a,y,ins x b)
+    | otherwise = C t
+
+balance :: RR t a -> a -> RR t a -> RL t a
+balance (R a) y (R b) = R(B a,y,B b)
+balance (C a) x b = balanceR a x b
+balance a x (C b) = balanceL a x b
+
+class Append t where app :: t a -> t a -> Red t a
+
+instance Append Unit where app _ _ = C E
+
+instance Append t => Append (AddLayer t) where
+    app (B(a,x,b)) (B(c,y,d)) = threeformB a x (appRed b c) y d
+
+threeformB :: Red t a -> a -> RR t a -> a -> Red t a -> RL t a
+threeformB a x (R(b,y,c)) z d = R(B(a,x,b),y,B(c,z,d))
+threeformB a x (C b) y c = balleftB (C a) x (B(b,y,c))
+
+appRed :: Append t => Red t a -> Red t a -> RR t a
+appRed (C x) (C y) = C(app x y)
+appRed (C t) (R(a,x,b)) = R(app t a,x,C b)
+appRed (R(a,x,b)) (C t) = R(C a,x,app b t)
+appRed (R(a,x,b))(R(c,y,d)) = threeformR a x (app b c) y d
+
+threeformR:: t a -> a -> Red t a -> a -> t a -> RR t a
+threeformR a x (R(b,y,c)) z d = R(R(a,x,b),y,R(c,z,d))
+threeformR a x (C b) y c = R(R(a,x,b),y,C c)
+
+balleft :: RR t a -> a -> RL t a -> RR (AddLayer t) a
+balleft (R a) y c = R(C(B a),y,c)
+balleft (C t) x (R(B(a,y,b),z,c)) = R(C(B(t,x,a)),y,balleftB (C b) z c)
+balleft b x (C t) = C (balleftB b x t)
+
+balleftB :: RR t a -> a -> AddLayer t a -> RL t a
+balleftB bl x (B y) = balance bl x (R y)
+
+balright :: RL t a -> a -> RR t a -> RR (AddLayer t) a
+balright a x (R b) = R(a,x,C(B b))
+balright (R(a,x,B(b,y,c))) z (C d) = R(balrightB a x (C b),y,C(B(c,z,d)))
+balright (C t) x b = C (balrightB t x b)
+
+balrightB :: AddLayer t a -> a -> RR t a -> RL t a
+balrightB (B y) = balance (R y)
+
+class Append t => DelRed t where
+  delTup :: Ord a => a -> Tr t a -> Red t a
+  delLeft :: Ord a => a -> t a -> a -> Red t a -> RR t a
+  delRight :: Ord a => a -> Red t a -> a -> t a -> RR t a
+
+class Append t => Del t where
+  del :: Ord a => a -> AddLayer t a -> RR t a
+
+class (DelRed t, Del t) => Deletion t
+
+instance DelRed Unit where
+  delTup z t@(_,x,_) = if x==z then C E else R t
+  delLeft  _ _ y b = R(C E,y,b)
+  delRight _ a y _ = R(a,y,C E)
+
+instance Deletion t => DelRed (AddLayer t) where
+  delTup z (a,x,b)
+    | z<x = balleftB (del z a) x b
+    | z>x = balrightB a x (del z b)
+    | otherwise = app a b
+  delLeft  x a     = balleft (del x a)
+  delRight x a y b = balright a y (del x b)
+
+instance DelRed t => Del t where
+  del z (B(a,x,b))
+    | z<x = delformLeft a
+    | z>x = delformRight b
+    | otherwise = appRed a b
+    where delformLeft(C t) = delLeft z t x b
+          delformLeft(R t) = R(delTup z t,x,b)
+          delformRight(C t) = delRight z a x t
+          delformRight(R t) = R(a,x,delTup z t)
+
+instance Deletion t => Deletion (AddLayer t)
+instance Deletion Unit
+
+rbdelete :: (Ord a,Deletion t) => a -> RB (AddLayer t) a -> RB t a
+rbdelete x (Next t) = Next (rbdelete x t)
+rbdelete x (Base t) = blacken2 (del x t)
+
+blacken2 :: RR t a -> RB t a
+blacken2 (C(C t)) = Base t
+blacken2 (C(R(a,x,b))) = Next(Base(B(C a,x,C b)))
+blacken2 (R p) = Next(Base(B p))
+
+delete:: Ord a => a -> Tree a -> Tree a
+delete x (Next u) = rbdelete x u
+delete _ _ = empty

RB3.hs

@@ -0,0 +1,204 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts          #-}
+{-# LANGUAGE RankNTypes                #-}
+
+module RedBlack3 where
+
+type Tr  t a b = (t a b, a, t a b)
+data Red t a b = C (t a b) | R (Tr t a b)
+data Black a b = E | B (Tr (Red Black) a [b])
+
+instance Show a => Show (Black a b) where
+    showsPrec _ E             = ('E':)
+    showsPrec _ (B (a, x, b)) = ("B(" ++) . showRed a . ("," ++) . shows x .
+                                ("," ++)  . showRed b . (")" ++)
+
+showRed :: forall t a b. (Show (t a b), Show a)
+        => Red t a b
+        -> ShowS
+showRed (C x)         = shows x
+showRed (R (a, x, b)) = ("R(" ++) . shows a . ("," ++) . shows x . ("," ++) .
+                         shows b . (")" ++)
+
+type RR a b = Red (Red Black) a b
+
+inc :: Black a b
+    -> Black a [b]
+inc = tickB
+
+{- tickB is the identity,
+   but it allows us to replace that bogus type variable -}
+
+tickB :: Black a b
+      -> Black a c
+tickB E             = E
+tickB (B (a, x, b)) = B (tickR a, x, tickR b)
+
+tickR :: Red Black a b
+      -> Red Black a c
+tickR (C t)         = C (tickB t)
+tickR (R (a, x, b)) = R (tickB a, x, tickB b)
+
+data Tree a = forall b . ENC (Black a b)
+
+instance Show a => Show (Tree a)
+    where show (ENC t) = show t
+
+empty :: Tree a
+empty = ENC E
+
+insert :: Ord a
+       => a
+       -> Tree a
+       -> Tree a
+insert x (ENC t) = ENC (blacken (insB x t))
+
+blacken :: Red Black a b
+        -> Black a b
+blacken (C u)         = u
+blacken (R (a, x, b)) = B (C (inc a), x, C (inc b))
+
+insB :: Ord a
+     => a
+     -> Black a b
+     -> Red Black a b
+insB x   E      = R (E, x, E)
+insB x t@(B (a, y, b))
+    | x < y     = balanceL (insR x a) y b
+    | x > y     = balanceR a          y (insR x b)
+    | otherwise = C t
+
+insR :: Ord a
+     => a
+     -> Red Black a b
+     -> RR a b
+insR x   (C t)    = C (insB x t)
+insR x t@(R (a, y, b))
+    | x < y     = R (insB x a, y, C b)
+    | x > y     = R (C a, y, insB x b)
+    | otherwise = C t
+
+balanceL :: RR a [b]
+         -> a
+         -> Red Black a [b]
+         -> Red Black a b
+balanceL (R (R (a, x, b), y, c)) z d = R (B (C a, x, C b), y, B (c, z, d))
+balanceL (R (a, x, R (b, y, c))) z d = R (B (a, x, C b), y, B (C c, z, d))
+balanceL (R (C a, x, C b))       z d = C (B (R (a, x, b), z, d))
+balanceL (C a)                   x b = C (B (a, x, b))
+
+balanceR :: Red Black a [b]
+         -> a
+         -> RR a [b]
+         -> Red Black a b
+balanceR a x (R (R (b, y, c), z, d)) = R (B (a, x, C b), y, B (C c, z, d))
+balanceR a x (R (b, y, R (c, z, d))) = R (B (a, x, b), y, B (C c, z, C d))
+balanceR a x (R (C b, y, C c))       = C (B (a, x, R (b, y, c)))
+balanceR a x (C b)                   = C (B (a, x, b))
+
+delete :: Ord a
+       => a
+       -> Tree a
+       -> Tree a
+delete x (ENC t) =
+    case delB x t of
+        R p              -> ENC (B p)
+        C (R (a, x', b)) -> ENC (B (C a, x', C b))
+        C (C q)          -> ENC q
+
+delB :: Ord a
+     => a
+     -> Black a b
+     -> RR a [b]
+delB _ E        = C (C E)
+delB x (B (a, y, b))
+    | x < y     = delfromL a
+    | x > y     = delfromR b
+    | otherwise = appendR a b
+  where delfromL (R t) = R (delT x t, y, b)
+        delfromL (C E) = R (C E, y, b)
+        delfromL (C t) = balL (delB x t) y b
+        delfromR (R t) = R (a, y, delT x t)
+        delfromR (C E) = R (a, y, C E)
+        delfromR (C t) = balR a y (delB x t)
+
+delT :: Ord a
+     => a
+     -> Tr Black a b
+     -> Red Black a b
+delT x t@(a,y,b)
+    | x < y     = delfromL a
+    | x > y     = delfromR b
+    | otherwise = append a b
+  where delfromL (B _) = balLeB (delB x a) y b
+        delfromL _     = R t
+        delfromR (B _) = balRiB a y (delB x b)
+        delfromR _     = R t
+
+balLeB :: RR a [b]
+       -> a
+       -> Black a b
+       -> Red Black a b
+balLeB bl x (B y) = balance bl x (R y)
+
+balRiB :: Black a b
+       -> a
+       -> RR a [b]
+       -> Red Black a b
+balRiB (B y) = balance (R y)
+
+balL :: RR a [b]
+     -> a
+     -> Red Black a b
+     -> RR a b
+balL (R a) y c                       = R (C (B a), y, c)
+balL (C t) x (R (B (a, y, b), z, c)) = R (C (B (t, x, a)), y, balLeB (C b) z c)
+balL b     x (C t)                   = C (balLeB b x t)
+
+balR :: Red Black a b
+     -> a
+     -> RR a [b]
+     -> RR a b
+balR a                       x (R b) = R (a, x, C (B b))
+balR (R (a, x, B (b, y, c))) z (C d) = R (balRiB a x (C b), y, C (B (c, z, d)))
+balR (C t)                   x b     = C (balRiB t x b)
+
+balance :: RR a [b]
+        -> a
+        -> RR a [b]
+        -> Red Black a b
+balance (R a) y (R b) = R (B a, y, B b)
+balance (C a) x b     = balanceR a x b
+balance a     x (C b) = balanceL a x b
+
+append :: Black a b
+       -> Black a b
+       -> Red Black a b
+append (B (a, x, b)) (B (c, y, d)) = threeformB a x (appendR b c) y d
+append _             _             = C E
+
+threeformB :: Red Black a [b]
+           -> a
+           -> RR a [b]
+           -> a
+           -> Red Black a [b]
+           -> Red Black a b
+threeformB a x (R (b, y, c)) z d = R (B (a, x, b), y, B (c, z, d))
+threeformB a x (C b) y c = balLeB (C a) x (B (b, y, c))
+
+appendR :: Red Black a b
+        -> Red Black a b
+        -> RR a b
+appendR (C x) (C y)                 = C (append x y)
+appendR (C t) (R (a, x, b))         = R (append t a, x, C b)
+appendR (R (a, x, b)) (C t)         = R (C a, x, append b t)
+appendR (R (a, x, b)) (R (c, y, d)) = threeformR a x (append b c) y d
+
+threeformR :: Black a b
+           -> a
+           -> Red Black a b
+           -> a
+           -> Black a b
+           -> RR a b
+threeformR a x (R (b, y, c)) z d = R (R (a, x, b), y, R (c, z, d))
+threeformR a x (C b) y c         = R (R (a, x, b), y, C c)

RB4.hs

@@ -0,0 +1,131 @@
+{-# LANGUAGE DataKinds                 #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE GADTs                     #-}
+{-# LANGUAGE KindSignatures            #-}
+{-# LANGUAGE RankNTypes                #-}
+{-# LANGUAGE StandaloneDeriving        #-}
+
+module RedBlackTree where
+
+data Nat = Zero | Succ Nat deriving (Eq, Ord, Show)
+type One = Succ Zero
+
+data RedBlack = Black | Red deriving (Eq, Ord, Show)
+
+-- red-black trees are rooted at a black node
+data RedBlackTree a = forall n. T (Node Black n a)
+deriving instance Show a => Show (RedBlackTree a)
+
+-- all paths from a node to a leaf have exactly n black nodes
+data Node :: RedBlack -> Nat -> * -> * where
+  -- all leafs are black
+  Leaf  :: Node Black One a
+  -- internal black nodes can have children of either color
+  B     :: Node cL    n a -> a -> Node cR    n a -> Node Black (Succ n) a
+  -- internal red nodes can only have black children
+  R     :: Node Black n a -> a -> Node Black n a -> Node Red   n        a
+deriving instance Show a => Show (Node c n a)
+
+-- one-hole context for red-black trees
+data Context :: Nat -> RedBlack -> Nat -> * -> * where
+  -- if we're at the root, the hole is a black node
+  Root :: Context n Black n a
+  -- we can go left or right from a red node hole, creating a hole for a black node
+  BC   :: Bool -> a -> Node Black n a -> Context m Red   n        a -> Context m Black n a
+  -- we can go left or right from a black node hole, creating a hole for either
+  EC   :: Bool -> a -> Node cY    n a -> Context m Black (Succ n) a -> Context m cX    n a
+
+data Zipper m a = forall c n. Zipper (Node c n a) (Context m c n a)
+
+-- create a zipper
+unZip :: Node Black n a -> Zipper n a
+unZip = flip Zipper Root
+
+-- destroy a zipper
+zipUp :: Zipper m a -> Node Black m a
+zipUp (Zipper x Root)              = x
+zipUp (Zipper x (BC goLeft a y c)) = zipUp $ Zipper (if goLeft then R x a y else R y a x) c
+zipUp (Zipper x (EC goLeft a y c)) = zipUp $ Zipper (if goLeft then B x a y else B y a x) c
+
+-- locate the node that should contain a in the red-black tree
+zipTo :: Ord a => a -> Zipper n a -> Zipper n a
+zipTo _ z@(Zipper Leaf _)       = z
+zipTo a z@(Zipper (R l a' r) c) = case compare a a' of
+  EQ -> z
+  LT -> zipTo a $ Zipper l (BC True  a' r c)
+  GT -> zipTo a $ Zipper r (BC False a' l c)
+zipTo a z@(Zipper (B l a' r) c) = case compare a a' of
+  EQ -> z
+  LT -> zipTo a $ Zipper l (EC True  a' r c)
+  GT -> zipTo a $ Zipper r (EC False a' l c)
+
+-- create a red-black tree
+empty :: RedBlackTree a
+empty = T Leaf
+
+-- insert a node into a red-black tree
+-- (see http://en.wikipedia.org/wiki/Red%E2%80%93black_tree#Insertion)
+insert :: Ord a => a -> RedBlackTree a -> RedBlackTree a
+insert a t@(T root) = case zipTo a (unZip root) of
+    -- find matching leaf and replace with red node (pointing to two leaves)
+    Zipper Leaf c -> insertAt (R Leaf a Leaf) c
+    -- if it's already in the tree, there's no need to modify it
+    _             -> t
+
+insertAt :: Node Red n a -> Context m c n a -> RedBlackTree a
+-- 1) new node is root => paint it black and done
+insertAt (R l a r) Root                                     = T $ B l a r
+-- 2) new node's parent is black => done
+insertAt x         (EC b a y c)                             = T . zipUp $ Zipper x (EC b a y c)
+-- 3) uncle is red => paint parent/uncle black, g'parent red.  recurse on g'parent
+insertAt x         (BC pb pa py (EC gb ga (R ul ua ur) gc)) = insertAt g gc
+  where p = if pb then B x pa py else B py pa x
+        u = B ul ua ur
+        g = if gb then R p ga u else R u ga p
+-- 4) node is between parent and g'parent => inner rotation
+insertAt (R l a r) (BC False pa py pc@(EC True _ _ _))      = insertAt (R py pa l) (BC True a r pc)
+insertAt (R l a r) (BC True pa py pc@(EC False _ _ _))      = insertAt (R r pa py) (BC False a l pc)
+-- 5) otherwise => outer rotation
+-- XXX: GHC seems unable to infer that gy is Black so I have to do both cases
+--      explicitly, rather than
+-- insertAt x (BC True pa py (EC True ga gy gc)) =
+--   T . zipUp $ Zipper (B x pa $ R py ga gy) gc
+-- insertAt x (BC False pa py (EC False ga gy gc)) =
+--   T . zipUp $ Zipper (B (R gy ga py) pa x) gc
+insertAt x (BC True pa py (EC True ga gy@Leaf gc))   =
+  T . zipUp $ Zipper (B x pa $ R py ga gy) gc
+insertAt x (BC True pa py (EC True ga gy@B {} gc))   =
+  T . zipUp $ Zipper (B x pa $ R py ga gy) gc
+insertAt x (BC False pa py (EC False ga gy@Leaf gc)) =
+  T . zipUp $ Zipper (B (R gy ga py) pa x) gc
+insertAt x (BC False pa py (EC False ga gy@B {} gc)) =
+  T . zipUp $ Zipper (B (R gy ga py) pa x) gc
+
+-- can't derive, since we abstract over n, so we have to manually
+-- check for identical structure
+instance Eq a => Eq (RedBlackTree a) where
+  T Leaf                            == T Leaf                                   =
+      True
+
+  T (B l@B {} a r@B {})             == T (B l'@B {} a' r'@B {})                 =
+      a == a' && T l == T l' && T r == T r'
+
+  T (B (R ll la lr) a r@B {})       == T (B (R ll' la' lr') a' r'@B {})         =
+      a == a' && la == la' && T ll == T ll' && T lr == T lr' && T r == T r'
+
+  T (B l@B {} a (R rl ra rr))       == T (B l'@B {} a' (R rl' ra' rr'))         =
+      a == a' && ra == ra' && T l == T l' && T rl == T rl' && T rr == T rr'
+
+  T (B (R ll la lr) a (R rl ra rr)) == T (B (R ll' la' lr') a' (R rl' ra' rr')) =
+      a == a' && la == la' && ra == ra' &&
+        T ll == T ll' && T lr == T lr' && T rl == T rl' && T rr == T rr'
+  _                                 == _                                        =
+      False
+
+-- can't derive, since B abstracts over child node colors, so
+-- manually check for identical structure
+instance Eq a => Eq (Node c n a) where
+  Leaf    == Leaf             = True
+  R l a r == R l' a' r'       = a == a' && l == l' && r == r'
+  b@B {}  == b'@B {}          = T b == T b'
+  _       == _                = False

RandList.hs

@@ -0,0 +1,85 @@
+module RandList
+  ( RandList
+  , empty
+  , isEmpty
+  , cons
+  , head
+  , tail
+  , lookup
+  , update
+  ) where
+
+import           Prelude hiding (head, lookup, tail)
+
+data BLT a = Leaf a
+           | Fork !Int (BLT a) (BLT a)
+   deriving (Eq, Show)
+
+data Digit a = Zero
+             | One (BLT a)
+   deriving (Eq, Show)
+
+type RandList a = [Digit a]
+
+empty :: RandList a
+empty = []
+
+isEmpty :: RandList a -> Bool
+isEmpty = null
+
+cons :: a -> RandList a -> RandList a
+cons x = insTree (Leaf x)
+
+head :: RandList a -> a
+head ts = x where (Leaf x, _) = borrowTree ts
+
+tail :: RandList a -> RandList a
+tail ts = ts' where (_, ts') = borrowTree ts
+
+lookup :: RandList a -> Int -> a
+lookup [] _ = error "Bad Index"
+lookup (Zero : ts) i = lookup ts i
+lookup (One t : ts) i
+   | i < size t = lookupTree t i
+   | otherwise  = lookup ts (i - size t)
+
+update :: RandList a -> Int -> a -> RandList a
+update [] _ _ = error "Bad Index"
+update (Zero : ts) i y = Zero : update ts i y
+update (One t : ts) i y
+   | i < size t = One (updateTree t i y) : ts
+   | otherwise  = One t : update ts (i - size t) y
+
+-- Utility functions
+
+size :: BLT a -> Int
+size (Leaf _)      = 1
+size (Fork n _ _ ) = n
+
+link :: BLT a -> BLT a -> BLT a
+link t1 t2 = Fork (size t1 + size t2) t1 t2
+
+insTree :: BLT a -> RandList a -> RandList a
+insTree t [] = [One t]
+insTree t (Zero : ts) = One t : ts
+insTree t1 (One t2 : ts) = Zero : insTree (link t1 t2) ts
+
+borrowTree :: RandList a -> (BLT a, RandList a)
+borrowTree [One t]      = (t, [])
+borrowTree (One t : ts) = (t, Zero : ts)
+borrowTree (Zero  : ts) = (t1, One t2 : ts')
+  where (Fork _ t1 t2, ts') = borrowTree ts
+
+lookupTree :: BLT a -> Int -> a
+lookupTree (Leaf x) 0 = x
+lookupTree (Leaf _) _ = error "Bad Index"
+lookupTree (Fork n t1 t2) i
+   | i < (n `div` 2) = lookupTree t1 i
+   | otherwise       = lookupTree t2 (i - n `div` 2)
+
+updateTree :: BLT a -> Int -> a -> BLT a
+updateTree (Leaf _) 0 y = Leaf y
+updateTree (Leaf _) _ _ = error "Bad Index"
+updateTree (Fork n t1 t2) i y
+   | i < (n `div` 2) = Fork n (updateTree t1 i y) t2
+   | otherwise       = Fork n t1 (updateTree t2 (i - n `div` 2) y)

SkewNat.hs

@@ -0,0 +1,13 @@
+module SkewNat where
+
+type SkewNat = [Int] -- increasing list of powers of 2^{k+1}-1
+
+inc :: SkewNat -> SkewNat
+inc ws@(w1 : w2 : rest)
+   | w1 == w2  = 1 + w1 + w2 : rest
+   | otherwise = 1           : ws
+inc ws         = 1           : ws
+
+dec :: SkewNat -> SkewNat
+dec (1 : ws) = ws
+dec (w : ws) = (w `div` 2) : (w `div` 2) : ws

SkewRandList.hs

@@ -0,0 +1,61 @@
+module SkewRandList
+  ( RList
+  , cons
+  , head
+  , tail
+  , lookup
+  , update ) where
+
+import           Prelude hiding (head, lookup, tail)
+
+data BTree a = Leaf a
+             | Node a (BTree a) (BTree a)
+  deriving (Show, Eq)
+
+data Digit a = Digit !Int (BTree a)
+  deriving (Show, Eq)
+
+type RList a = [Digit a]
+
+cons :: a -> RList a -> RList a
+cons x (Digit w1 t1 : Digit w2 t2 : ts')
+   | w1 == w2  = Digit (1 + w1 + w2) (Node x t1 t2) : ts'
+cons x ts      = Digit 1 (Leaf x) : ts
+
+head :: RList a -> a
+head (Digit 1 (Leaf x)     : _) = x
+head (Digit _ (Node x _ _) : _) = x
+
+tail :: RList a -> RList a
+tail (Digit 1 (Leaf _)       : ts) = ts
+tail (Digit w (Node _ t1 t2) : ts) =
+  Digit w' t1 : Digit w' t2 : ts
+ where w' = w `div` 2
+
+lookup :: RList a -> Int -> a
+lookup (Digit w t : ts) i
+   | i < w = lookupTree w t i
+   | otherwise = lookup ts (i - w)
+
+update :: RList a -> Int -> a -> RList a
+update (Digit w t : ts) i y
+   | i < w = Digit w (updateTree w t i y) : ts
+   | otherwise = Digit w t : update ts (i-w) y
+
+lookupTree :: Int -> BTree a -> Int -> a
+lookupTree 1 (Leaf x)     0 = x
+lookupTree _ (Node x _ _) 0 = x
+lookupTree w (Node _ t1 t2) i
+   | i < w'    = lookupTree w' t1 (i-1)
+   | otherwise = lookupTree w' t2 (i-1-w')
+ where w' = w `div` 2
+
+updateTree :: Int -> BTree a -> Int -> a -> BTree a
+updateTree 1 (Leaf _) 0 y = Leaf y
+updateTree _ (Node _ t1 t2) 0 y = Node y t1 t2
+updateTree w (Node x t1 t2) i y
+   | i < (w`div`2) =
+     Node x (updateTree w' t1 (i-1) y) t2
+   | otherwise     =
+     Node x t1 (updateTree w' t2 (i-1-w') y)
+ where w' = w `div` 2

SparseNat.hs

@@ -0,0 +1,28 @@
+module SparseNat where
+
+type SparseNat = [Int] -- increasing list of powers of 2
+
+carry :: Int -> SparseNat -> SparseNat
+carry w []     = [w]
+carry w ws@(w' : rest)
+   | w < w'    = w : ws
+   | otherwise = carry (2 * w) rest
+
+borrow :: Int -> SparseNat -> SparseNat
+borrow w ws@(w' : rest)
+   | w < w'    = rest
+   | otherwise = w : borrow (2 * w) ws
+
+inc :: SparseNat -> SparseNat
+inc = carry 1
+
+dec :: SparseNat -> SparseNat
+dec = borrow 1
+
+add :: SparseNat -> SparseNat -> SparseNat
+add ws [] = ws
+add [] ws = ws
+add m@(w1 : ws1) n@(w2 : ws2)
+   | w1 < w2   = w1 : add ws1 n
+   | w2 < w1   = w2 : add m ws2
+   | otherwise = carry (2 * w1) (add ws1 ws2)

StrictList.hs

@@ -0,0 +1,30 @@
+module StrictList (
+    StrictList(..)
+  , foldl
+  , reverse
+  , head
+  , tail
+  ) where
+
+import           Prelude hiding (foldl, head, reverse, tail)
+
+data StrictList a = !a :$ !(StrictList a) | Empty
+                  deriving (Show, Eq)
+
+infixr 5 :$
+
+foldl :: (b -> a -> b) -> b -> StrictList a -> b
+foldl f = lgo
+    where lgo z Empty     = z
+          lgo z (x :$ xs) = let z' = f z x in z' `seq` lgo z' xs
+
+reverse :: StrictList a -> StrictList a
+reverse = foldl (flip (:$)) Empty
+
+head :: StrictList a -> a
+head (x :$ _ ) = x
+head Empty     = error "Empty StrictList has no head"
+
+tail :: StrictList a -> StrictList a
+tail (_ :$ xs) = xs
+tail Empty     = error "Empty StrictList has no tail"

Zipper.hs

@@ -0,0 +1,51 @@
+module Zipper where
+
+data Tree a = Item a
+            | Section [Tree a]
+   deriving (Show, Eq)
+
+data Path a = Top
+            | Node [Tree a] (Path a) [Tree a]
+   deriving (Show, Eq)
+
+data Location a = Loc (Tree a) (Path a)
+   deriving (Show, Eq)
+
+goLeft :: Location a -> Location a
+goLeft (Loc _ Top) = error "Can't go left of top"
+goLeft (Loc t (Node (l:left) up right)) = Loc l (Node left up (t:right))
+goLeft (Loc _ (Node [] _ _)) = error "Can't go left of first"
+
+goRight :: Location a -> Location a
+goRight (Loc _ Top) = error "Can't go right of top"
+goRight (Loc t (Node left up (r:right))) = Loc r (Node (t:left) up right)
+goRight _           = error "Can't go right of last"
+
+goUp :: Location a -> Location a
+goUp (Loc _ Top) = error "Can't go up from top"
+goUp (Loc t (Node left up right)) = Loc (Section (reverse left ++ t:right)) up
+
+goDown :: Location a -> Location a
+goDown (Loc (Item _) _) = error "Can't go down from item"
+goDown (Loc (Section (t1:trees)) p) = Loc t1 (Node [] p trees)
+
+nth :: Location a -> Int -> Location a
+nth loc = go
+  where go 1             = goDown loc
+        go n | n > 0     = goRight (go (n-1))
+             | otherwise = error "nth expects a positive int"
+
+replace :: Location a -> Tree a -> Location a
+replace (Loc _ p) t = Loc t p
+
+insertRight :: Location a -> Tree a -> Location a
+insertRight (Loc _ Top) _ = error "Can't insert right of top"
+insertRight (Loc t (Node left up right)) r = Loc t (Node left up (r:right))
+
+insertLeft :: Location a -> Tree a -> Location a
+insertLeft (Loc _ Top) _ = error "Can't insert left of top"
+insertLeft (Loc t (Node left up right)) l = Loc t (Node (l:left) up right)
+
+insertDown :: Location a -> Tree a -> Location a
+insertDown (Loc (Item _) _) _ = error "Can't insert down of an item"
+insertDown (Loc (Section sons) p) t1 = Loc t1 (Node [] p sons)