# Difference between revisions of "User:PaoloMartini"

Jump to navigation
Jump to search

PaoloMartini (talk | contribs) (Points-free hylomorphism) |
PaoloMartini (talk | contribs) (Roman numerals) |
||

Line 185: | Line 185: | ||

refold = ((flip (.) unfold . (.) . (.) . (.)) .) . fold |
refold = ((flip (.) unfold . (.) . (.) . (.)) .) . fold |
||

+ | </haskell> |
||

+ | |||

+ | == Roman (type-)numerals == |
||

+ | |||

+ | <haskell> |
||

+ | {-# OPTIONS_GHC -fglasgow-exts #-} |
||

+ | module Romans where |
||

+ | |||

+ | class Roman t where |
||

+ | roman :: t -> Int -> 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 (V a) => Roman (I (V a)) where roman _ = roman (undefined :: (V a)) . subtract 1 |
||

+ | 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))) 0, |
||

+ | roman (undefined :: (I (V O))) 0, |
||

+ | roman (undefined :: (V (I (I (I O))))) 0, |
||

+ | roman (undefined :: (X (V (I O)))) 0, |
||

+ | roman (undefined :: (X (X (X (I (I O)))))) 0, |
||

+ | roman (undefined :: (L (X (I (V O))))) 0, |
||

+ | roman (undefined :: (C (X (X (V (I (I (I O)))))))) 0, |
||

+ | roman (undefined :: (C (C (L (V (I O)))))) 0, |
||

+ | roman (undefined :: (D (X (I (I O))))) 0, |
||

+ | roman (undefined :: (M (X (X (I (V O)))))) 0, |
||

+ | roman (undefined :: (M (M (X (L (V (I (I (I O))))))))) 0] |
||

</haskell> |
</haskell> |

## Revision as of 00:18, 29 July 2006

## 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 -> 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 (V a) => Roman (I (V a)) where roman _ = roman (undefined :: (V a)) . subtract 1
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))) 0,
roman (undefined :: (I (V O))) 0,
roman (undefined :: (V (I (I (I O))))) 0,
roman (undefined :: (X (V (I O)))) 0,
roman (undefined :: (X (X (X (I (I O)))))) 0,
roman (undefined :: (L (X (I (V O))))) 0,
roman (undefined :: (C (X (X (V (I (I (I O)))))))) 0,
roman (undefined :: (C (C (L (V (I O)))))) 0,
roman (undefined :: (D (X (I (I O))))) 0,
roman (undefined :: (M (X (X (I (V O)))))) 0,
roman (undefined :: (M (M (X (L (V (I (I (I O))))))))) 0]
```