{-# OPTIONS -fglasgow-exts #-} -- Just a few functions for playing with StrictCheck import Data.Generics import StrictCheck -- spine-strict variant of unzip -- StrictCheck first finds same over-strictness as in standard unzip unzip2 :: [(a, b)] -> ([a], [b]) unzip2 = foldr (\(x,y) (xs,ys) -> (x:xs,y:ys)) ([],[]) data MyNat = Zero | Succ MyNat deriving (Typeable,Data) -- overly strict successor function succ :: MyNat -> MyNat succ x = go x Zero where go Zero x = x go (Succ x) y = go x (Succ y) -- breadth-first numbering along Chris Okasaki, ICFP 2000 -- first the queue data type data Queue a = Q [a] [a] deriving (Show,Data,Typeable) empty :: Queue a empty = Q [] [] front :: Queue a -> Maybe (a,Queue a) front (Q [] []) = Nothing front (Q (x:xs) ys) = Just (x,Q xs ys) front (Q [] ys) = Just (x,Q xs []) where x:xs = reverse ys snoc :: Queue a -> a -> Queue a snoc (Q xs ys) y = Q xs (y:ys) data Tree a = E | T (Tree a) a (Tree a) deriving (Show,Data,Typeable) -- the actual breadth-first numbering function bfNum :: Tree a -> Tree Int bfNum t = t' where Just (t',_) = front (bfNum' 1 (snoc empty t)) bfNum' :: Int -> Queue (Tree a) -> Queue (Tree Int) bfNum' i q = case front q of Nothing -> empty Just (E,ts) -> bfNum' i ts `snoc` E Just (T l x r,ts) -> let Just (r',ts'') = front (bfNum' (i+1) ((ts `snoc` l) `snoc` r)) Just (l',ts') = front ts'' in ts' `snoc` T l' i r'