###### Sprachumschaltung

Sie sind hier: Lösung 01

# Lösung 01

Lösung zu Blatt 01

## Dateiinhalt

```-- | Functional Programming, course at LMU, summer term 2012
--   Andreas Abel and Steffen Jost
--
-- Exercise sheet 1, 2012-04-24

import qualified Data.Set as Set

import Test.QuickCheck
import Test.QuickCheck.All

data Undefined

----------------------------------------------------------------------

-- Exercise 1
-- a) Define functoriality from a monad

infixl 5 <\$>

(<\$>) :: Monad m => (a -> b) -> m a -> m b
f <\$> m = m >>= return . f

-- b) For your implementation, prove the functor laws from the monad laws

{-
Identity:
id <\$> m
= m >>= return . id
= m >>= return
= m

Composition:
f <\$> (g <\$> m)
= m >>= return . g >>= return . f
= m >>= \ x -> return (g x) >>= \ y -> return (f y)
= m >>= \ x -> return (f (g x))
= m >>= return . f . g
= f . g <\$> m
-}

-- Tests for Exercise 1

prop_mmap_identity m =
id <\$> m == (m :: [Int])

prop_mmap_composition f g m =
f <\$> (g <\$> m) == f . g <\$> (m :: [Int])

----------------------------------------------------------------------

-- Exercise 2
-- Option type constructor

data Option a = None | Some a
deriving (Show, Eq, Ord)

return = Some
None   >>= k = None
Some a >>= k = k a

mzero = None
mplus None     m = m
mplus (Some a) m = Some a

-- Tests for Exercise 2

instance Arbitrary a => Arbitrary (Option a) where
arbitrary = frequency [(1, return None), (4, fmap Some arbitrary)]
shrink _  = []

instance Show (a -> b) where
show f = "<function>"

(return a >>= k)         == (k a :: Option Int)
(m >>= return)           == (m   :: Option Int)
(m >>= \ x -> k x >>= l) == (m >>= k >>= l :: Option Int)

prop_mzero_left  m = mzero `mplus` m == (m :: Option Int)
prop_mzero_right m = m `mplus` mzero == (m :: Option Int)
prop_mzero_assoc m1 m2 m3 =
m1 `mplus` (m2 `mplus` m3) == (m1 `mplus` m2) `mplus` (m3 :: Option Int)

prop_zero_bind_l k   = (mzero >>= k) == (mzero :: Option Int)
prop_zero_bind_r m   = (m >> mzero)  == (mzero :: Option Int)

-- Left distribution law does not hold for Option
-- prop_plus_dist_l m n k =
--   ((m `mplus` n) >>= k) == ((m >>= k) `mplus` (n >>= k) :: Option Int)
prop_plus_dist_r m k l =
(m >>= \ x -> k x `mplus` l x) == ((m >>= k) `mplus` (m >>= l) :: Option Int)

----------------------------------------------------------------------

-- Exercise 3
-- Define a service monad that generates unique Integer numbers

unique :: m Integer

newtype Unique a = Unique { un :: State Integer a }

unique = Unique \$ do
s <- get
put \$ s + 1
return s

runUnique :: Unique a -> a
runUnique (Unique m) = evalState m 0

test :: StateT Bool (State Integer) ()
test = do
put 5
put True
x <- not <\$> get
put x

-- Tests for Exercise 3

-- | @uniques n@ generates a list of @n@ different @Integer@s.
uniques :: Int -> [Integer]
uniques n = runUnique \$ forM [1..n] \$ const unique

-- | @allDifferent l@ checks that list @l@ does not contain duplicates.
--   O(n log n), but not implemented efficiently.
allDifferent :: (Eq a, Ord a) => [a] -> Bool
allDifferent l = l == Set.toList (Set.fromList l)

-- | Test that numbers generated by @unique@ are in fact unique.
prop_unique = forAll (choose (1,100)) \$ \ n ->
allDifferent (uniques n)

----------------------------------------------------------------------

-- Implement a monad that lets you pay for computation

pay :: Integer -> m ()

newtype Cost a = Cost { runCost :: (a, Integer) }

return a = Cost (a, 0)
m >>= k  = Cost \$
let (a, i) = runCost m
(b, j) = runCost (k a)
in  (b, i + j)

pay n = Cost ((), n)

-- | @revAppSum xs acc@ reverses @xs@ onto @acc@ and 'pay's amount @x@
--   for each element @x@ of the list @xs@ that is touched.
revAppSum :: MonadCost m => [Integer] -> [Integer] -> m [Integer]
revAppSum []     acc = return acc
revAppSum (x:xs) acc = do
pay x
revAppSum xs (x:acc)

-- | @reverseSum xs@ returns @(reverse xs, sum xs)@ which is computed
--   by a call to 'revAppSum'.
reverseSum :: [Integer] -> ([Integer], Integer)
reverseSum xs = runCost \$ revAppSum xs []

-- Tests for Exercise 4

prop_reverseSum xs = reverseSum xs == (reverse xs, sum xs)

----------------------------------------------------------------------

runTests = \$quickCheckAll
```
Verweise

Artikelaktionen

abgelegt unter: