Created
February 11, 2016 16:26
-
-
Save akhileshs/55eedf7452b38d0caad8 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{- ---------------------------------------------------------------------- | |
Raw code file for "Evolution of a Haskell Programmer" | |
Fritz Ruehr, Willamette University | |
See <http://www.willamette.edu/~fruehr/haskell/evolution.html> | |
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 _) = "<function>" | |
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 ------------------------------------------ |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment