{---------------------------------------------------------- Datei mit Beispielen zur Lazy Evaluation ----------------------------------------------------------} import IO ---------------------------------------------------------- -- Definition unendlicher Datenstrukturen ---------------------------------------------------------- liste1 :: Num a => [a] liste1 = 1 : liste1 -- [1,1..] from :: Num a => a -> [a] from n = n : from (n+1) -- [n..] fibnbs :: Num a => a -> a -> [a] fibnbs n m = n : fibnbs m (n+m) ---------------------------------------------------------- -- Primzahlgenerierung mit dem Sieb des Eratosthenes ---------------------------------------------------------- not_multiple :: Int -> Int -> Bool not_multiple x y = (y `mod` x) > 0 sieve :: [Int] -> [Int] sieve [] = [] sieve (x:xs) = x: sieve (filter (not_multiple x) xs) is_prime :: Int -> Bool is_prime n = elem n (sieve [2..]) twins :: [Int] -> [(Int,Int)] twins [] = [] twins [x] = [] twins (x:xs@(y:ys))| y - x <= 2 = (x,y):twins xs | otherwise = twins xs --------------------------------------------------------------- -- Bsp: Newtonsches Iterationsverfahren -- ------------------------------------------------------------ -- Sei a > 0, x_0 > 0. Dann konvergiert die Folge -- = 0> mit x_{i+1} = (x_i + a/x_i) / 2 -- gegen sqrt(a). -- Iterationsfunktion next :: Fractional a => a -> a -> a next a x = (x + a/x) / 2 -- Folgendefinition folge :: Fractional a => a -> a -> [a] folge a x_0 = iterate (next a) x_0 -- Abbruchkriterium within :: (Ord a, Num a) => a -> [a] -> a within eps (x1:x2:xs) | abs (x2-x1) < eps = x2 | otherwise = within eps (x2:xs) -- Approximation der Quadratwurzel mysqrt :: (Ord a, Fractional a) => a -> a -> a -> a mysqrt x_0 eps a = within eps (folge a x_0) ----------------------------------------------------------- -- Problemloesen mit Generate-and-Test -- -------------------------------------------------------- gt :: (a -> [b]) -> (b -> Bool) -> a -> [b] gt generate test params = filter test (generate params) -- Beispiel: Permutation Sort ----------------------------------------------------------- -- Erzeugung aller Permutationen einer Liste allPerms :: [a] -> [[a]] allPerms [] = [[]] allPerms (x:xs) = concat (map (distr x) (allPerms xs)) where distr x [] = [[x]] distr x l@(y:ys) = (x:l):(map (y:) (distr x ys)) -- Teste, ob Liste sortiert ist sorted :: Ord a => [a] -> Bool sorted xs = and $ zipWith (<=) xs (tail xs) -- Permutation Sort: -- generiere alle Permutationen und filtere sortierte heraus psort :: Ord a => [a] -> [a] psort = head . (gt allPerms sorted) ----------------------------------------------------------- -- Verarbeitung partieller Informationen -- -------------------------------------------------------- data Tree a = Leaf a | Node a (Tree a) (Tree a) deriving Show -- Bsp: Bestimme mit nur einem Baumdurchlauf -- das Minimum in einem Baum und ersetze jeden -- Eintrag durch diesen Wert -- Ansatz: -- Minimum bestimmen minTree :: Ord a => Tree a -> a minTree (Leaf x) = x minTree (Node x l r) = min x (min (minTree l) (minTree r)) -- Knoteneintraege durch vorgegebenen Wert ersetzen replace :: Tree a -> b -> Tree b replace (Leaf x) y = Leaf y replace (Node x l r) y = Node y (replace l y) (replace r y) -- Alle Knoteneintraege durch Minimum ersetzen -- replaceMin :: Ord a => Tree a -> Tree a replaceMin t = replace t $ minTree t -- -> diese Loesung benoetigt zwei Baumdurchlaeufe -- Definiere durch Paarung von minTree und replace -- eine Funktion, die mit einem Baumdurchlauf auskommt minReplace :: Ord a => Tree a -> a -> (a, Tree a) minReplace (Leaf x) y = (x, Leaf y) minReplace (Node x l r) y = (min x (min ml mr), Node y ly ry) where (ml,ly) = minReplace l y (mr,ry) = minReplace r y -- ... und nun in einem Durchlauf: replaceMin1 :: Ord a => Tree a -> Tree a replaceMin1 t = mt where (min, mt) = minReplace t min -- Testbaum testbaum = Node 10 (Node 15 (Node 16 (Node 7 (Leaf 3) (Node 39 (Leaf 15) (Leaf 18))) (Node 17 (Leaf 13) (Node 9 (Leaf 11) (Leaf 2)))) (Leaf 18)) (Node 25 (Node 6 (Node 14 (Leaf 34) (Node 3 (Leaf 5) (Leaf 36))) (Node 80 (Leaf 26) (Node 19 (Leaf 4) (Leaf 12)))) (Leaf 99)) testbaum2 = let t = Node 25 (Node 6 (Node 14 (Leaf 34) (Node 3 (Leaf 5) (Leaf 36))) (Node 80 (Leaf 26) (Node 19 (Leaf 4) (Leaf 12)))) (Leaf 99) in (Node 3 t (Node 1 t t)) ----------------------------------------------------------- -- Prozessnetze -- -------------------------------------------------------- -- -- .---. .---. .-------------. -- fibs <---| 1 |<---| 1 |<--| zipWith (+) | -- | '---' | '---' '-------------' -- | |_____________^ ^ -- |____________________________| -- fibs :: [Integer] fibs = 1:1:zipWith (+) fibs (tail fibs) -- Vergleiche: fibs1 :: () -> [Integer] fibs1 () = 1:1:zipWith (+) (fibs1 ()) (tail (fibs1 ())) -- .---. .-------------. -- ps <---| 0 |<-----| zipWith (+) |<-- xs -- | '---' '-------------' -- | ^ -- |___________________| -- prefixSums :: Num a => [a] -> [a] prefixSums xs = ps where ps = 0 : zipWith (+) xs ps -- main :: IO() main = putStr "Hello" fib 0 = 1 fib 1 = 1 fib (n+2) = fib (n+1) + fib n --------------------------------------------------------------- -- Simulation einer Client-Server-Interaktion --------------------------------------------------------------- type Request = Integer type Response = Integer type Result = Integer system = let resps = server $ reqs (reqs,ress) = client resps in ress server :: [Request] -> [Response] server = map (\ x -> x+x) client :: [Response] -> ([Request],[Result]) client rs@(~(a:as)) = (2:req:as,rs) where req = if a == 0 then 1 else a client2 :: [Response] -> ([Request],[Result]) client2 rs = (2:req:as,rs) where req = if a == 0 then 1 else a (a:as) = rs --------------------------------------------------------------- -- Strombasierte Ein-/Ausgabe mit interact --------------------------------------------------------------- -- interact :: (String -> String) -> IO () -- interact f = getContents >>= (putStr . f) -- -- getContents :: IO String -- liefert die Eingabe als Character-Strom (lazy list) infixl 9 >.> g >.> f = f.g readAndReverse :: String -> String readAndReverse = (lines >.> mapUntil (==[]) reverse >.> unlines) >.> ("Type in a line, please!\n"++) mapUntil :: (a -> Bool) -> (a->a) -> [a] -> [a] mapUntil p f [] = [] mapUntil p f (x:xs) | (p x) = [] | otherwise = (f x) : mapUntil p f xs -- vergleichbares Verhalten mit monadischer IO readRevWrite :: IO () readRevWrite = do l <- getLine if l == [] then return () else do putStr ((reverse l) ++ "\n") readRevWrite -- mit monadischer Kontrollstruktur While while :: (a -> Bool) -> IO a -> IO () while test action = loop where loop = do val <- action if test val then loop else return () readRevWrite1 :: IO String -- einzelne Zeile bearbeiten readRevWrite1 = getLine >>= apply reverse >>= \cs -> do putStr (cs ++ "\n") return cs apply :: (a->b) -> a -> IO b apply f x = return (f x) interactReadAndRev2 :: IO () interactReadAndRev2 = while (not.null) readRevWrite1 -- mit Eingabeaufforderungen readAndReverse' :: String -> String readAndReverse' = lines >.> mapUntil (==[]) ((++"\nType in a line, please?" ).reverse) >.> unlines >.> ("Type in a line, please?\n" ++) ---------------------------------------------------------------------- -- Interaktives Palindrom-Testprogramm mit interact ---------------------------------------------------------------------- palindrome line = (line == reverse line) test :: String -> String test = (lines >.> mapUntil (==[]) process >.> unlines) >.> ("Type in a line, please?\n" ++) process :: String -> String process line | line == [] = "Good bye\n" | palindrome line = line ++ " is a palindrome!\n" ++ prompt | otherwise = line ++ " is not a palindrome!\n" ++ prompt where prompt = "Type in a line, please?"