FUP 馃寱


Table of Contents

Serie 1 馃槆

Substring

Implementieren Sie eine naive (keine Optimierungen) Suchfunktionsubstring, die entscheidet ob das erste Agrument ein Teilstring deszweiten Argumentes ist
substring :: String -> String -> Bool
substring s w =
    ls <= lw && (take ls w == s || substring s (tail w))
    where
      ls = length s
      lw = length w

mysubstring :: String -> String -> Bool
mysubstring x y
    | x == "" = False
    | (length y) < (length x) = False
    | (take (length x)) y == x = True
    | otherwise = mysubstring x $ (drop 1) y

String Search

Implementieren Sie eine Funktion, die in einem gegebenen String alle Vorkomnisse durch "<a>" ersetzt.
parens :: String -> String
parens s
    | ("a" == (take(1) s)) = "<a>" ++ (parens (drop(1) s))
    | length(s) == 0 = ""
    | otherwise =  (take(1) s) ++ (parens (drop(1) s))

parens2 :: String -> String
parens2 s
    | ("abc" == (take(3) s)) = "<abc>" ++ (parens2 (drop(3) s))
    | length(s) == 0 = ""
    | otherwise =  (take(1) s) ++ (parens2 (drop(1) s))

String Reverse

myreverse :: String -> String
myreverse [] = ""
myreverse (x : xs) = myreverse xs ++ [x]

String Palindrom

makePalindrome :: String -> String
makePalindrome w = w ++ myreverse(w)

Fancy Sum

my_sum f m n = foldl (+) 0 [f i | i <- [m..n]]

Serie 2 馃檭

BTree

data BTree a
    = BNode (BTree a) a (BTree a)
    | Leaf a
    deriving Show

collect :: BTree a -> [a]
collect t = case t of
    Leaf x -> [x]
    BNode l x r -> collect l ++ [x] ++ collect r

btree = BNode (Leaf 2) 1 (BNode (Leaf 4) 3 (Leaf 5))

depth :: BTree a -> Integer
depth (Leaf _) = 1
depth (Node _ l r) = 1 + max (depth l) (depth r)

sumTree :: BTree Integer -> Integer
sumTree (Leaf x) = x
sumTree (Node x l r) = x + sumTree l + sumTree r

prodTree :: BTree Integer -> Integer
prodTree (Leaf x) = x
prodTree (Node x l r) = x * prodTree l * prodTree r

type TreeToInt = BTree Integer -> Integer

prodTreeF :: TreeToInt
prodTreeF = treeFold (\x y z -> x * y * z) id

sumTreeF :: TreeToInt
sumTreeF = treeFold add id
    where
        add x y z = x + y + z

depthF :: BTree a -> Integer
depthF = treeFold f (const 1)
    where
--        f x y = 1 + max x y
        f :: a -> Integer -> Integer -> Integer
        f _ = curry ((+1) . (uncurry max))

treeFold
    :: (a -> b -> b -> b)
    -- ^^ Ersatz f眉r Node
    -> (a -> b)
    -- ^^ Ersatz f眉r Leaf
    -> BTree a -> b
treeFold node leaf t = case t of
    Node x l r -> node x (recurse l) (recurse r)
    Leaf x -> leaf x
    where
        recurse = treeFold node leaf

ListTree

data Tree a = Tree a [Tree a]
    deriving (Show, Eq)

collect2 :: Tree a -> [a]
collect2 (Tree a ts) = a:(concatMap collect2 ts)

sum2 :: Tree Integer -> Integer
sum2 (Tree a ts) = a + foldl (+) 0 (map sum2 ts)

tree :: Tree Integer
tree =
    Tree 1
      [ Tree 2 []
      , Tree 3 []
      , Tree 4
        [ Tree 5 []
        , Tree 6 []
        ]
      ]

Nat Number

data Nat = Zero | Succ Nat
    deriving (Show, Eq)

eval :: Nat -> Integer
eval Zero = 0
eval (Succ n) = 1 + eval n
--   ( n + 1 ) = 1 + n

interpret :: Integer -> Nat
interpret 0 = Zero
interpret n = Succ $ interpret (n-1)

add :: Nat -> Nat -> Nat
add Zero y = y
add (Succ n) y = Succ (n `add` y)

-- x = interpret 5
-- y = interpret 7
-- x `add` y
-- --> Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))))))))
-- eval $ x `add` y
-- --> 12

mul :: Nat -> Nat -> Nat
mul Zero y = Zero
mul (Succ n) y = (n `mul` y) `add` y

fakt :: Nat -> Nat
fakt Zero = Succ Zero
fakt (Succ n) = (Succ n) `mul` (fakt n)


-- Use addition and multiplication to define factorial
--fact :: NatNumber -> NatNumber
--fact Zero = Succ Zero
--fact (Succ n) = Succ n `mul` fact n

--msum :: NatNumber -> NatNumber
--msum Zero = Zero
--msum (Succ n) = Succ n `add` msum n

--cfact n = eval $ fact $ interpret n

Fraction

data Fraction = Fraction
    { numerator :: Integer
    , denumerator :: Integer
    }

mulF :: Integer -> Fraction -> Maybe Integer
mulF _ (Fraction _ 0) = Nothing
mulF a (Fraction x y)
    | a * x `mod` y == 0 = Just $ a * x `div` y
    | otherwise = Nothing
type Program = [Fraction]
type Input = Integer
type Output = [Integer] --type ist alias
-- (i:is) i = instruktion --> is = rest
-- p ist im Kontext und wird nicht ver盲ndert
-- --> Eingepackte funktion
execute :: Program -> Input -> Output
execute p n = reverse $ aux p [] n
    where
        aux [] acc n = (n:acc)
        aux (i:is) acc n = case n `mulF` i of
            Just m -> aux p (n:acc) m
            Nothing -> aux is acc n
--run p n = execute p p n
xp = [ Fraction 5 3
    , Fraction 2 5
    ]

Sort Datatype (Car)

data Model = Model String deriving (Eq, Show, Ord)
data Make = Make String deriving (Eq, Show, Ord)
data Color = Color String deriving (Eq, Show, Ord)
data Power
    = HP Integer
    | KW Integer
    deriving (Eq, Show, Ord)

toHP :: Power -> Integer
toHP (HP x) = x
toHP (KW x) = (134 * x) `div` 100

data  Car = Car
    { model :: Model
    , make :: Make
    , year ::  Integer
    , color  :: Color
    , power  ::  Power
    } deriving (Eq, Show)

-- import Data.List
instance Ord Car where
    (<=) car1 car2 = (car1 == car2) || (toHP (power car1)) <= (toHP (power car2))

ford = Car
    { model = Model "Fiesta"
    , make = Make "Ford"
    , year = 2017
    , color = Color "red"
    , power = HP 70
    }

-- hier muss Reihenfolge stimmen
ferrari = Car
    (Model "Testarossa")
    (Make "Ferrari")
    1999
    (Color "green")
    (KW 250)
-- toHP $ power ferrari

zoe = Car
    (Model "Zo茅")
    (Make "Renault")
    2018
    (Color "white")
    (HP 110)

sortedCars = sort [zoe, ferrari, ferrari, ford]

sort [Color "red", Color "blue"]
-- [Color "blue",Color "red"]

Serie 3 馃ズ

Regex

-------------------------------------------------------------------------------
-- | Auxiliary list and string functions
-------------------------------------------------------------------------------

import Data.List

-- | All partitions of a List in two parts.
part :: [a] -> [([a],[a])]
part xs = map (\n -> (take n xs, drop n xs)) [1 .. l]
    where
        l = length xs

-- *Main> part [1,2,3]
-- [([1],[2,3]),([1,2],[3]),([1,2,3],[])]

-------------------------------------------------------------------------------
-- | Syntax
-------------------------------------------------------------------------------

-- | The abstract syntax tree (AST) of regular expressions
data Regex
    = Empty
    | Epsilon
    | Symbol Char
    | Concat [Regex]
    | Or [Regex]
    | Plus Regex
    deriving (Show, Eq)

-- | The catamorphism matching the AST
regex
    :: a
    -> a
    -> (Char -> a)
    -> ([a] -> a)
    -> ([a] -> a)
    -> (a -> a)
    -> Regex
    -> a
regex em ep sym con choice plus expression =
    case expression of
        Empty -> em
        Epsilon -> ep
        Symbol s -> sym s
        Concat rs -> con $ map recurse rs
        Or rs -> choice $ map recurse rs
        Plus r -> plus $ recurse r
    where
        recurse = regex em ep sym con choice plus

-------------------------------------------------------------------------------
-- | Makros i.e. syntax extensions
-------------------------------------------------------------------------------

-- | Kleene's star
star :: Regex -> Regex
star r = Or [Epsilon, Plus r]

-- | One or zero repetitions
maybe :: Regex -> Regex
maybe r = Or [Epsilon, r]

-- | Exactly n repetitions
times :: Int -> Regex -> Regex
times n r = Concat $ take n $ repeat r -- Repeat R = unendlich lange liste

-------------------------------------------------------------------------------
-- | Semantics of regular expressions in terms of String predicates
-------------------------------------------------------------------------------

eval :: Regex -> (String -> Bool)
eval = regex em ep sym serial choice plus
    where
        em = const False -- em = \x -> False
        ep = (==) "" -- ep = \x -> x == ""
        sym c = (==) [c]
        -- charToString c = [c]
        -- charToString = (:[])
        choice fs s = or $ map (\f -> f s) fs
        -- *Main> choice [(==) "a", (==) "", (==) "b"] "a"
        -- [True,False,False]
        serial :: [String -> Bool] -> String -> Bool
        serial [] "" = True
        serial (f:fs) "" = f "" && serial fs ""
        serial [] _ = False
        serial (f:fs) str =
            or
            $ map (\(x,y) -> f x && serial fs y)
            $ part str

        -- *Main> serial [((==) "a"),((==) "b"), ((==) "c")] "abc"
        -- True

        -- *Main> even xs = length xs `mod` 2 == 0
        -- *Main> serial [even, not . even] "aabc"
        -- False
        -- *Main> serial [even, not . even] "aabca"
        -- True
        -- *Main> odd = not . even
        -- *Main> serial [even, odd] "aabca"
        -- True

        plus :: (String -> Bool) -> String -> Bool
        plus f str =
            or
            $ map (\(s, t) -> f s && (t == "" || plus f t))
            $ part str

-------------------------------------------------------------------------------
-- | Examples
-------------------------------------------------------------------------------

-- | a
ra :: Regex
ra = Symbol 'a'

-- | b
rb :: Regex
rb = Symbol 'b'

-- | c
rc :: Regex
rc = Symbol 'c'

-- | (a|b)
avb :: Regex
avb = Or [ra, rb]

-- | x
rx :: Regex
rx = Symbol 'x'

-- | y
ry :: Regex
ry = Symbol 'y'

-- | (x|y)
xvy :: Regex
xvy = Or [rx, ry]

-- | (x|y)(a|b)
xyCab :: Regex
xyCab = Concat [xvy, avb]

-- | (x|y)*
xyStar :: Regex
xyStar = star xvy

-- | r = (a|b)*abc(x|y)
exRegex :: Regex
exRegex = Concat [star avb, ra, rb, rc, xvy]

Serie 4 馃槣

Hanoi

Wikipedia
hanoi 0 a b c = []
hanoi n a b c = moves1 ++  [(a,c)] ++ moves2
    where
        moves1 = hanoi (n-1) a c b
        moves2 = hanoi (n-1) b a c
-- hanoi 3 'a' 'b' 'c'
-- -> [('a','c'),('a','b'),('c','b'),('a','c'),('b','a'),('b','c'),('a','c')]
hanoiAB 0 = []
hanoiAB n = hanoiAC (n-1) ++ [("a","b")] ++ hanoiCB (n-1)
hanoiAC 0 = []
hanoiAC n = hanoiAB (n-1) ++ [("a","c")] ++ hanoiBC (n-1)
hanoiBC 0 = []
hanoiBC n = hanoiBA (n-1) ++ [("b","c")] ++ hanoiAC (n-1)
hanoiBA 0 = []
hanoiBA n = hanoiBC (n-1) ++ [("b","a")] ++ hanoiCA (n-1)
hanoiCA 0 = []
hanoiCA n = hanoiCB (n-1) ++ [("c","a")] ++ hanoiBA (n-1)
hanoiCB 0 = []
hanoiCB n = hanoiCA (n-1) ++ [("c","b")] ++ hanoiAB (n-1)
-- hanoiAC 3
-- -> [("a","c"),("a","b"),("c","b"),("a","c"),("b","a"),("b","c"),("a","c")]

Primitive Rekursion Extended

primRec g c n x
    | n == 0 = c x
    | otherwise = g (f (n-1) x) n x
    where
        f = primRec g c
exp_ x 0 = 1
exp_ x y = x * exp_ x (y-1)
--         ^g(f (n-1) x) n x
-- Achtung Argumente vertauscht: Aufruf: exp'sol 10 2
exp'sol = primRec g c
    where
        g k _ x = k * x
        c = const 1
myExp = flip exp'sol -- damit normal aufgerufen werden kann

Fixpunkt

Implementieren Sie ein Funktional primesF, so dass fix primesF eine Funktion ergibt, die zu gegebenem Int n eine Liste mit allen Primzahlen bis (inklusive) n zur眉ckgibt.
fix ::((a->b) ->a -> b) -> a -> b
fix f = f (fix f)

primesF :: ((Integer -> [Integer]) -> Integer -> [Integer])
primesF f n
    | n < 2 = []
    | all check ps = n:ps
    | otherwise = ps
    where
        ps = f $ n-1
        check p = n `mod` p /= 0
-- *Main> all (check 4) [3,2]
-- False
-- *Main> all (check 5) [3,2]
-- True

exp2_ 0 = 1
exp2_ n = 2 * (exp2_ (n-1))

exp2_F f 0 = 1
exp2_F f n = 2 * (f (n-1))
-- (fix expF) 11
-- expF (fix expF) 11
-- 2 * (fix expF 10)
-- ...
-- 2 * ... * 2 * (fix expF 0)
-- 2 * ... * 2 * (expF (fix expF) 0)
-- 2 * ... * 2 * (1)

-- f = fix primesF
-- f 0 = []
-- f 1 = []
-- f 2 = [2]
-- f 3 = [3,2]
-- f 4 = [3,2]
-- f 5 = [5,3,2]

str f 0 = ""
str f n = (show n) ++ f (n-1)

check n p = n `mod` p /= 0

Serie 5 馃く

Functor Laws

Datentyp

newtype Boxed a = Boxed {unbox :: a}
    deriving Show

instance Functor Boxed where
    -- f <$> (Boxed a) = Boxed (f a)
    fmap f (Boxed a) = Boxed (f a)

b = Boxed 10

x1 = fmap id b

x1_1 = fmap ((+1) . (+2)) b
x1_2 = fmap (+1) $ fmap (+2) b
Claim:
1) id <$> (Boxed x) = Boxed $ id x = Boxed x
2) (f.g) <$> (Boxed x) = Boxed $ (f . g) x
                       = Boxed $ f (g x)
                       = f <$> (Boxed (g x))
                       = f <$> (g <$> (Boxed x))

Funktion

Idee: FromInt b ist wie unendliche Liste mit b's drin
newtype FromInt a = FromInt {fun :: Integer -> a} -- FromInt isch en stream / unendlichi lischte

ff = FromInt (+2)
-- fun ff $ 22
-- 24

-- ... f (-2), f (-1), f 0, f 1, f 2, ...
-- a
-- Idee:
-- g <$> [ ..., f (-1), f 0, f 1, f 2, ...]
-- [ ..., g (f (-1)), g (f 0), g (f 1), g (f 2), ...]
-- [ ..., (g.f) (-1), (g.f) 0, (g.f) 1, (g.f) 2, ...]
instance Functor FromInt where
    -- fmap :: (a -> b) -> FromInt a -> FromInt b
    -- f <$> (FromInt g) = FromInt $ f . g
    fmap g (FromInt f) =        FromInt $ g . f
    --      ^ (a_i)_{i:Int}     ^ (b_i)_{i:Int}

-- [  1,   2,   3, ...]
-- [f 1, f 2, f 3, ...]
-- ...   -2,   -1,   0,   1,   2, ...
-- ... f -2, f -1, f 0, f 1, f 2, ...

example = FromInt f
    where
        f n
            | n >= 0 = take n (concat (repeat "a"))
            | otherwise = take (-n) (concat (repeat "b"))
-- fun example 17    ==> "aaaaaaaaaaaaaaaaa"
-- fun example (-10) ==> "bbbbbbbbbb"
Claim:
1) id <$> ff = ff
-- klar -> wenn keine rekursion d盲nn chamer eifach iisetze

2) (f.g) <$> ff = f <$> (g <$> ff)
-- Idee: f . (g . h) = (f . g) . h -- h isch ff uuspackt...
2) (f.g) <$> (FromInt h) = FromInt $ (f . g) . h
                         = FromInt $ f . (g . h)
                         = f <$> FromInt $ g . h
                         = f <$> (g <$> (FromInt h))

Maybe Tree

data MBTree a
    = Leaf a
    | MBTree (MBTree a) (Maybe a) (MBTree a)

tree = MBTree
    (MBTree (Leaf 1) (Just 3) (Leaf 2))
    (Just 4)
    (MBTree (Leaf 3) (Just 5) (Leaf 4))

treeFold node leaf (MBTree l x r) = do
        left <- recurse l
        right <- recurse r
        x11 <- x
        return $ node left x11 right
        where
            recurse = treeFold node leaf
treeFold node leaf (Leaf x) = leaf x

depth :: MBTree a -> Integer
depth (Leaf _) = 1
depth (MBTree l _ r) = 1 + max (depth l) (depth r)

mtfold :: (a -> t -> a -> a) -> (t -> Maybe a) -> MBTree t -> Maybe a
mtfold ftree fleaf t = case t of
    MBTree l x r -> ftree <$> (recurse l) <*> x <*> (recurse r)
    Leaf x -> fleaf x
    where
        recurse = mtfold ftree fleaf

treeSum = mtfold (\l x r -> x + l + r) return
treeProd = mtfold (\l x r -> x * l * r) return
-- treeSum tree
Claim:
Unfolding definition:
f <$> (Leaf x) = Leaf $ f x
f <$> (MBTree l ma r) = MBTree (f <$> l) (f <$> ma) (f <$> r)
--                             rekursiv   map maybe  rekursiv
-- bi l und r isch uf de tree und bi ma isch uf de maybe aagw盲ndet

-- Claim: instance satisfies Functor laws.
-- Proof:
1) id <$> (Leaf x) = Leaf $ id x = Leaf x
   id <$> (MBTree l ma r) = MBTree (id <$> l) (id <$> ma) (id <$> r)
--                          ^induction        ^ maybe f.  ^induction
                          = MBTree l ma r

2) (f.g) <$> (Leaf x) = Leaf $ (f . g) x
                      = Leaf $ f (g x)
                      = f <$> Leaf $ g x
                      = f <$> (g <$> (Leaf x))

   (f.g) <$> (MBTree l ma r) = MBTree ((f.g)<$>l) ((f.g)<$>ma) ((f.g)<$>r)
                     -- apply induction + functor laws for Maybe
                     = MBTree (f <$> (g<$>l)) (f <$> (g<$>ma)) (f <$> (g<$>l))
                     = f <$> (MBTree (g<$>l) (g<$>ma) (g<$>l))
                     = f <$> (g <$> (MBTree l ma l))

Contravariant

newtype ToInteger a = ToInteger (a -> Integer)

app :: ToInteger a -> a -> Integer
app (ToInteger f) x = f x

contra :: (b -> a) -> ToInteger a -> ToInteger b
contra f (ToInteger g) = ToInteger $ g . f

instance Contravariant ToInteger where
    contramap = contra

Serie 7 馃コ

Endrekursive Tree

Akkumulator + Continuation

BTree: Depth

data Tree a = Leaf a | Node a (Tree a) (Tree a)
    deriving Show

depth :: Tree a -> Integer
depth tree = recursion 0 [tree]
    where
        recursion :: Integer -> [Tree a] -> Integer
        recursion n [] = n
        recursion n treeList = recursion (n+1) (concatMap f treeList)
            where
                f (Leaf _) = []
                f (Node _ left right) = [left, right]

root = Node 1 (Node 2 (Leaf 3) (Leaf 3)) (Leaf 7)

main :: IO ()
main = print $ depth root

BTree: Sum & collect

data Tree a = Node a (Tree a) (Tree a) | Leaf a
    deriving Show

sumT :: Num a => Tree a -> a
sumT (Leaf a)     = a
sumT (Node a l r) = a + (sumT l) + (sumT r)

sumRec :: Num a => Tree a -> a
sumRec tree = recursion 0 [tree]
    where
        recursion acc [] = acc
        recursion acc treeList = recursion (acc + (treeSum treeList)) (flattenList treeList)
            where
                treeSum = sum . map treeValue

                treeValue (Leaf val)     = val
                treeValue (Node val _ _) = val

                flattenList = concatMap f

                f (Leaf _)            = []
                f (Node _ left right) = [left, right]

show' = \tree -> go tree id
    where
        go (Node _ left right) c = go left (\l -> go right (\r -> c ("(Node " ++ l ++ " " ++ r ++ ")")))
        go (Leaf _) c = c "Leaf"

-- Extended Solution
collect :: Tree a -> [a]
collect tree = go [tree] []
    where
        go []       acc = acc
        go treeList acc = go (flattenList treeList) (acc ++ treeValues treeList )
            where
                treeValues = map treeValue
                treeValue (Leaf val    ) = val
                treeValue (Node val _ _) = val
                flattenList = concatMap f
                f (Leaf _           ) = []
                f (Node _ left right) = [left, right]

sumT2 :: Num a => Tree a -> a
sumT2 = sum . collect

root = Node 1 (Node 2 (Leaf 3) (Leaf 3)) (Leaf 7)

-------------------------
-- Akkumulator Pattern
-------------------------
sumTSmall tree = sumTAcc 0 [tree]
sumTAcc :: Integer -> [Tree Integer] -> Integer
sumTAcc acc [] = acc
sumTAcc acc (x:xs) = case x of
    (Node n l r) -> sumTAcc (acc + n) (l:r:xs)
    (Leaf n)     -> sumTAcc (acc + n) xs
-------------------------
-- **Best Solution** Akkumulator: Collect
-------------------------
sumT' tree = (sum (erCollect [] [tree]))
erCollect :: Num a =>  [a] ->[Tree a] -> [a]
erCollect acc [] = acc
erCollect acc (x:xs) = case x of
    (Node n l r) -> erCollect (acc ++ [n]) (l:r:xs)
    (Leaf n)     -> erCollect (acc ++ [n]) xs
-------------------------
-------------------------
-- Continuation Pattern
-------------------------
sumTR' :: Num a => Tree a -> a
sumTR' t = sumTR_ (const 0) [t]
    where
      sumTR_ f [] = f ()
      sumTR_ f ((Node a l r):ts) = sumTR_ f ((Leaf a):l:r:ts)
            -- Node zu Leaf machen
      sumTR_ f ((Leaf a):ts) = sumTR_ (\x -> a + (f x)) ts
-------------------------
-- Continuation Case of
-------------------------
sumTR'' :: Num a => Tree a -> a
sumTR'' t = sumTR_ (const 0) [t]
    where
      sumTR_ f [] = f ()
      sumTR_ f (t:ts) = case t of
        (Node n l r) -> sumTR_ (\x -> n + (f x)) (l:r:ts)
        (Leaf n)     -> sumTR_ (\x -> n + (f x)) ts
-------------------------
-- **Best Solution** Continuation: Collect
-------------------------
sumCollectTR'' = sum . collectTR''
collectTR'' t = collectTR_ (\x -> []) [t]
    where
      collectTR_ f [] = f undefined
      collectTR_ f (t:ts) = case t of
        (Node n l r) -> collectTR_ (\x -> n:(f x)) (l:r:ts)
        (Leaf n)     -> collectTR_ (\x -> n:(f x)) ts

TreeList: Depth & Sum & collect

data Tree a = Tree a [Tree a] deriving Show

depth :: Tree a -> Integer
depth tree = go [tree] 0
    where
        go :: [Tree a] -> Integer -> Integer
        go []       acc = acc
        go treeList acc = go (concatMap f treeList) (acc + 1)
            where
                f (Tree _ []) = []
                f (Tree _ xs) = xs

collect :: Tree a -> [a]
collect tree = go [tree] []
    where
        go []       acc = acc
        go treeList acc = go (flattenList treeList) (acc ++ treeValues treeList )
            where
                treeValues = map treeValue
                treeValue (Tree val _) = val
                flattenList = concatMap f
                f (Tree _ []) = []
                f (Tree _ xs) = xs

sumT :: Num a => Tree a -> a
sumT = sum . collect



root = Tree 1 [Tree 2 [Tree 3 [Tree 4 []]], Tree 5 [Tree 6 [],Tree 6 [],Tree 6 [Tree 7 [Tree 8 [Tree 8 [Tree 8 []]]]]]]

Monad =<<

concatMap (\x -> [x,x+1]) [1,2,3]
--[1,2,2,3,3,4]
map (\x -> [x,x+1]) [1,2,3]
--[[1,2],[2,3],[3,4]]
(\x -> [x,x+1]) =<< [1,2,3]
--[1,2,2,3,3,4]

Deep Embedding (EDSL)

Deep Shape

import Data.Set
type Point = (Float, Float)
type Vector = (Float, Float)

data Shape
    = Empty
    | UnitDisc
    | UnitSq
    | Translate Vector Shape
    | Negate Shape
    | Intersect Shape Shape
    | Merge Shape Shape
    | Minus Shape Shape

combineBool
    :: (Bool -> Bool -> Bool)
    -> (Point -> Bool)
    -> (Point -> Bool)
    -> Point -> Bool
combineBool op f1 f2 point = f1 point `op` f2 point


inside :: Shape -> Point -> Bool
inside s (x,y) = case s of
    Empty -> False
    UnitDisc -> x^2 + y^2 <= 1
    UnitSq -> abs x <= 1 && abs y <= 1
    Translate (dx,dy) s' -> inside s' (x - dx,y - dy)
    Negate s' -> not $ inside s' (x,y)
    -- Intersect s1 s2 -> combineBool (&&) (inside s1) (inside s2) $ (x, y)
    Intersect s1 s2 -> inside s1 (x, y) && inside s2 (x, y)
    Merge s1 s2 -> inside s1 (x, y) || inside s2 (x, y)
    Minus s1 s2 -> inside s1 (x, y) && not (inside s2 (x, y))

Deep Term

data Term = Term Integer
    deriving (Show, Eq)
constantT :: Integer -> Term
constantT = Term

sumT :: Term -> Term -> Term
sumT (Term a) (Term b) = Term $ a + b

productT :: Term -> Term -> Term
productT (Term a) (Term b) = Term $ a * b

exampleT :: Term
exampleT = sumT
    (productT (constantT 4) (constantT 3))
    (sumT (constantT 2) (constantT 1))


data DeepTerm
    = Const Integer
    | Sum DeepTerm DeepTerm
    | Prod DeepTerm DeepTerm
    deriving (Show, Eq)

eval :: DeepTerm -> Integer
eval t = case t of
    Const x -> x
    Sum t1 t2 -> (eval t1) + (eval t2)
    Prod t1 t2 -> (eval t1) * (eval t2)

--eval :: Term -> Integer
--eval (Term t) = t

exampleDT :: DeepTerm
exampleDT = Sum
    (Prod (Const 4) (Const 3))
    (Sum (Const 2) (Const 1))

exampleT2 = productT
    (constantT 7)
    (sumT
        (constantT 2)
        (sumT (constantT 3) (constantT 4)))

Deep Term mit Maybe

data DeepTerm
    = Const (Maybe Integer)
    | Sum DeepTerm DeepTerm
    | Prod DeepTerm DeepTerm
    | Div DeepTerm DeepTerm
    deriving (Show, Eq)

evalTerm s = case s of
    Const s -> s
    Sum x y -> return (+) <*> (evalTerm x) <*> (evalTerm y)
    Prod x y -> return (*) <*> (evalTerm x) <*> (evalTerm y)
    Div x y -> do
        tx <- evalTerm x
        ty <- evalTerm y
        let result | ty == 0 = fail "Div by Zero"
                   | otherwise = return $ tx `div` ty
        result

justTerm :: DeepTerm
justTerm = Sum
    (Prod (Const (Just 4)) (Const (Just 3)))
    (Sum (Const (Just 2)) (Const (Just 1)))

divTerm :: DeepTerm
divTerm = Div (Const (Just 10)) (Const (Just 0))

Deep Polynomial

newtype Polynomial = Polynomial { app :: Integer -> Integer}

instance Show Polynomial where
  show (Polynomial a) = show $ a 2

addP :: Polynomial -> Polynomial -> Polynomial
addP (Polynomial p1) (Polynomial p2) = Polynomial $
    \x -> p1 x + p2 x

monome :: Integer -> Integer -> Polynomial
monome coefficient exponent = Polynomial $
    \x -> coefficient * x^exponent

sumNotation :: [Integer] -> Polynomial
sumNotation xs = Polynomial $
    \x -> sum (map (\(c,e) -> c*x^e) xsIndexed)
    where
        xsIndexed = zip xs [0..]

printSumNotation xs = map (\(c,e) -> (show c) ++ "*x" ++ "^" ++ (show e)) xsIndexed
    where
        xsIndexed = zip xs [0..]

-- x^2 + 2
res1 = addP (monome 2 0) (monome 1 2)

data DeepPolynomial
    = AddP DeepPolynomial DeepPolynomial
    | Monome Integer Integer
    | SumNotation [Integer]


eval t = case t of
    AddP p1 p2 -> \x -> (eval p1) x + (eval p2) x
    Monome coefficient exponent -> \x -> coefficient * x^exponent
    SumNotation xs -> \x -> sum (map (\(c,e) -> c*x^e) xsIndexed)
        where
            xsIndexed = zip xs [0..]

deepRes1 = eval $ AddP (Monome 2 0) (Monome 1 2)

-- x - x^3
deepMonome = eval $ AddP (Monome 1 1) (Monome (-1) 3)
deepSumNot = eval $ SumNotation [0,1,0,-1]
-- printSumNotation [0,1,0,-1]

test = deepMonome 123 == deepSumNot 123

Rekursion 馃攣

klassische Rekursion

fibo 0 = 0
fibo 1 = 1
fibo n = fibo (n-1) + fibo (n-2)
---------------------------------------------
sieve :: (a -> a -> Bool) -> [a] -> [a]
sieve pred xs = case xs of
    []   -> []
    x:xs -> x:(sieve pred $ filter (pred x) xs)

-- -> sieve (\x y -> mod y x /= 0) [2..100]

Wertverlaufsrekursion

covR g n x = g [f i x | i <- [0 .. (n-1)]] n x
    where
        f = covR g

fib = covR g
    where
        g [] _ _ = 0
        g [x] _ _ = 1
        g xs _ _ = head (reverse xs) + head (reverse (init xs))

-- *Main> map (\x -> fib x ()) [0..10] --> [0,1,1,2,3,5,8,13,21,34,55]

-- Hier ist Liste bereits Reversed!
covRec :: ([Integer] -> Integer) -> Integer -> Integer
covRec g n = g $ reverse [f i | i <- [0..(n-1)]]
    where
        f = covRec g

fibo = covRec g
    where
        g [] = 0
        g [x] = 1
        g (x:y:xs) = x + y

-- *Main> map fibo [0..10]
-- [0,1,1,2,3,5,8,13,21,34,55]

Akkumulator Pattern

fiboFast (x:xs) 0 = x
fiboFast (x:y:xs) n = fiboFast (x+y:x:y:xs) (n-1)

fibo2 n = fiboFast [1,0] (n-1)

fibo3 = f 1 0
    where
        f l vl 0 = vl
        f l vl n = f (l+vl) l (n-1)
---------------------------------------------
sieve1 :: [a] -> (a -> a -> Bool) -> [a] -> [a]
sieve1 acc pred xs = case xs of
    []   -> reverse acc
    x:xs -> sieve1 (x:acc) pred $ filter (pred x) xs
-- -> sieve1 [] (\x y -> mod y x /= 0) [2..100]

Continuations Pattern

sieve2 con pred xs = case xs of
    []   -> con []
    x:xs -> sieve2 (\y -> con $ x:y) pred (filter (pred x) xs)
-- -> sieve2 id (\x y -> mod y x /= 0) [2..100]
getPrimes n = sieve2 id (\x y -> mod y x /= 0) [2..n]

Fun App Mon 馃殌

data AExp
    = Const Integer
    | Div AExp AExp
    deriving Show

data Result a
    = Result a
    | Error String
    deriving Show

-- Div 2 0 -> error

safeDiv :: Integer -> Integer -> Result Integer
safeDiv x 0 = Error "Division by zero attempt"
safeDiv x y = Result $ x `div` y

evalAExp :: AExp -> Result Integer
evalAExp (Const x) = Result x
evalAExp (Div ex1 ex2) = case evalAExp ex1 of
    Error msg -> Error msg
    Result y1 -> case evalAExp ex2 of
        Error msg -> Error msg
        Result y2 -> safeDiv y1 y2

evalM :: AExp -> Result Integer
evalM (Const x) = Result x
evalM (Div e1 e2) = do
    y1 <- evalM e1
    y2 <- evalM e2
    safeDiv y1 y2


instance Functor Result where
    -- (a -> b) -> Result a -> Result b
    fmap f (Result x) = Result $ f x
    fmap _ (Error msg) = Error msg

instance Applicative Result where
    -- a -> Result a
    pure = Result
    -- <*> :: Result (a -> b) -> Result a -> Result b
    (Result f) <*> Result x = Result $ f x
    (Error msg) <*> _ = Error msg
    _ <*> (Error msg) = Error msg

instance Monad Result where
    -- Result a -> (a -> Result b) -> Result b
    (Result x) >>= f = f x
    (Error msg) >>= f = Error msg
safeDiv x y = do
        x1 <- x
        y1 <- y
        if y1 == 0 then fail "Div by Zero"
        else return $ x1 `div` y1

Functor $

predec :: Int -> Maybe Int
predec x
    | x <= 1    = Nothing
    | otherwise = Just $ x - 1

divS :: Int -> Int -> Maybe Int
divS x y | y == 0    = Nothing
         | otherwise = Just $ x `div` y

f :: Int -> Int
f x = 2 * x

g :: Int -> Maybe Int
g x = f <$> predec x

Applicative *

h :: Int -> Int -> Maybe Int
h x y = (*) <$> predec x <*> predec y

drei :: Int -> Int -> Int -> Int
drei x y z = x + y + z

d :: Int -> Int -> Int -> Maybe Int
d x y z = drei <$> predec x <*> predec y <*> predec z

data User = User
    { uName  :: String
    , uEmail :: String
    , uCity  :: String
    } deriving Show

type Profile = [(String, String)]

petersProfile :: Profile
petersProfile =
    [ ("name", "peter")
    , ("email", "peter@peter.com")
    , ("city", "zueri")
    ]

incompleteProfile :: Profile
incompleteProfile =
    [ ("name", "Hans")
    , ("emaill", "hans@abc.com")
    , ("city", "zueri")
    ]

myLookup :: String -> Profile -> Maybe String
myLookup str [] = Nothing
myLookup str ((key, value):assocs)
    | str == key = Just value
    | otherwise = myLookup str assocs

buildUser :: Profile -> Maybe User
buildUser profile =
    case myLookup "name" profile of
        Nothing -> Nothing
        Just name -> case myLookup "email" profile of
            Nothing -> Nothing
            Just email -> case myLookup "city" profile of
                Nothing -> Nothing
                Just city -> Just $ User name email city

peter :: Maybe User
peter = buildUser petersProfile

buildUserAp :: Profile -> Maybe User
buildUserAp profile = User
    <$> myLookup "name" profile
    <*> myLookup "email" profile
    <*> myLookup "city" profile

Monad >>=

type CityBase = [(String, String)]

buildUserC :: Profile -> CityBase -> Maybe User
buildUserC profile cities =
    case myLookup "name" profile of
        Nothing -> Nothing
        Just name -> case myLookup "email" profile of
            Nothing -> Nothing
            Just email -> case myLookup email cities of
                Nothing -> Nothing
                Just city -> Just $
                    User name email city

buildUserCM :: Profile -> CityBase -> Maybe User
buildUserCM profile cities = do
    name  <- myLookup "name" profile
    email <- myLookup "email" profile
    city  <- myLookup email cities
    pure $ User name email city

buildUserB :: Profile -> CityBase -> Maybe User
buildUserB profile cities =
    myLookup "name" profile
        >>= \name -> myLookup "email" profile
        >>= \email -> myLookup email cities
        >>= \city -> pure $ User name email city

annasProfile :: Profile
annasProfile =
    [ ("name", "Anna")
    , ("email", "anna@nasa.gov")
    ]

citiesB :: CityBase
citiesB = [("anna@nasa.gov", "Washington")]

Lambda (位) Calculus 馃

lambdacalc.io

Reduktion

(Lx.(x y) Lz.z)
(Lz.z y)
y
-----------------------------------------------------------
-- geht in normal order reduction,
-- nicht aber in applicative order reduction:
(Lx.y (Lx.(x x) Lx.(x x)))

-- geht gar nicht:
(Lx.(x x) Lx.(x x))
-----------------------------------------------------------
(((Lxyz.((x y) (x z)) Lx.a) b) c)
(Lz.((Lx.a b) (Lx.a z)) c)
(Lx.a b) (Lx.a c)
(a a)
a a
-----------------------------------------------------------
-- Beta Normalform m枚glich?
(Lx.(x x) Lx.(x x))              --> Nein
(Lx.(x y) Lz.z) -> (Lz.z y) -> y --> Ja
(Lx.y (Lx.(x x) Lx.(x x)))  -> y --> Ja // Mittels Lazy Eval
(Lx.x (Lx.(x x) Lx.(x x)))       --> Nein

Free Vars

import Data.Set (Set, singleton, union, empty, delete, insert, disjoint)
-----------------------------------------------------------
-- | Simple lambda terms
-----------------------------------------------------------
data Term
    = Var String
    | App Term Term
    | Abs String Term
    deriving (Show, Eq)
pretty :: Term -> String
pretty = prettyE . emb
    where
        emb (Var str) = EVar str
        emb (App t1 t2) = EApp (emb t1) (emb t2)
        emb (Abs x t) = EAbs x (emb t)
-- 位f.位x. f^n x
churchEnc :: Integer -> Term
churchEnc n = Abs "f" (Abs "x" (c n))
  where
    c :: Integer -> Term
    c k | k < 1 = Var "x"
        | otherwise = App (Var "f") (c (k-1))
--位n.位f.位x. f (n f x)
churchSucc :: Term
churchSucc = Abs "n" $ Abs "f" $ Abs "x"
    (App (v "f") (App (App (v "n") (v "f")) (v "x")))
    where
        v = Var
term :: (String -> a) -> (a -> a -> a) -> (String -> a -> a) -> Term -> a
term var app abst lTerm = case lTerm of
    Var str -> var str
    App t s -> app (re t) (re s)
    Abs str t -> abst str (re t)
    where
        re = term var app abst
freeVars :: Term -> Set String
freeVars = term singleton union delete
boundVars :: Term -> Set String
boundVars = term (const empty) union insert
-- | substitute A x B = A [x:=B]
subs :: Term -> String -> Term -> Term
subs a v b = case a of
    Var str | str == v  -> b
            | otherwise -> a
    App t1 t2 -> App (subs t1 v b) (subs t2 v b)
    Abs x t | x == v -> a
            | disjoint (freeVars b) (boundVars a) ->
                Abs x (subs t v b)
            | otherwise -> undefined
-----------------------------------------------------------
-- | Extended lambda terms
-----------------------------------------------------------
data ETerm
    = Add
    | N Integer
    | EVar String
    | EApp ETerm ETerm
    | EAbs String ETerm
    deriving Show
eterm :: a -> (Integer -> a) -> (String -> a) -> (a -> a -> a) -> (String -> a -> a) -> ETerm -> a
eterm add_ n evar eapp eabs term = case term of
    Add -> add_
    N x -> n x
    EVar str -> evar str
    EApp t s -> eapp (re t) (re s)
    EAbs str t -> eabs str (re t)
    where
        re = eterm add_ n evar eapp eabs
prettyE :: ETerm -> String
prettyE Add = "Add"
prettyE (N x) = show x
prettyE (EVar name) = name
prettyE (EApp t l) = "(" ++ (prettyE t) ++ " " ++ (prettyE l) ++ ")"
prettyE (EAbs x t) = "L" ++ x ++ "." ++ (prettyE t)

---------------------------------------
----- EDIT HERE: (((位xyz.((x y) (x z)) 位x.a) b) c)
lambda = Abs
x = (Var "x")
y = (Var "y")
z = (Var "z")
a = (Var "a")
b = (Var "b")
c = (Var "c")

subterm1 :: Term
subterm1 = (lambda "x" (lambda "y" (lambda "z" (App (App x y) (App x z)))))

subterm2 :: Term
subterm2 = (App subterm1 (lambda "x" a))
finalTerm = (App (App subterm2 b) c)

test = lambda "x" (App x b)

eval term =  (show (freeVars term)) ++ "     " ++ (pretty term)

-- eval test
-- eval finalTerm
---------------------------------------
--resultFreeVars = freeVars finalTerm
--resultTerm = pretty finalTerm

Beweise 馃寶

Last List

last1 (x:y:xs) = last1 (y:xs)
last1 [x] = x

last2 = head . reverse

-- Beweis: (leere Liste, liste mit einem Element und liste mit zwei Elementen)
-- last1 [] = undefined
-- last2 [] = head (reverse []) = head [] = undefined
--
-- last1 [x] = x
-- last2 [x] = head (reverse [x]) = head [x] = x
--
-- last1 (x:y:xs) = last1 (y:xs)
--                = last2 (y:xs) -- Induction hypothesis
--
-- last2 (x:y:xs) = head (reverse (x:y:xs))
--                = head (reverse xs ++ [y,x]) -- reverse xs und Konkatenation von [y,x] gleiches wie ganze Liste reversed
--                = head ((reverse xs ++ [y]) ++ [x])
--                = head (reverse xs ++ [y])
--                = head (reverse (y:xs))
--                = last2 (y:xs)
-- Lieber beschreiben (in Text) als ein Beispiel, ein Beispiel ist kein Beweis. (Nur ein Gegenbeispiel ist ein Gegenbeweis.)

Claim Map

claim :: Eq b => (a -> b) -> [a] -> [a] -> Bool
claim f x y = map f (x ++ y) == map f x ++ map f y

-- immer True, weil
-- map f ([x1..xn] [y1..yk])
--  = map f [x1..xn, y1..yk]
--  = [f x1,..,f xn, f y1,..,f yk]
--  = [f x1,..,f xn] ++ [f y1,..,f yk]
--  = map f [x1..xn] ++ map f [y1..yk]

Additional Code 馃Ж

B盲ume Zeichnen

In Folder Drawing/
stack ghci --package gloss --package random --package gloss-export --package text --ghci-options -fno-ghci-sandbox DrawingTable.hs
compareTrees 4 456

Matrix

module Matrix where

type Point = (Float, Float)
type Vector = Point

data Matrix = Matrix (Float, Float) (Float, Float)
    deriving Show

scale :: Float -> Matrix -> Matrix
scale r (Matrix (a, b) (c, d)) = Matrix (r*a, r*b) (r*c, r*d)

invert :: Matrix -> Matrix
invert (Matrix (a, b) (c, d)) = scale
    (1/(a*d - b*c))
    (Matrix (d, -b) (-c, a))

apply :: Matrix -> Vector -> Vector
apply (Matrix (a, b) (c, d)) (x, y) =
    ( a*x + b*y
    , c*x + d*y
    )

m = Matrix (10,2) (8,4)
result = ((flip apply) (1,1)) . (scale 2) . invert

Magic Stuff

fibs = 0 : 1 : zipWith (+) fibs (tail fibs)

pascal = iterate (\row -> zipWith (+) ([0] ++ row) (row ++ [0])) [1]

primes = sieve [2..] where
    sieve (p:xs) = p : sieve [ n | n <- xs, n `mod` p > 0 ]

------- Monad
[[x,y] | x <- "12", y <- "45"]

"12" >>= \x -> "45" >>= \y -> return [x,y]

((+) =<< (+) =<< (+) =<< id) 3

sequence [even,odd] 4

-- function composition for functions with 2 arguments
(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(...) = (.) . (.)
infixr 8 ...

-- counts the amount of elements in two lists that are equal and at the same index in a pointfree style
exactMatches :: Eq a => [a] -> [a] -> Int
exactMatches = length . filter id ... zipWith (==)

Sequence, Scan and Sum

negateL :: Bool -> Bool
negateL = \x -> negate1 x

add1 :: Integer -> Integer -> Integer
add1 x = \y -> x + y

-- *Main> :t add1 2
-- add1 2 :: Integer -> Integer
-- *Main> :t add1 2 3
-- add1 2 3 :: Integer

add2 :: Integer -> Integer -> Integer
add2 = \x y -> x + y

add3 :: Integer -> Integer -> Integer
add3 = \x -> (\y -> x + y)

seq2 :: (a -> b) -> (b -> c) -> (a -> c)
seq2 f g = \x -> g(f(x))
-- seq2 f g x = g $ f x
-- f $ g x === g ( f(x))

isOdd :: Integer -> Bool
isOdd = seq2 isEven negate1

isOdd2 :: Integer -> Bool
isOdd2 x = not $ isEven x


seqMany :: [a -> a] -> (a -> a)
seqMany [] a = a
seqMany (f:fs) a = seqMany fs $ f a
-- : Pattern Matching
-- *Main> :t (:)
-- (:) :: a -> [a] -> [a]

-- *Main> seqMany [(*3), (+2)] 20
-- 62

-- *Main> :t foldl
-- foldl :: Foldable t => (b -> a -> b) -> b -> t a -> b
-- x=>"b" [a, b, c]=>"a" ==> <"xa"> ===> (<xa> b)

seqManyL :: [a -> a] -> a -> a
seqManyL = foldl seq2 id

seqManyR :: [a -> a] -> a -> a
seqManyR = foldr seq2 id

x = foldl (+) 0 [1,2,3,4]

sumSq :: [Integer] -> Integer
sumSq = foldl (\acc x -> acc + x*x) 0

-- (Funktion ->     ->      ) -> Init x -> input -> output
-- (string -> char -> string) -> string -> string -> string

fl = foldl (\s c -> c:s) "x" "abc"
-- x    /--- abc
--   ax     /  |
--     bax    /
--       cbax
fr = foldr (\c s -> c:s) "x" "abc"

-- seqManyR [(+1), square, (+1)] 10

-- (|>) x f = f x
-- 10 |> add13 |> \x -> x*x
summe [] = 0
summe (x:xs) = x + summe xs

----------------------------------------------
-- Folds
----------------------------------------------

foldr (\x y -> concat ["(",x,"+",y,")"]) "0" (map show [1..13])
--"(1+(2+(3+(4+(5+(6+(7+(8+(9+(10+(11+(12+(13+0)))))))))))))"

foldl (\x y -> concat ["(",x,"+",y,")"]) "0" (map show [1..13])
--"(((((((((((((0+1)+2)+3)+4)+5)+6)+7)+8)+9)+10)+11)+12)+13)"

foldt (\x y -> concat ["(",x,"+",y,")"]) "0" (map show [1..13])
--"((((1+2)+(3+4))+((5+6)+(7+8)))+(((9+10)+(11+12))+13))"

foldi (\x y -> concat ["(",x,"+",y,")"]) "0" (map show [1..13])
--"(1+((2+3)+(((4+5)+(6+7))+((((8+9)+(10+11))+(12+13))+0))))"

head = foldr (\a b->a) undefined鈥
last = foldl (\a b->b) undefined鈥

fl = foldl (\s c -> c:s) "x" "abc"
fr = foldr (\c s -> c:s) "x" "abc"

sumSq :: [Integer] -> Integer
sumSq = foldl (\acc x -> acc + x*x) 0
sumFold x = foldr (+) 0 x
andFold x = foldr (&&) True x
orFold x = foldr (||) False x

-- foldr (\elem acc -> term) start_acc list
-- foldl (\acc elem -> term) start_acc list

count e = foldr (\x acc -> if e==x then acc+1 else acc) 0
-- call with: count 2 [1,2,34,2]
isAll e = foldr (\x -> (&&) $ e ==x) True
-- call with: isAll 2 [2]
isAll2 e = foldr (\x acc -> e==x && acc) True
-- call with:  isAll2 2 [2]
lengthFold  x = foldr (\x -> (+) 1) 0 x
lengthFold2 x  = foldr (const $ (+) 1) 0 x


char_replace a b = map (\x -> if (a == x) then b else x)
-- char_replace 'a' 't' "Panda"
-- "Ptndt"

-- Scan
-- Gleiche "api" wie fold aber speichert jeden schritt des folds in einer liste. 
-- Beispiel aus der Probepr眉fung: mkLists 3 --> [[1], [1,2], [1,2,3]]
mkLists :: Integer -> [[Integer]]
mkLists n = scanl (\acc next -> acc ++ [next]) [1] [2 .. n]

---- besser (List comprehension)
mkList n = [[1..k] | k <- [1..n]]

List comprehension

Listen k枚nnen mit der List-Comprehension Syntax angegeben werden:
a = [x * x | x <- [0..9]]
b = [x * y | x <- [0..9], y <- [0..9]]
c = [i + 2 | i <- [1..5], i `mod` 2 == 0] -- ergibt [4,6]
mkList n = [[1..k] | k <- [1..n]]
d = [(x,y) | x <- [1..3], y <- [1..x]] -- beachte x :) 

Maybe (Filter, Monad)

filterMap :: (a -> Maybe b) -> [a] -> [b]
filterMap p [] = []
filterMap p (x:xs) = case p x of
    Nothing -> filterMap p xs
    Just y  -> y : filterMap p xs

g :: Int -> Maybe Int
g x | x <= 3 = Just x
    | otherwise = Nothing

filterMapTR :: (a -> Maybe b) -> [a] -> [b]
filterMapTR p = aux []
    where
        aux acc [] = reverse acc
        aux acc (x:xs) = case p x of
            Nothing -> aux acc xs
            Just y  -> aux (y:acc) xs


justOrDefault :: a -> Maybe a -> a
justOrDefault _ (Just x) = x
justOrDefault d _ = d


mon_add x y = do
    a <- x
    b <- y
    return $ a + b


max3 x y z
    | x >= y && x >= z = x
    | y >= x && y >= z = y
    | otherwise      = z

mon_max3 x y z = do
    a <- x
    b <- y
    c <- z
    return $ max3 a b c

to_int_max3 x y z = max3 (justOrDefault 0 x) (justOrDefault 0 y) (justOrDefault 0 z)

-- ---------------------------------------------------------------------------
Just 4 >>= \x -> return (x * x) -- Just 16
[1,2,3] >>= \x -> return (x * x) -- [1,4,9]
Just 4 >>= \x -> fail "bla" -- Nothing
[1,2,3] >>= \x -> fail "blah" -- []
-- ---------------------------------------------------------------------------
-- Implementation
data  Maybe a  =  Nothing | Just a
  deriving (Eq, Ord)

instance  Functor Maybe  where
    fmap _ Nothing       = Nothing
    fmap f (Just a)      = Just (f a)

instance  Monad Maybe  where
    (Just x) >>= k      = k x
    Nothing  >>= _      = Nothing

    (Just _) >>  k      = k
    Nothing  >>  _      = Nothing

    return              = Just
    fail _              = Nothing
-- ---------------------------------------------------------------------------
-- Functions over Maybe

maybe :: b -> (a -> b) -> Maybe a -> b
maybe n _ Nothing  = n
maybe _ f (Just x) = f x

isJust         :: Maybe a -> Bool
isJust Nothing = False
isJust _       = True

isNothing         :: Maybe a -> Bool
isNothing Nothing = True
isNothing _       = False

fromJust          :: Maybe a -> a
fromJust Nothing  = error "Maybe.fromJust: Nothing" -- yuck
fromJust (Just x) = x

fromMaybe     :: a -> Maybe a -> a
fromMaybe d x = case x of {Nothing -> d;Just v  -> v}

maybeToList            :: Maybe a -> [a]
maybeToList  Nothing   = []
maybeToList  (Just x)  = [x]

listToMaybe           :: [a] -> Maybe a
listToMaybe []        =  Nothing
listToMaybe (a:_)     =  Just a

catMaybes              :: [Maybe a] -> [a]
catMaybes ls = [x | Just x <- ls]

mapMaybe          :: (a -> Maybe b) -> [a] -> [b]
mapMaybe _ []     = []
mapMaybe f (x:xs) =
 let rs = mapMaybe f xs in
 case f x of
  Nothing -> rs
  Just r  -> r:rs

mapMaybeFB :: (b -> r -> r) -> (a -> Maybe b) -> a -> r -> r
mapMaybeFB cons f x next = case f x of
  Nothing -> next
  Just r -> cons r next

Black Jack

data CardFace
    = Ace
    | King
    | Queen
    | Jack
    | Number Integer
    deriving (Show, Eq)

data CardSuite
    = Club
    | Diamond
    | Heart
    | Spade
    deriving (Show, Eq)

data Card = Card
    { face :: CardFace
    , suite:: CardSuite
    } deriving (Show, Eq)

prettyPrint :: Card -> String
prettyPrint (Card face suite) =
    "[ " ++ prettyFace ++ " | " ++ prettySuite ++ " ]"
    where
      prettyFace :: String
      prettyFace = case face of
        Ace -> "A"
        King -> "K"
        Queen -> "Q"
        Jack -> "J"
        Number x -> show x

      prettySuite :: String
      prettySuite = case suite of
        Club -> "oOo"
        Diamond -> "<>"
        Heart -> "<3"
        Spade -> "o^o"


data CardValue
    = Choice Integer Integer
    | Definite Integer
    deriving (Show, Eq)

value :: Card -> CardValue
value card = case face card of
    Number x -> Definite x
    Ace -> Choice 1 11
    _rest -> Definite 10

data Hand = Hand [Card]
    deriving (Show, Eq)

Deep Shape Full

module Shape where

import Data.List

type Point = (Float, Float)
type Vector = Point

data Matrix = Matrix (Float, Float) (Float, Float)
    deriving Show

scale :: Float -> Matrix -> Matrix
scale r (Matrix (a, b) (c, d)) = Matrix (r*a, r*b) (r*c, r*d)

invert :: Matrix -> Matrix
invert (Matrix (a, b) (c, d)) = scale
    (1/(a*d - b*c))
    (Matrix (d, -b) (-c, a))

apply :: Matrix -> Vector -> Vector
apply (Matrix (a, b) (c, d)) (x, y) =
    ( a*x + b*y
    , c*x + d*y
    )


data Shape
    -- Basic shapes
    = Empty
    | UnitDisc
    | UnitSquare
    -- Combinators
    | Intersect Shape Shape
    | Merge Shape Shape
    | Minus Shape Shape
    -- Modifiers
    | Negate Shape
    | Translate Vector Shape
    | Stretch Float Float Shape
    | FlipX Shape
    | FlipY Shape
    | Flip45 Shape
    | Flip0 Shape
    | Rotate Float Shape


inside :: Shape -> Point -> Bool
inside s (x,y) = case s of
    Empty -> False
    UnitDisc -> x^2 + y^2 <= 1
    UnitSquare -> abs x <= 1 && abs y <= 1
    Translate (dx, dy) s' -> inside s' (x - dx, y - dy)
    Intersect s1 s2 -> (inside s1) (x,y) && (inside s2) (x,y)
    Merge s1 s2 -> (inside s1) (x,y) || (inside s2) (x,y)
    Minus s1 s2 -> inside (Intersect s1 (Negate s2)) (x,y)
    Negate s' -> not $ inside s' (x,y)
    Stretch rx ry s -> transformM (Matrix (rx, 0) (0, ry)) s
    FlipX s -> transformM (Matrix (1, 0) (0, -1)) s
    FlipY s -> transformM (Matrix (-1, 0) (0, 1)) s
    Flip45 s -> transformM (Matrix (0, 1) (1, 0)) s
    Flip0 s -> transformM (Matrix (-1, 0) (0, -1)) s
    Rotate a s -> transformM  (Matrix (cos a, -(sin a)) (sin a, cos a)) s
    where
        -- | Matrix transformations
        transformM :: Matrix -> Shape -> Bool
        transformM m s = inside s $ apply (invert m) (x,y)


render :: Float -> Float -> Shape -> IO ()
render length height shape = writeFile "shape.txt" lines
    where
        draw p
            | inside shape p = ('#', p)
            | otherwise = (' ', p)

        breakLn (d, (x,y))
            | x == length = [d,'\n']
            | otherwise = [d]

        pixels = [draw (x,y) | y <- [(-height)..height],  x <- [(-length)..length]]

        lines = concatMap breakLn pixels

-- Examples

shape1 = Stretch 10 10 UnitDisc

shape2 = Stretch 10 10 UnitSquare

shape3 = Translate (20, 20) $ Merge shape1 shape2

shape4 = Minus shape2 shape1

shape5 = Minus shape2 (Translate (5,0) shape1)

iShape = FlipX $ Merge
    (Stretch 2 1 UnitSquare)
    (Translate (0, 5) UnitDisc)

disc50 = Stretch 50 50 UnitDisc

--render 10 10 shape1

Fractran Full

-- Datatype for Fractions
data Fraction = Fraction
    { numerator :: Integer
    , denominator :: Integer
    } deriving (Show, Eq)

-- Possible results of attempting to multiply an Integer with a Fraction.
data MultResult
    = Success Integer
    | Failure
    deriving (Show, Eq)

-- Multiplying Fraction with Integer
(*.) :: Fraction -> Integer -> MultResult
(*.) (Fraction num den) n = case n `divMod` den  of
    (x, 0) -> Success $ x * num
    _ -> Failure

-- A FRACTRAN program consists of a sequence of fractions
data Program = Program [Fraction]
    deriving (Show, Eq)

-- Executing a FRACTRAN program with an input
execute :: Program -> Integer -> [Integer]
execute (Program p) input = run p [input]
    where
      run :: [Fraction] -> [Integer] -> [Integer]
      run [] inputs = inputs
      run (f:state) (i:inputs) = case f *. i of
        Success r -> run p (r:i:inputs)
        Failure   -> run state (i:inputs)

-- Test

testProgram = Program
    [ Fraction 91 33
    , Fraction 11 13
    , Fraction 1 11
    , Fraction 399 34
    , Fraction 17 19
    , Fraction 1 17
    , Fraction 2 7
    , Fraction 187 5
    , Fraction 1 3
    ]

input = 31250

-- expected 8192
result = head $ execute testProgram input

Made with 鉂わ笍 by Pascal & Ralph