Капелька адекватности - Elena and Grizzlies

(ahem) “Points-free” · and

fac n = if n == 0
          then 1
          else n * fac (n-1)

fac = (\(n) ->
       (if ((==) n 0)
           then 1
           else ((*) n (fac ((-) n 1)))))

fac  0    =  1
fac (n+1) = (n+1) * fac n

fac 0 = 1
fac n = n * fac (n-1)

fac n = foldr (*) 1 [1..n]

fac n = foldl (*) 1 [1..n]

-- using foldr to simulate foldl

fac n = foldr (\x g n -> g (x*n)) id [1..n] 1

facs = scanl (*) 1 [1..]

fac n = facs !! n

fac = foldr (*) 1 . enumFromTo 1

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

fac n = snd (until ((>n) . fst) (\(i,m) -> (i+1, i*m)) (1,1))

facAcc a 0 = a
facAcc a n = facAcc (n*a) (n-1)

fac = facAcc 1

facCps k 0 = k 1
facCps k n = facCps (k . (n *)) (n-1)

fac = facCps id

y f = f (y f)

fac = y (\f n -> if (n==0) then 1 else n * f (n-1))

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)))

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 

-- 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 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

-- 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

-- (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

-- (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)

-- 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

-- 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

fac n = product [1..n]

Капелька адекватности - Elena and Grizzlies

вторник, 24 февраля 2009 г.

Haskell: два алгоритма противоречат друг другу.

The Evolution of a Haskell Programmer

Freshman Haskell programmer

Sophomore Haskell programmer, at MIT

Junior Haskell programmer

Another junior Haskell programmer

Senior Haskell programmer

Another senior Haskell programmer

Yet another senior Haskell programmer

Memoizing Haskell programmer

Pointless (ahem)
“Points-free” Haskell programmer

Iterative Haskell programmer

Iterative one-liner Haskell programmer

Accumulating Haskell programmer

Continuation-passing Haskell programmer

Boy Scout Haskell programmer

Combinatory Haskell programmer

List-encoding Haskell programmer

Interpretive Haskell programmer

Static Haskell programmer

Beginning graduate Haskell programmer

Origamist Haskell programmer

Cartesianally-inclined Haskell programmer

Ph.D. Haskell programmer

Post-doc Haskell programmer

Tenured professor

Background

But seriously, folks, ...

Revision history

References

Комментариев нет:

Отправить комментарий

вторник, 24 февраля 2009 г.