{-- 2007 Formosan Summer School on Logic, Language, and Computation Supplementary Haskell Code for Introduction to Functional Program Derivation Shin-Cheng Mu --} import List hiding (unfoldr, partition) fact 0 = 0 fact (n+1) = (n+1) * fact n -- aliasing head and tail to be consistent with the lecture. hd xs = head xs tl xs = tail xs -- iTree and eTree as defined in the lecture. data ITree a = Null | Node a (ITree a) (ITree a) deriving Show data ETree a = Tip a | Bin (ETree a) (ETree a) deriving Show square n = n*n -- sum is predefined -- sumsq = sum . map square sumsq [] = 0 sumsq (x:xs) = square x + sumsq xs -- reverse is predefined rcat xs ys = reverse xs ++ ys -- ssp xs n = sumsq xs + n ssp [] n = n ssp (x:xs) n = ssp xs (square x + n) steep [] = True steep (x:xs) = steep xs && x > sum xs steepsum [] = (True, 0) steepsum (x:xs) = let (b,y) = steepsum xs in (b && x > y, x + y) -- length is predefined -- foldr is predefined bmax x y | x >= y = x | otherwise = y max = foldr bmax (-32767) prod = foldr (*) 1 -- id, and are predefined -- and = foldr (&&) True -- id = foldr (:) [] -- takeWhile, dropWhile, inits, tails, and scanr are predefined segs = concat . map inits . tails -- mss = max . map sum . segs mss = fst . foldr step (0,0) where step x (m,y) = ((0 `bmax` (x+y)) `bmax` m, 0 `bmax` (x+y)) foldiT :: (a -> b -> b -> b) -> b -> ITree a -> b foldiT f e Null = e foldiT f e (Node a t u) = f a (foldiT f e t) (foldiT f e u) foldeT :: (b -> b -> b) -> (a -> b) -> ETree a -> b foldeT f g (Tip x) = g x foldeT f g (Bin t u) = f (foldeT f g t) (foldeT f g u) sizeiTree = foldiT (\x m n -> m + n + 1) 0 sumeTree = foldeT (+) id flatteniT = foldiT (\x xs ys -> xs ++ [x] ++ ys) [] flatteneT = foldeT (++) (\x -> [x]) unfoldr :: (s -> Bool) -> (s -> (a,s)) -> s -> [a] unfoldr p f s = if p s then [] else let (x,s') = f s in x : unfoldr p f s' split (f,g) a = (f a, g a) fromto m = unfoldr (>= m) (split (id, (1+))) tailsp = unfoldr null (split (id, tl)) from = unfoldr (const False) (split (id, (1+))) -- iterate is predefined merge xs = unfoldr null2 mrg xs where null2 (xs,ys) = null xs && null ys mrg ([], y:ys) = (y, ([],ys)) mrg (x:xs, []) = (x, (xs,[])) mrg (x:xs, y:ys) = if x <= y then (x, (xs, y:ys)) else (y, (x:xs, ys)) unfoldiT :: (a -> Bool) -> (a -> (b,a,a)) -> a -> ITree b unfoldiT p f s = if p s then Null else let (x,s1,s2) = f s in Node x (unfoldiT p f s1) (unfoldiT p f s2) unfoldeT :: (a -> Bool) -> (a -> (a,a)) -> (a -> b) -> a -> ETree b unfoldeT p f g s = if p s then Tip (g s) else let (s1,s2) = f s in Bin (unfoldeT p f g s1) (unfoldeT p f g s2) single [x] = True single xs = False half = foldr step ([],[]) where step x (xs,ys) = (ys, x:xs) unflatteneT = unfoldeT single half id -- Due to the "monomorphic restriction" of Haskell, -- we have to eta-expand functions like msort, qsort, -- isort, etc. That is, we cannot omit the xs in -- msort xs = ... xs. msort xs = (foldeT (curry merge) id . unflatteneT) xs partition (x:xs) = (x, filter (<=x) xs, filter (>x) xs) qsort xs = (flatteniT . unfoldiT null partition) xs isort xs = foldr insert [] xs where insert x xs = takeWhile (