User:PaoloMartini
From HaskellWiki
Contents |
1 Points-free contest
1.1 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]]
2 Experimenting with variadic functions
2.1 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
2.2 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
3 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)
4 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
5 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
6 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)))))))))]
7 Randoms
randoms :: (Random a, RandomGen g) => g -> [a] randoms = fix ((. next) . uncurry . (. (:)) . flip (.)) randoms = unfoldr (Just . random) randomsR :: (Random a, RandomGen g) => (a,a) -> g -> [a] randomsR range = unfoldr (Just . randomR range)
