Name: Anonymous 2009-01-01 14:40
Does anyone use Haskell Clean?
Its faster then GHC
Its faster then GHC
fact n = last.loeb $ const 1:[(*x).(!!(x-2)) | x <- [2..n]]
fact 1 = 1
fact 2 = 2
fact 3 = 6
fact 4 = 24
fact 5 = 120
fact 6 = 720
fact 7 = 5040
fact n = error "Error occurred"
{-# LANGUAGE RankNTypes, GADTs, MultiParamTypeClasses, FlexibleInstances, ViewPatterns, KindSignatures, OverlappingInstances, NoMonomorphismRestriction, IncoherentInstances #-}
module Main where
import Control.Monad.Fix
import Control.Applicative
-- | A PHOAS encoded lambda calculus with mu-binders
data Term v t where
Var :: v t -> Term v t
App :: Term v (a -> b) -> Term v a -> Term v b
Lam :: (v a -> Term v b) -> Term v (a -> b)
Lam2 :: (v a -> v b -> Term v c) -> Term v (a -> b -> c)
If :: Term v Bool -> Term v t -> Term v t -> Term v t
Eq :: Eq a => Term v a -> Term v a -> Term v Bool
Mu :: (v t -> Term v t) -> Term v t
MuN :: ([v t] -> [Term v t]) -> Term v t
-- | Hide the structure used as variables
-- This makes direct instantiation impossible and thus enforces the structure
data Exp t where
Exp :: Variable v => Term v t -> Exp t
-- | Some helper to work with variables
-- lower . raise = id
-- raise . lower = id_v
class Variable (v :: * -> *) where
raise :: a -> v a
lower :: v a -> a
on :: (a -> b) -> v a -> v b
on f = raise . f . lower
instance Variable Id where
raise a = (Id a)
lower ((Id a)) = a
-- | Lift any value into the language
class Liftable t where
lift :: Variable v => t -> Term v t
instance Liftable a where
lift i = Var (raise i)
instance Liftable b => Liftable (a -> b) where
lift f = Lam $ \x -> lift (f (lower x))
-- | A phoas term is a Functor
instance Variable v => Functor (Term v) where
fmap f m = App (lift f) m
-- | And it is an applicative, this is handy for composition of lambdas
instance Variable v => Applicative (Term v) where
pure = lift
(<*>) = App
-- | Some underlying functor for instantiating v
newtype Id a = Id {
unId :: a
}
{- | A couple of helper functions -}
-- | Non lifting application
($$) = App
-- | RHS lifting application
($.) f n = App f (lift n)
-- | LHS lifting application
(.$) f n = App (lift f) n
-- | Both lifting application
(.$.) f n = App (lift f) (lift n)
-- | l to r Composition
($<) :: (Variable v, Liftable a, Liftable b, Liftable c) => Term v (b -> c) -> Term v (a -> b) -> Term v (a -> c)
($<) f g = (Lam (\(lower -> a) -> f $$ (g $. a)))
-- | r to l composition
($>) :: (Variable v, Liftable a, Liftable b, Liftable c) => Term v (a -> b) -> Term v (b -> c) -> Term v (a -> c)
($>) f g = (Lam (\(lower -> a) -> g $$ (f $. a)))
infixl 1 $$
infixl 1 .$
infixl 1 $.
infixl 1 .$.
infix 4 `eq`
infixr 9 $<
infixr 1 $>
lam = Lam
mu = Mu
eq = Eq
-- | Recursive definition of factorial (using mu binders)
fact :: Term Id (Integer -> Integer)
fact = mu (\(lower -> f) -> lam (\(lower -> n) ->
If (pred n)
(pure 1)
$
(*n) <$> (f <$> (pure $ n - 1))
))
where
next f n = pure (f (n - 1))
pred n = pure (n == 0)
-- | Factorial function
fac :: Integer -> Integer
fac = eval (Exp fact)
-- | Recursive definition of fibonacci (using mu binders)
fibt :: Term Id (Integer -> Integer)
fibt = mu (\(lower -> f) -> lam (\(lower -> n) ->
If (pred n)
(pure 1)
(next f n)
))
where pred n = pure (n<1)
next f n = let n1 = f <$> pure (n - 1)
n2 = f <$> pure (n - 2)
in (+) <$> n1 <*> n2
-- | Fib function
fib :: Integer -> Integer
fib = eval (Exp fibt)
-- | Evaluator for a expression
eval :: Exp t -> t
eval (Exp f) = evalC f
-- | Evaluator for a PHOAS term
-- Evaluation of mu terms is defined with fix `fix f = let x = f x in x` to optimize sharing.
evalC :: Variable v => Term v t -> t
evalC (App f a) = evalC f $ evalC a
evalC (Var t) = lower t
evalC (Lam f) = \a -> evalC ( f (raise a))
evalC (If cond th el) = case evalC (cond) of
True -> evalC th
False -> evalC el
evalC (Eq a b) = evalC a == evalC b
evalC (Mu f) = fix (evalC . f . raise)
evalC (MuN f) = head $ fix (fmap evalC . f . fmap raise)
cyclicList :: Term Id [Integer]
cyclicList = mu $ \(lower -> k) -> pure (1 : 2 : k)
getCyclicList :: [Integer]
getCyclicList = eval (Exp cyclicList)
data Tree a = Node a [Tree a]
deriving Show
-- | Same as
-- letrec x = Node 1 [Node 2 [], Node 3 [x,y]]
-- y = Node 2 [x]
-- in Node 1 [y]
cyclicTree :: Term Id (Tree Integer)
cyclicTree = muN $ \ ~( _ : (lower -> x): (lower -> y):_) -> [
pure (Node 1000 [y]),
pure (Node 1 [Node 2 [], Node 3 [x,y]]),
pure (Node 2 [x])
]
getCyclicTree = eval (Exp cyclicTree)factorial n = product [2..n] work ?