217 lines
6.0 KiB
Haskell
217 lines
6.0 KiB
Haskell
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
|