{- ---------------------------------------------------------------------- Raw code file for "Evolution of a Haskell Programmer" Fritz Ruehr, Willamette University See Any given variation section (seperated by horizontal rules) can be enabled by setting off its delimiting nested comments with EOL comments (in which case the previously enabled section should be disabled). Within a variation section, multiple versions of factorial are named differently to avoid conflicts. The variation enabled by default is the "freshman" one. -} ---------------------------------------------------------------------- ---------------------------------------- -- {- -- Freshman Haskell programmer fac n = if n == 0 then 1 else n * fac (n-1) -- -} ---------------------------------------- {- -- Sophomore Haskell programmer at MIT fac = (\(n) -> (if ((==) n 0) then 1 else ((*) n (fac ((-) n 1))))) -} ---------------------------------------- {- -- Junior Haskell programmer fac 0 = 1 fac (n+1) = (n+1) * fac n -} ---------------------------------------- {- -- Another junior Haskell programmer fac 0 = 1 fac n = n * fac (n-1) -} ---------------------------------------- {- -- Senior Haskell programmer fac n = foldr (*) 1 [1..n] -} ---------------------------------------- {- -- Another senior Haskell programmer fac n = foldl (*) 1 [1..n] -} ---------------------------------------- {- -- Yet another senior Haskell programmer -- using foldr to simulate foldl fac n = foldr (\x g n -> g (x*n)) id [1..n] 1 -} ---------------------------------------- {- -- Memoizing Haskell programmer facs = scanl (*) 1 [1..] fac n = facs !! n -} ---------------------------------------- {- -- Points-free Haskell programmer fac = foldr (*) 1 . enumFromTo 1 -} ---------------------------------------- {- -- Iterative Haskell programmer fac n = result (for init next done) where init = (0,1) next (i,m) = (i+1, m * (i+1)) done (i,_) = i==n result (_,m) = m for i n d = until d n i -} ---------------------------------------- {- -- Iterative one-liner Haskell programmer fac n = snd (until ((>n) . fst) (\(i,m) -> (i+1, i*m)) (1,1)) -} ---------------------------------------- {- -- Accumulating Haskell programmer facAcc a 0 = a facAcc a n = facAcc (n*a) (n-1) fac = facAcc 1 -} ---------------------------------------- {- -- Continuation-passing Haskell programmer facCps k 0 = k 1 facCps k n = facCps (k . (n *)) (n-1) fac = facCps id -} ---------------------------------------- {- -- Boy Scout Haskell programmer y f = f (y f) fac = y (\f n -> if (n==0) then 1 else n * f (n-1)) -} ---------------------------------------- {- -- Combinatory Haskell programmer s f g x = f x (g x) k x y = x b f g x = f (g x) c f g x = f x g y f = f (y f) cond p f g x = if p x then f x else g x fac = y (b (cond ((==) 0) (k 1)) (b (s (*)) (c b pred))) -} ---------------------------------------- {- -- List-encoding Haskell programmer arb = () -- "undefined" is also a good RHS, as is "arb" :) listenc n = replicate n arb listprj f = length . f . listenc listprod xs ys = [ i(x,y) | x<-xs, y<-ys ] where i _ = arb facl [] = listenc 1 facl n@(_:pred) = listprod n (facl pred) fac = listprj facl -} ---------------------------------------- {- -- Interpretive Haskell programmer -- a dynamically-typed term language data Term = Occ Var | Use Prim | Lit Integer | App Term Term | Abs Var Term | Rec Var Term type Var = String type Prim = String -- a domain of values, including functions data Value = Num Integer | Bool Bool | Fun (Value -> Value) instance Show Value where show (Num n) = show n show (Bool b) = show b show (Fun _) = "" prjFun (Fun f) = f prjFun _ = error "bad function value" prjNum (Num n) = n prjNum _ = error "bad numeric value" prjBool (Bool b) = b prjBool _ = error "bad boolean value" binOp inj f = Fun (\i -> (Fun (\j -> inj (f (prjNum i) (prjNum j))))) -- environments mapping variables to values type Env = [(Var, Value)] getval x env = case lookup x env of Just v -> v Nothing -> error ("no value for " ++ x) -- an environment-based evaluation function eval env (Occ x) = getval x env eval env (Use c) = getval c prims eval env (Lit k) = Num k eval env (App m n) = prjFun (eval env m) (eval env n) eval env (Abs x m) = Fun (\v -> eval ((x,v) : env) m) eval env (Rec x m) = f where f = eval ((x,f) : env) m -- a (fixed) "environment" of language primitives times = binOp Num (*) minus = binOp Num (-) equal = binOp Bool (==) cond = Fun (\b -> Fun (\x -> Fun (\y -> if (prjBool b) then x else y))) prims = [ ("*", times), ("-", minus), ("==", equal), ("if", cond) ] -- a term representing factorial and a "wrapper" for evaluation facTerm = Rec "f" (Abs "n" (App (App (App (Use "if") (App (App (Use "==") (Occ "n")) (Lit 0))) (Lit 1)) (App (App (Use "*") (Occ "n")) (App (Occ "f") (App (App (Use "-") (Occ "n")) (Lit 1)))))) fac n = prjNum (eval [] (App facTerm (Lit n))) -} ---------------------------------------- {- -- Static Haskell programmer -- (after Thomas Hallgren's "Fun with Functional Dependencies") -- static Peano constructors and numerals data Zero data Succ n type One = Succ Zero type Two = Succ One type Three = Succ Two type Four = Succ Three -- dynamic representatives for static Peanos zero = undefined :: Zero one = undefined :: One two = undefined :: Two three = undefined :: Three four = undefined :: Four -- addition, a la Prolog class Add a b c | a b -> c where add :: a -> b -> c instance Add Zero b b instance Add a b c => Add (Succ a) b (Succ c) -- multiplication, a la Prolog class Mul a b c | a b -> c where mul :: a -> b -> c instance Mul Zero b Zero instance (Mul a b c, Add b c d) => Mul (Succ a) b d -- factorial, a la Prolog class Fac a b | a -> b where fac :: a -> b instance Fac Zero One instance (Fac n k, Mul (Succ n) k m) => Fac (Succ n) m -- try, for "instance" (sorry): -- -- :t fac four -} ------------------------------------------------------------ {- -- Beginning graduate Haskell programmer -- the natural numbers, a la Peano data Nat = Zero | Succ Nat -- iteration and some applications iter z s Zero = z iter z s (Succ n) = s (iter z s n) plus n = iter n Succ mult n = iter Zero (plus n) -- primitive recursion primrec z s Zero = z primrec z s (Succ n) = s n (primrec z s n) -- two versions of factorial fac = snd . iter (one, one) (\(a,b) -> (Succ a, mult a b)) fac' = primrec one (mult . Succ) -- for convenience and testing (try e.g. "fac five") int = iter 0 (1+) instance Show Nat where show = show . int (zero : one : two : three : four : five : _) = iterate Succ Zero -} ------------------------------------------------------------ {- -- Origamist Haskell programmer -- (curried, list) fold and an application fold c n [] = n fold c n (x:xs) = c x (fold c n xs) prod = fold (*) 1 -- (curried, boolean-based, list) unfold and an application unfold p f g x = if p x then [] else f x : unfold p f g (g x) downfrom = unfold (==0) id pred -- hylomorphisms, as-is or "unfolded" (ouch! sorry ...) refold c n p f g = fold c n . unfold p f g refold' c n p f g x = if p x then n else c (f x) (refold' c n p f g (g x)) -- several versions of factorial, all (extensionally) equivalent fac = prod . downfrom fac' = refold (*) 1 (==0) id pred fac'' = refold' (*) 1 (==0) id pred -} ------------------------------------------------------------ {- -- Cartesianally-inclined Haskell programmer -- Based roughly on Lex Augusteijn's "Sorting Morphisms" -- (product-based, list) catamorphisms and an application cata (n,c) [] = n cata (n,c) (x:xs) = c (x, cata (n,c) xs) mult = uncurry (*) prod = cata (1, mult) -- (co-product-based, list) anamorphisms and an application ana f = either (const []) (cons . pair (id, ana f)) . f cons = uncurry (:) downfrom = ana uncount uncount 0 = Left () uncount n = Right (n, n-1) -- two variations on list hylomorphisms hylo f g = cata g . ana f hylo' f (n,c) = either (const n) (c . pair (id, hylo' f (c,n))) . f pair (f,g) (x,y) = (f x, g y) -- several versions of factorial, all (extensionally) equivalent fac = prod . downfrom fac' = hylo uncount (1, mult) fac'' = hylo' uncount (1, mult) -} ------------------------------------------------------------ {- -- Ph.D. Haskell programmer -- explicit type recursion based on functors newtype Mu f = Mu (f (Mu f)) deriving Show in x = Mu x out (Mu x) = x -- cata- and ana-morphisms, now for *arbitrary* (regular) base functors cata phi = phi . fmap (cata phi) . out ana psi = in . fmap (ana psi) . psi -- base functor and data type for natural numbers, -- using a curried elimination operator data N b = Zero | Succ b deriving Show instance Functor N where fmap f = nelim Zero (Succ . f) nelim z s Zero = z nelim z s (Succ n) = s n type Nat = Mu N -- conversion to internal numbers, conveniences and applications int = cata (nelim 0 (1+)) instance Show Nat where show = show . int zero = in Zero suck = in . Succ -- pardon my "French" (Prelude conflict) plus n = cata (nelim n suck ) mult n = cata (nelim zero (plus n)) -- base functor and data type for lists data L a b = Nil | Cons a b deriving Show instance Functor (L a) where fmap f = lelim Nil (\a b -> Cons a (f b)) lelim n c Nil = n lelim n c (Cons a b) = c a b type List a = Mu (L a) -- conversion to internal lists, conveniences and applications list = cata (lelim [] (:)) instance Show a => Show (List a) where show = show . list prod = cata (lelim (suck zero) mult) upto = ana (nelim Nil (diag (Cons . suck)) . out) diag f x = f x x fac = prod . upto -} ------------------------------------------------------------ {- -- Post-doc Haskell programmer -- (from Uustalu, Vene and Pardo's "Recursion Schemes from Comonads") -- explicit type recursion with functors and catamorphisms newtype Mu f = In (f (Mu f)) unIn (In x) = x cata phi = phi . fmap (cata phi) . unIn -- base functor and data type for natural numbers, -- using locally-defined "eliminators" data N c = Z | S c instance Functor N where fmap g Z = Z fmap g (S x) = S (g x) type Nat = Mu N zero = In Z suck n = In (S n) add m = cata phi where phi Z = m phi (S f) = suck f mult m = cata phi where phi Z = zero phi (S f) = add m f -- explicit products and their functorial action data Prod e c = Pair c e outl (Pair x y) = x outr (Pair x y) = y fork f g x = Pair (f x) (g x) instance Functor (Prod e) where fmap g = fork (g . outl) outr -- comonads, the categorical "opposite" of monads class Functor n => Comonad n where extr :: n a -> a dupl :: n a -> n (n a) instance Comonad (Prod e) where extr = outl dupl = fork id outr -- generalized catamorphisms, zygomorphisms and paramorphisms gcata :: (Functor f, Comonad n) => (forall a. f (n a) -> n (f a)) -> (f (n c) -> c) -> Mu f -> c gcata dist phi = extr . cata (fmap phi . dist . fmap dupl) zygo chi = gcata (fork (fmap outl) (chi . fmap outr)) para :: Functor f => (f (Prod (Mu f) c) -> c) -> Mu f -> c para = zygo In -- factorial, the *hard* way! fac = para phi where phi Z = suck zero phi (S (Pair f n)) = mult f (suck n) -- for convenience and testing int = cata phi where phi Z = 0 phi (S f) = 1 + f instance Show (Mu N) where show = show . int -} ------------------------------------------------------------ {- -- Tenured professor fac n = product [1..n] -} ----- END OF FILE ------------------------------------------