pad.hs

{-# LANGUAGE Rank2Types, GADTs #-}
import Data.Map hiding (map, foldr, mapMaybe, filter)
import qualified Data.Map as M

import Data.Maybe

newtype Tree k v = Tree {unTree :: forall r. (v->r) -> (Map k r->r) -> r}

instance Functor (Tree k) where
    fmap f (Tree cont) = Tree $ \leaf tree -> cont (leaf . f) tree

newtype NoScape = NoScape {unNoScape :: String}

instance Show NoScape where
    show (NoScape s) = s 

instance (Show k, Show v) => Show (Tree k v) where
    show (Tree cont) = unNoScape $ cont (NoScape . show) (NoScape . show)

fstLtrMap :: Ord k => [[k]] -> Map k [[k]]
fstLtrMap [] = empty
fstLtrMap ([]:xss) = fstLtrMap xss
fstLtrMap xss@((x:_):_) = igo x xss [] empty
    where
        igo b ((b':bs):bss) acc mp | b == b' = igo b bss (bs:acc) mp
                                   | otherwise = igo b' bss [bs] (insert b acc mp)
        igo b ([]:bss) acc mp = igo b bss acc mp
        igo b [] acc mp = insert b acc mp

dictToTree lst = Tree $ \leaf branch -> (let igo [[]] s = leaf $ reverse s
                                             igo  xs  s = branch $ M.mapWithKey (\k x -> igo x (k:s)) $ fstLtrMap xs
                                       in igo lst [])

data Nat = Z | S {unS :: Nat} deriving (Show, Eq, Ord)
toNat n = case compare n 0 of
    LT -> error "Not a natural"
    EQ -> Z
    GT -> S $ toNat (n-1)
fromNat  Z    = 0
fromNat (S n) = succ $ fromNat n

inf = S inf

mex :: (Foldable t) => t Nat -> Nat
mex = igo Z where
    igo n ns = if n `elem` ns then S (igo (S n) ns) else Z

newtype TreeAnt k v = TreeA {unTreeA :: forall r. (v -> Map k r -> r) -> r}

instance (Show k, Show v) => Show (TreeAnt k v) where
    show (TreeA cont) = unNoScape $ cont $ \val rest -> NoScape $ (show val) ++ " ~ " ++ (show rest)

instance Functor (TreeAnt k) where
    fmap f (TreeA cont) = TreeA $ \branchA -> cont $ \v mp -> branchA (f v) mp

-- treeTotreeA dr (Tree cont) = TreeA $ \branchA -> cont (flip branchA empty) (branchA dr)
solveTree :: Tree k v -> TreeAnt k (Maybe Nat)
solveTree (Tree cont) = TreeA $ \branchA -> fst $ cont (const $ (branchA Nothing empty, inf)) (\mp -> let m = mex $ M.map snd mp in (branchA (Just m) (M.map fst mp), m))

topTreeA (TreeA cont) = cont $ \v _ -> v

climbTreeA :: Ord k => [k] -> TreeAnt k v -> TreeAnt k v
climbTreeA k (TreeA cont) = TreeA $ \branchA -> cont (let
                                                          igo v mp [] = branchA v (M.map ($[]) mp)
                                                          igo _ mp (k:ks) = (mp ! k) ks
                                                      in igo) k

depthTreeA k (TreeA cont) = TreeA $ \branchA -> cont (let
                                                           igo v _  1 = branchA v empty
                                                           igo v mp n = branchA v (M.map ($(pred n)) mp)
                                                       in igo) k