pinealservo/func-data-presn
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Data structure slides and source code

Browse Source
This commit is contained in:
Levi Pearson
2014-06-10 22:58:26 -06:00
commit 2d9121e663
19 changed files with 2371 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
DenseNat.hs Normal file
View File

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

97
HAMT.hs Normal file
View File

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

216
HON.hs Normal file
View File

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

31
Nested.hs Normal file
View File

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

1031
Presn.md Normal file
View File

File diff suppressed because it is too large Load Diff

22
Queue1.hs Normal file
View File

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

33
Queue2.hs Normal file
View File

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

55
Queue2.txt Normal file
View File

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

1
Queue3.hs Normal file
View File

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

81
RB1.hs Normal file
View File

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

179
RB2.hs Normal file
View File

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

204
RB3.hs Normal file
View File

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

131
RB4.hs Normal file
View File

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

85
RandList.hs Normal file
View File

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

13
SkewNat.hs Normal file
View File

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

61
SkewRandList.hs Normal file
View File

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

28
SparseNat.hs Normal file
View File

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

30
StrictList.hs Normal file
View File

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

51
Zipper.hs Normal file
View File

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