User:PaoloMartini
Revision as of 00:54, 29 July 2006 by PaoloMartini (talk | contribs) (Cleaned up Romans (no more unuseful argument and function composition))
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
Points-free contest
Manual reductions
\a b c -> a + (b*c) \a b c -> (+) a ((*) b c) \a b -> ((+) a) . ((*) b) \a -> (((+) a) .) . (*) \a -> (.) ((+ a) .) (*) \a -> (flip (.)) (*) ((+ a) .) \a -> (flip (.)) (*) (((.) (+ a)) (flip (.)) (*) . ((.) . (+)) <xerox> I think I deserve an award for that reduction. <dons> xerox reaches PointFree Hacker, Level 7.
<xerox> f . g . h = (\x -> f . x . h) g = (\x -> f . (x . h)) g = (\x -> (f .) ((.) x h)) g = ((f .) . (. h)) g
pascal = iterate (ap (zipWith (+) . (++ [1])) ([1] ++)) [1]
-- > take 3 pascal
-- [[1],[2,2],[3,4,3]]
Experimenting with variadic functions
First revision (W (a -> a))
{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}
module VarArg
where
data W a = W { unW :: a } deriving Show
-- `c' is:
--
-- c f x = (f x)
-- c f x y = c (f x) y
--
class C a r | r -> a where
c :: (a -> a -> a) -> a -> r
instance C a (W (a -> a)) where
c f x = W (\y -> f x y)
r :: Int -> W (Int -> Int) -> Int
r x = ($ x) . unW
instance C a r => C a (a -> r) where
c f x y = c f (f x y)
test1 = let t1 = c (+) 1
t2 = c (+) 1 2
t3 = c (+) 1 2 3
t4 = c (+) 1 2 3 4
in map (r 0) [t1,t2,t3,t4]
test2 = zipWith (==) [1, 1+2, sum [1,2,3], foldr (+) 0 [1,2,3,4]] test1
-- `d' is:
--
-- d f [ ] = f
-- d f (x:xs) = d (f x) xs
--
-- ..for which `c' is the only valid `f'.
--
class D a r | r -> a where
d :: (forall r. (C a r) => a -> r) -> [a] -> r
instance C a (W (a -> a)) => D a (W (a -> a)) where
d f (x:[]) = f x
d f (x:xs) = d (f x) xs
test3 = let t1 = d (c (^)) [2..3]
t2 = d (c (*)) [2..10]
t3 = d (c (+)) [2..100]
in map (r 1) [t1,t2,t3]
test4 = zipWith (==) [foldl1 (^) [2..3], foldl1 (*) [1..10], foldl1 (+) [1..100]] test3
No more incoherent instances ((W a) and QuickCheck)
{-# OPTIONS_GHC -fglasgow-exts #-}
module Apply
where
import Test.QuickCheck
data W a = W { reify :: a } deriving Show -- wrapper
class Apply a r | r -> a where
apply :: (a -> a -> a) -> a -> a -> r
instance Apply a (W a) where
apply f x y = W (f x y)
instance Apply a r => Apply a (a -> r) where
apply f x y z = apply f (f x y) z
-- test
plus_prop = quickCheck p2 >> quickCheck p3 >> quickCheck p4
where p2 :: Int -> Int -> Bool
p3 :: Int -> Int -> Int -> Bool
p4 :: Int -> Int -> Int -> Int -> Bool
p2 x y = (reify $ apply (+) x y) == x + y
p3 x y z = (reify $ apply (+) x y z) == x + y + z
p4 x y z w = (reify $ apply (+) x y z w) == x + y + z + w
Catamorfism on a binary tree
Replacing systematically the data constructors with an evaluation function.
data Tree a = Leaf a
| Branch (Tree a) (Tree a)
cata :: (a -> r, r -> r -> r) -> Tree a -> r
cata (f1,f2) (Leaf x) = f1 x
cata (f1,f2) (Branch b1 b2) = f2 (cata (f1,f2) b1) (cata (f1,f2) b2)
Fibonacci (type-)numbers
{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}
module Fibonacci where
data Zero
data Succ n
type One = Succ Zero
class Add a b c | a b -> c where
add :: a -> b -> c
instance Add Zero n n
instance Add a b c => Add (Succ a) b (Succ c)
class Fib n m | n -> m where
fib :: n -> m
instance Fib Zero Zero
instance Fib One One
instance (Fib n a, Fib (Succ n) b, Add a b c) => Fib (Succ (Succ n)) c
Points-free hylomorphism
module Refold where
fold f n [ ] = n
fold f n (x:xs) = f x (fold f n xs)
unfold p f g x = if p x then [] else f x : unfold p f g (g x)
{-
refold c n p f g = fold c n . unfold p f g
refold c n p f = (fold c n .) . unfold p f
refold c n p = ((fold c n .) .) . unfold p
refold c n = (((fold c n .) .) .) . unfold
refold c n = (\x -> (((x .) .) .) . unfold) fold c n
refold c = (\x -> (((x .) .) .) . unfold) . fold c
refold = ((\x -> (((x .) .) .) . unfold) .) . fold
refold = ((\x -> (.) (((x .) .) .) unfold) .) . fold
refold = ((\x -> flip (.) unfold (((x .) .) .)) .) . fold
refold = ((\x -> flip (.) unfold . (\x -> (.) ((.) ((.) x))) $ x) .) . fold
refold = ((flip (.) unfold . ((.) . (.) . (.))) .) . fold
-}
refold = ((flip (.) unfold . (.) . (.) . (.)) .) . fold
Roman (type-)numerals
{-# OPTIONS_GHC -fglasgow-exts #-}
module Romans where
class Roman t where
roman :: t -> Int
data O -- 0
data I a -- 1
data V a -- 5
data X a -- 10
data L a -- 50
data C a -- 100
data D a -- 500
data M a -- 1000
instance Roman O where roman _ = 0
instance Roman (I O) where roman _ = 1
instance Roman (V O) where roman _ = 5
instance Roman (X O) where roman _ = 10
instance Roman (I a) => Roman (I (I a)) where roman _ = roman (undefined :: (I a)) + 1
instance Roman a => Roman (I (V a)) where roman _ = roman (undefined :: a) + 4
instance Roman a => Roman (I (X a)) where roman _ = roman (undefined :: a) + 9
instance Roman (I a) => Roman (V (I a)) where roman _ = roman (undefined :: (I a)) + 5
instance Roman (V a) => Roman (V (V a)) where roman _ = roman (undefined :: (V a)) + 5
instance Roman (I a) => Roman (X (I a)) where roman _ = roman (undefined :: (I a)) + 10
instance Roman (V a) => Roman (X (V a)) where roman _ = roman (undefined :: (V a)) + 10
instance Roman (X a) => Roman (X (X a)) where roman _ = roman (undefined :: (X a)) + 10
instance Roman a => Roman (X (L a)) where roman _ = roman (undefined :: a) + 40
instance Roman a => Roman (X (C a)) where roman _ = roman (undefined :: a) + 90
instance Roman a => Roman (X (D a)) where roman _ = roman (undefined :: a) + 490
instance Roman a => Roman (L a) where roman _ = roman (undefined :: a) + 50
instance Roman (I a) => Roman (C (I a)) where roman _ = roman (undefined :: (I a)) + 100
instance Roman (V a) => Roman (C (V a)) where roman _ = roman (undefined :: (V a)) + 100
instance Roman (X a) => Roman (C (X a)) where roman _ = roman (undefined :: (X a)) + 100
instance Roman (L a) => Roman (C (L a)) where roman _ = roman (undefined :: (L a)) + 100
instance Roman (C a) => Roman (C (C a)) where roman _ = roman (undefined :: (C a)) + 100
instance Roman a => Roman (C (D a)) where roman _ = roman (undefined :: a) + 400
instance Roman a => Roman (C (M a)) where roman _ = roman (undefined :: a) + 900
instance Roman a => Roman (D a) where roman _ = roman (undefined :: a) + 500
instance Roman a => Roman (M a) where roman _ = roman (undefined :: a) + 1000
powersoftwo = [roman (undefined :: (I (I O))),
roman (undefined :: (I (V O))),
roman (undefined :: (V (I (I (I O))))),
roman (undefined :: (X (V (I O)))),
roman (undefined :: (X (X (X (I (I O)))))),
roman (undefined :: (L (X (I (V O))))),
roman (undefined :: (C (X (X (V (I (I (I O)))))))),
roman (undefined :: (C (C (L (V (I O)))))),
roman (undefined :: (D (X (I (I O))))),
roman (undefined :: (M (X (X (I (V O)))))),
roman (undefined :: (M (M (X (L (V (I (I (I O)))))))))]