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