Added solutions for Blatt 3 & Blatt 5

To compile and run Blatt5 just do a "stack build" and either

stack exec Blatt5-static

or

stack exec Blatt5-animated

Übungen/Blatt3.solution.hs

@@ -0,0 +1,171 @@
+-- Übungsblatt 3
+-- =============
+--
+-- Throat-Clearing
+-- ---------------
+--
+-- a.k.a. Imports, damit der Code funktioniert.
+
+module MonadExercise where
+import Control.Applicative()
+import Control.Monad()
+import Data.Monoid
+
+-- Vorwort
+-- -------
+--
+-- Die Typklassen, die auf diesem Zettel implementiert werden sollen sind
+-- teilweise nicht eindeutig. Ein gutes *Indiz* für eine falsche
+-- implementation kann sein, dass Informationen "weggeschmissen" werden -
+-- allerdings muss man bei anderen Implementationen genau dies machen.
+--
+-- Applicative
+-- -----------
+--
+-- Nachdem wir uns letzte Woche ausführlich mit der Typklasse `Functor`
+-- beschäftigt haben, bauen wir nun darauf auf und definieren die
+-- Applicative-Instanz. Zur Erinnerung:
+--
+--     class Functor f => Applicative f where
+--       pure :: a -> f a
+--       <*>  :: f (a -> b) -> f a -> f b
+--
+-- Nehmen sie an, sie hätten folgende Datentypen mit ihren
+-- `Functor`-Instanzen gegeben. Schreiben sie jeweils die
+-- Applicative-Instanz:
+
+data Identity a = Identity { unIdentity :: a }
+                        deriving (Show, Eq)
+
+instance Functor Identity where
+  fmap f (Identity a) = Identity (f a)
+
+
+instance Applicative Identity where
+        pure = Identity
+        (Identity f) <*> (Identity x) = Identity (f x)
+
+instance Monad Identity where
+        return = pure
+        (Identity x) >>= f = f x
+
+
+data Vielleicht a = Etwas a
+                  | Nichts
+                deriving (Show, Eq)
+
+instance Functor Vielleicht where
+  fmap f (Etwas a) = Etwas (f a)
+  fmap _ Nichts    = Nichts
+
+instance Applicative Vielleicht where
+        pure = Etwas
+        (Etwas f) <*> x = f <$> x
+        Nichts    <*> _ = Nichts
+
+instance Monad Vielleicht where
+        return          = pure
+        (Etwas a) >>= f = f a
+        Nichts    >>= _ = Nichts
+
+data EntwederOder b a = Entweder a
+                      | Oder b
+                deriving (Show, Eq)
+
+instance Functor (EntwederOder b) where
+  fmap f (Entweder a) = Entweder (f a)
+  fmap _ (Oder b)     = Oder b
+
+instance Applicative (EntwederOder b) where
+        pure = Entweder
+        (Entweder f) <*> x = f <$> x
+        (Oder e)    <*> _ = Oder e
+
+instance Monad (EntwederOder b) where
+        return = pure
+        (Entweder x) >>= f = f x
+        (Oder e)     >>= _ = Oder e
+
+data List a = Cons a (List a)
+            | Nil
+                deriving (Show, Eq)
+
+instance Functor List where
+  fmap f (Cons a r) = Cons (f a) (fmap f r)
+  fmap _ Nil        = Nil
+
+instance Monoid (List a) where
+  mempty                 = Nil
+  mappend Nil bs         = bs
+  mappend (Cons a as) bs = Cons a (mappend as bs)
+
+instance Applicative List where
+        pure a            = Cons a Nil
+        Nil <*> _         = Nil
+        (Cons f fs) <*> x = (f <$> x) <> (fs <*> x)
+
+instance Monad List where
+        return            = pure
+        Nil         >>= _ = Nil
+        (Cons x xs) >>= f = f x <> (xs >>= f)
+
+data V3 a = V3 a a a
+
+instance Functor V3 where
+  fmap f (V3 x y z) = V3 (f x) (f y) (f z)
+
+instance Applicative V3 where
+        pure a = V3 a a a
+        (V3 f g h) <*> (V3 x y z) = V3 (f x) (g y) (h z)
+
+instance Monad V3 where
+        return = pure
+        (V3 x y z) >>= f = V3 a b c
+           where
+                   (V3 a _ _) = f x
+                   (V3 _ b _) = f y
+                   (V3 _ _ c) = f z
+
+-- Monad
+-- -----
+--
+-- Zu welchen der oben aufgeführten Typen gibt es eine Monaden-Instanz? Wie
+-- sieht diese aus? Schreiben sie diese (falls möglich).
+--
+-- Bonus
+-- -----
+
+data Account = Account
+data Inbox = Inbox
+data Mail = Mail
+
+-- Seien folgende Funktionen gegeben:
+
+login    :: Maybe Account
+login    = undefined
+
+getInbox :: Account -> Maybe Inbox
+getInbox = undefined
+
+getMails :: Inbox -> [Mail]
+getMails = undefined
+
+safeHead :: [a] -> Maybe a
+safeHead = undefined
+
+-- Schreiben sie eine Funktion:
+
+getFirstMail :: Maybe Mail
+getFirstMail = do
+        a <- login
+        i <- getInbox a
+        safeHead $ getMails i
+
+getFirstMail' :: Maybe Mail
+getFirstMail' = login >>= getInbox >>= safeHead . getMails
+
+-- welche die oben genannten 4 Funktionen nutzt um die erste Mail aus dem
+-- gegebenen Account zurückzuliefern, sofern alles erfolgreich war.
+--
+-- Können sie beide Varianten (einmal mittels `do`-notation und einmal mit
+-- `>>=`) schreiben?

Übungen/Blatt5-solution/Blatt5-solution.cabal

@@ -0,0 +1,64 @@
+name:                Blatt5-solution
+version:             0.1.0.0
+synopsis:            Solution for Sheet 5 of our course FFPiHaskell (2016)
+description:         Please see README.md
+homepage:            https://github.com/ffpihaskell/Vorlesung2016
+license:             BSD3
+license-file:        LICENSE
+author:              Stefan Dresselhaus
+maintainer:          sdressel@techfak.uni-bielefeld.de
+copyright:           2016 Stefan Dresselhaus
+category:            GUI
+build-type:          Simple
+-- extra-source-files:
+cabal-version:       >=1.10
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     Parser
+                     , GUI
+                     , Types
+  build-depends:       base >= 4.7 && < 5
+                     , attoparsec
+                     , bytestring
+                     , gloss
+                     , time
+                     , array
+  default-language:    Haskell2010
+
+executable Blatt5-static
+  hs-source-dirs:      app
+  main-is:             Main-Static.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , Blatt5-solution
+                     , gloss
+                     , bytestring
+                     , array
+                     , time
+  default-language:    Haskell2010
+
+executable Blatt5-animated
+  hs-source-dirs:      app
+  main-is:             Main-Animated.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , Blatt5-solution
+                     , gloss
+                     , bytestring
+                     , array
+                     , time
+  default-language:    Haskell2010
+
+test-suite Blatt5-solution-test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Spec.hs
+  build-depends:       base
+                     , Blatt5-solution
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  default-language:    Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/ffpihaskell/Vorlesung2016

Übungen/Blatt5-solution/LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2016
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Übungen/Blatt5-solution/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

Übungen/Blatt5-solution/app/Main-Animated.hs

@@ -0,0 +1,30 @@
+module Main where
+
+import Parser
+import GUI
+import Types
+import Data.ByteString as BS
+import Data.Array
+import Data.Time
+import Data.Word
+import Graphics.Gloss
+import Data.Monoid
+
+datafile :: String
+datafile = "time_ip.csv"
+
+mainAnimate :: IO ()
+mainAnimate = do
+        df <- BS.readFile datafile
+        let pd = ipBuckets <$> parseData df
+        case pd of
+          Right pd' -> animate (InWindow "Animation" (800,600) (100,200)) white (animateGrid 240 200 pd')
+          Left err  -> print $ "parsing Error:" <> err
+
+main :: IO ()
+main = mainAnimate
+
+ipBuckets :: [Data] -> Array (Word8,Word8,Int) Int
+ipBuckets d = accumArray (+) 0 ((0,0,0),(15,15,23)) (f <$> d)
+        where
+                f (Data _ (TimeOfDay h m _) (IPv4 a _ _ _)) = ((a `div` 16, a `mod` 16, h), 1)

Übungen/Blatt5-solution/app/Main-Static.hs

@@ -0,0 +1,30 @@
+module Main where
+
+import Parser
+import GUI
+import Types
+import Data.ByteString as BS
+import Data.Array
+import Data.Time
+import Data.Word
+import Graphics.Gloss
+import Data.Monoid
+
+datafile :: String
+datafile = "time_ip.csv"
+
+mainStatic :: IO ()
+mainStatic = do
+        df <- BS.readFile datafile
+        let pd = hourBuckets <$> parseData df
+        case pd of
+          Right pd' -> display (InWindow "Bar Chart" (800,600) (100,200)) white (drawBar 240 200 pd')
+          Left err  -> print $ "parsing Error:" <> err
+
+main :: IO ()
+main = mainStatic
+
+hourBuckets :: [Data] -> Array Int Int
+hourBuckets d = accumArray (+) 0 (0,23) (f <$> d)
+        where
+                f (Data _ (TimeOfDay h _ _) _) = (h,1)

Übungen/Blatt5-solution/src/GUI.hs

@@ -0,0 +1,46 @@
+module GUI where
+
+import Data.Array
+import Graphics.Gloss
+import Data.Word
+
+type Height = Int
+type Width = Int
+
+drawBar :: Width -> Height -> Array Int Int -> Picture
+drawBar w h a = Pictures $ draw <$> [0..num]
+        where
+                num = u - l
+                (l, u) = bounds a
+                w' :: Float
+                w' = fromIntegral w / fromIntegral num
+                h' :: Float
+                h' = fromIntegral h / fromIntegral (maximum $ elems a)
+                draw :: Int -> Picture
+                draw i = Translate (w'*i') 0 $ -- translate the whole bar
+                         Pictures [ Color blue $ Polygon [(0,0), (0, h''), (w', h''), (w', 0)] -- draw bar
+                                  , Translate 0 (-10) $ Scale 0.05 0.05 $ Text (show i) -- draw caption
+                                  ]
+                        where
+                                i' = fromIntegral i
+                                h'' = fromIntegral (a!i) * h'
+
+animateGrid :: Width -> Height -> Array (Word8, Word8, Int) Int -> Float -> Picture
+animateGrid w h d f = Pictures $ draw <$> [0..l1] <*> [0..l2]
+        where
+              (_, (l1, l2, t)) = bounds d
+              maxVal :: Float
+              maxVal = fromIntegral . maximum . elems $ d
+              draw :: Word8 -> Word8 -> Picture
+              draw x y = Translate (w'*fromIntegral x) (h'*fromIntegral y) $
+                         Pictures [ Color (mixColors val (maxVal-val) red green) $ rectangleSolid w' h'
+                                  , Scale 0.05 0.05 . Text . show . round $ val
+                                  ]
+                                          where
+                                                  val = fromIntegral $ d!(x,y,f')
+              w' :: Float
+              w' = fromIntegral w / fromIntegral l1
+              h' :: Float
+              h' = fromIntegral h / fromIntegral l2
+              f' = floor f `mod` t
+

Übungen/Blatt5-solution/src/Parser.hs

@@ -0,0 +1,69 @@
+module Parser 
+        
+       (parseData)
+
+       where
+
+import qualified Data.ByteString as BS
+import Data.Attoparsec.ByteString
+import Data.Attoparsec.ByteString.Char8 (isHorizontalSpace, char, endOfLine, decimal, digit)
+import Data.Time (Day(..), TimeOfDay(..), makeTimeOfDayValid, fromGregorianValid)
+import Types
+
+
+parseData :: BS.ByteString -> Either String [Data]
+parseData = parseOnly parserData
+
+parserData :: Parser [Data]
+parserData = many' parseDatapoint
+
+
+parseDatapoint :: Parser Data
+parseDatapoint = do
+        skipWhile isHorizontalSpace
+        d <- parseDay
+        char 'T'
+        t <- parseTime
+        char 'Z'
+        skipWhile isHorizontalSpace
+        char ','
+        skipWhile isHorizontalSpace
+        ip <- parseIP
+        skipWhile isHorizontalSpace
+        endOfLine
+        return $ Data d t ip
+
+parseDay :: Parser Day
+parseDay = do
+        y <- count 4 digit
+        char '-'
+        m <- count 2 digit
+        char '-'
+        d <- count 2 digit
+        case fromGregorianValid (read y) (read m) (read d) of
+          (Just d) -> return d
+          Nothing  -> fail "Incorrect Date"
+
+
+parseTime :: Parser TimeOfDay
+parseTime = do
+        h <- count 2 digit
+        char ':'
+        m <- count 2 digit
+        char ':'
+        s <- count 2 digit
+        case makeTimeOfDayValid (read h) (read m) (read s) of
+          (Just t) -> return t
+          Nothing  -> fail "Incorrect Time"
+
+parseIP :: Parser IPv4
+parseIP = do
+        a <- decimal
+        char '.'
+        b <- decimal
+        char '.'
+        c <- decimal
+        char '.'
+        d <- decimal
+        return $ IPv4 a b c d
+

Übungen/Blatt5-solution/src/Types.hs

@@ -0,0 +1,14 @@
+module Types where
+
+import Data.Word
+import Data.Time
+
+data Data = Data
+          { date :: Day
+          , time :: TimeOfDay
+          , ip   :: IPv4
+          }
+          deriving (Show, Eq)
+
+data IPv4 = IPv4 Word8 Word8 Word8 Word8
+        deriving (Show, Eq)

Übungen/Blatt5-solution/stack.yaml

@@ -0,0 +1,34 @@
+# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
+
+# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
+resolver: lts-5.13
+
+# Local packages, usually specified by relative directory name
+packages:
+- '.'
+
+# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
+extra-deps: [ gloss-1.10.1.1
+            , gloss-rendering-1.10.1.1
+            ]
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: >= 1.0.0
+
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]

Übungen/Blatt5-solution/test/Spec.hs

@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"