first commit

.gitignore

+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local

.travis.yml

+# This is the simple Travis configuration, which is intended for use
+# on applications which do not require cross-platform and
+# multiple-GHC-version support. For more information and other
+# options, see:
+#
+# https://docs.haskellstack.org/en/stable/travis_ci/
+#
+# Copy these contents into the root directory of your Github project in a file
+# named .travis.yml
+
+# Use new container infrastructure to enable caching
+sudo: false
+
+# Do not choose a language; we provide our own build tools.
+language: generic
+
+# Caching so the next build will be fast too.
+cache:
+  directories:
+  - $HOME/.stack
+
+# Ensure necessary system libraries are present
+addons:
+  apt:
+    packages:
+      - libgmp-dev
+
+before_install:
+# Download and unpack the stack executable
+- mkdir -p ~/.local/bin
+- export PATH=$HOME/.local/bin:$PATH
+- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
+
+install:
+# Build dependencies
+- stack --no-terminal --install-ghc test --only-dependencies
+
+script:
+# Build the package, its tests, and its docs and run the tests
+- stack --no-terminal test --haddock --no-haddock-deps
+

LICENSE

+Copyright Author name here (c) 2017
+
+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.
\ No newline at end of file

README.md

+Übungszettel 4
+==============
+
+In dieser und den nächsten Übungen werden wir uns mit der (Weiter-)Entwicklung 
+eines Spiels beschäftigen.
+
+Bisher umfasst das Spiel die folgenden Module:
+* GameTypes.hs
+* GameLogic.hs
+* GameDraw.hs
+* GameConfig.hs 
+* GameMain.hs
+
+Sie können es mit `stack exec Game` ausprobieren. 
+
+Wie Sie sehen werden, sind uns bei der Implementation dieses Spiels leider 
+einige Fehler unterlaufen. Außerdem fehlen noch einige wichtige Features, 
+aber zum Glück kennen sich unsere Tutanden gut genug aus, um uns zu helfen! 
+
+Issue 1
+---------
+Sie haben in der Vorlesung bereits *Record syntax* kennengelernt. Im Modul 
+`GameLogic.hs` unter "Initialization" findet sich die unschöne Funktion `newWorld`. 
+Geben Sie dieser Funktion eine anschauliche Form, indem Sie Teilausdrücke 
+refaktorisieren (in sinnvollen Funktionen oder `where`-/`let`-Klauseln) und 
+verwenden Sie *Record syntax* um eine default World anzulegen! 
+Bedenken Sie, dass sie zur Zuweisung einzelner *Record fields* genau deren Namen 
+verwenden müssen (nicht die daraus erstellten Lenses). 
+
+Issue 2
+---------
+In der Datei `GameDraw.hs` wird bestimmt, wie eine `World` angezeigt wird.
+1. Ergänzen Sie den Code, so dass ein toter Boss als rotes `'T'`, ein toter Hero 
+als grünes `'T'` dargestellt wird. 
+2. Ergänzen Sie das Spiel um einen visuellen Hinweis, der anzeigt, ob das Spiel
+pausiert ist.
+
+Issue 3
+---------
+Obwohl die Spielerbewegung einwandfrei funktioniert, schlägt der entsprechende 
+QuickCheck-Test fehl! Korrigieren Sie den QuickCheck-Test. 
+
+Issue 4
+---------
+1. Implementieren Sie eine neue `Action`, die die Blickrichtung des Helden ändert, 
+ohne dass ein World-Update stattfindet. Erweitern Sie hierfür entsprechend den 
+`Action`-Typ in `GameTypes.hs`, modifizieren Sie `performAction` in `GameLogic.hs` 
+und schreiben Sie eine Funktion `changeDirection :: Direction -> World -> World`. 
+Erweitern Sie außerdem `getAction` in `GameConfig.hs`, so dass gilt: 
+ -- `'h'` führt zu Blick nach `West`
+ -- `'j'` führt zu Blick nach `North`
+ -- `'k'` führt zu Blick nach `South`
+ -- `'l'` führt zu Blick nach `East`. 
+
+2. Eine Kollegin hat begonnen ein neues Feature zu implementieren: Eine neue `Action` 
+soll dem Spieler/der Spielerin das Stellen von Fallen vor dem Helden ermöglichen. 
+Bewegt sich ein Monster auf eine solche Falle, soll diese zuschnappen und Schaden 
+zufügen. Die Kollegin hat bereits einen `Action`-Wert (`SetTrap`) und einen `Entity`-
+Wert (`Trap`) in `GameTypes.hs` angelegt und `getAction` in `GameConfig.hs` angepasst. 
+Im GameLogic-Modul hat sie die zu modifizierenden Stellen mit einem `-- TODO`-Kommentar 
+markiert. Bringen Sie ihre Arbeit zuende. 
+
+Bonus: Issue 5
+---------
+An einigen Stellen im Code fügen Entities Schaden zu. 
+Hard coded finden sich folgende Schadenswerte: 
+-- Angreifender `Hero` fügt Boss 45 Schaden zu
+-- Explodierende `Bomb` fügt Held 30 bzw. entfernter 15 Schaden zu
+-- Läuft der Held in ein `Fire` fügt es ihm 15 Schaden zu
+-- Läuft der Boss in eine `Trap` fügt diese ihm x Schaden zu
+Implementieren Sie ein sinnvolles Schadensystem, in dem Sie den Typ `Stats` um 
+ein Feld `_damage :: Integer` erweitern. Ein großes Feuer soll mehr Schaden zufügen 
+als ein kleines. Passen Sie die `GameLogic` entsprechend an. 
+Hinweis: Trap hat bisher keine Stats. Wie Sie hier verfahren, ist Ihnen überlassen. 
+
+
+Appendix: 
+--------
+
+Die wichtigsten Lens operators (**unbedingt anschauen**): 
+https://github.com/ekmett/lens/wiki/Operators
+
+Auch das hier ist definitv einen Blick Wert: 
+http://intolerable.me/lens-operators-intro/
+
+Und hier noch ein Link zu 
+Setter: https://hackage.haskell.org/package/lens-4.15.2/docs/Control-Lens-Setter.html
+

Setup.hs

+import Distribution.Simple
+main = defaultMain

app/GameMain.hs

+module Main where
+
+import GameTypes
+import GameLogic
+import GameConfig
+import GameDraw
+import Draw
+import Control.Lens
+import Data.List
+import Data.Maybe
+import Linear.V2
+import Control.Exception
+import System.IO
+import qualified Data.Map as M
+
+
+{- ncurses view -}
+
+main :: IO ()
+main = play' opts 60 world renderWorld (\_ w -> w) handleEvent
+  where world = newWorldWithBoss (V2 10 1) (V2 10 16) (defaultConfig^.worldSize)
+        opts  = defaultConfig^.ncursesOpts
+
+handleEvent :: Event -> World -> World 
+handleEvent (EventCharacter c) w = fromMaybe w $ performAction w <$> getAction c
+handleEvent _ w                  = w
+
+
+
+
+
+
+{- Terminal view -}
+
+main' :: IO ()
+main' = gameLoop $ newWorldWithBoss (V2 10 1) (V2 10 16) (20, 32)
+
+gameLoop :: World -> IO ()
+gameLoop oldW = do
+  putStrLn ""
+  renderWorld' oldW
+  putStrLn "Use 'w', 'a', 's', 'd' to navigate through the world. Press ' ' to attack, 'p' to pause."
+  input <- getChar
+  let newW = fromMaybe oldW $ performAction oldW <$> getAction input
+  gameLoop newW
+
+renderWorld' :: World -> IO ()
+renderWorld' world = do
+  let graphics = map (map (renderEntity)) (layout $ M.toAscList $ world^.entities)
+      layout   = groupBy (\(u,_) (v,_) -> u^._y /= v^._y)
+  mapM_ putStrLn graphics
+
+renderEntity :: (V2 Integer, Entity) -> Char
+renderEntity (p, Floor)     = '-'
+renderEntity (p, (Hero s))  = 'H'
+renderEntity (p, (Boss s))  = 'M'
+renderEntity (p, (Wall))    = '#'
+renderEntity (p, (Bomb _))  = 'o'
+renderEntity (p, (Fire s))  | s^.life < 2 = 'x'
+                            | otherwise   = 'X'
+renderEntity _  = '?'
+
+hide :: IO a -> IO a
+hide action = bracket_
+  (hSetEcho stdin False)
+  (hSetEcho stdin True)
+  action
+
+
+
+

src/Draw.hs

+{-# Language DeriveFunctor #-}
+{-# Language DeriveGeneric #-}
+{-# Language TemplateHaskell #-}
+
+module Draw
+        ( Options(..)
+        , VisObject(..)
+        , Color(..)
+        , Drawable(..)
+        , display
+        , display'
+        , simulate
+        , simulate'
+        , play
+        , play'
+        , Event(..)
+        ) where
+
+import GHC.Generics ( Generic )
+import Data.Maybe (fromMaybe, isNothing)
+import Control.Monad (unless)
+import UI.NCurses hiding (Color)
+import System.CPUTime
+import Control.Monad.IfElse
+import Control.Monad.IO.Class
+import Control.Lens
+import Linear.V2
+
+data Color = White | Black | Red | Green deriving (Eq,Show)
+
+data Options =
+  Options
+  { _optBackgroundColor :: Maybe Color             -- ^ optional background color
+  , _optWindowSize      :: Maybe (Integer,Integer) -- ^ optional (row,col) window size
+  , _optWindowPosition  :: Maybe (Integer,Integer) -- ^ optional (row,col) window origin
+  } deriving Show
+
+makeLenses (''Options)
+
+data VisObject a = VisObjects [VisObject a]
+                 | Trans (V2 Integer) (VisObject a)
+                 | LineV (V2 Integer)  a  Color
+                 | LineH (V2 Integer)  a  Color
+                 | Char  (V2 Integer)  a  Color
+                 | Text  (V2 Integer) [a] Color
+                 deriving (Generic, Functor)
+
+class Drawable a where
+        c :: a -> Char
+
+instance Drawable Char where
+        c = id
+
+type ColorCache = (ColorID, ColorID, ColorID, ColorID)
+
+initColors :: Curses ColorCache
+initColors = do
+        cWhite <- newColorID ColorWhite ColorWhite 10
+        cBlack <- newColorID ColorBlack ColorWhite 11
+        cRed   <- newColorID ColorRed   ColorWhite 12
+        cGreen <- newColorID ColorGreen ColorWhite 13
+        return ( cWhite, cBlack, cRed, cGreen)
+
+white = _1
+black = _2
+red   = _3
+green = _4
+
+initWindow :: Options -> Curses (ColorCache, Window)
+initWindow options = do
+        win <- newWindow
+                  (fromMaybe 60 $ options^?optWindowSize._Just._1)
+                  (fromMaybe 80 $ options^?optWindowSize._Just._2)
+                  (fromMaybe 0  $ options^?optWindowPosition._Just._2)
+                  (fromMaybe 0  $ options^?optWindowPosition._Just._1)
+        colors  <- initColors
+        bgRed   <- newColorID ColorWhite ColorRed   14
+        bgGreen <- newColorID ColorWhite ColorGreen 15
+        let bgCol Black = colors^.white
+            bgCol White = colors^.black
+            bgCol Red   = bgRed
+            bgCol Green = bgGreen
+        updateWindow win $ setColor $ bgCol
+                                (fromMaybe Black $ options^.optBackgroundColor)
+        return (colors, win)
+
+display :: Drawable a => Options -> VisObject a -> Curses ()
+display options toDraw = do
+        (colors, win) <- initWindow options
+        updateWindow win $ clear >> rawDraw colors toDraw
+        render
+        waitKeyEvent win
+
+display' options toDraw = runCurses $ display options toDraw 
+
+waitKeyEvent :: Window -> Curses ()
+waitKeyEvent win = do
+        let isKeyEvent (Just (EventCharacter _))  = True
+            isKeyEvent (Just (EventSpecialKey _)) = True
+            isKeyEvent _                   = False
+        event <- getEvent win Nothing
+        unless (isKeyEvent event) $ waitKeyEvent win
+
+waitQKey :: Window -> Integer -> Curses Bool
+waitQKey win timeout = do
+        start <- liftIO getCPUTime
+        let isQKey (Just (EventCharacter 'q')) = True
+            isQKey _                           = False
+        event <- getEvent win $ Just timeout
+        if isNothing event
+           then return False
+           else if isQKey event
+           then return True
+           else do
+                   now <- liftIO getCPUTime
+                   waitQKey win $ timeout - round
+                     ((fromIntegral (now - start)::Double) / (10^9::Double))
+
+simulate' options sampleRate model drawFunction simulateFunction = runCurses $ simulate options sampleRate model drawFunction simulateFunction
+simulate :: (Drawable a) => Options -> Integer -> world -> (world -> VisObject a) -> (Double -> world -> world) -> Curses ()
+simulate options sampleRate model drawFunction simulateFunction = do
+        (colors, win) <- initWindow options
+        let simulateLoop model = do
+              start <- liftIO getCPUTime
+              updateWindow win $ clear >> rawDraw colors (drawFunction model)
+              render
+              isQKey <- waitQKey win sampleRate
+              unless isQKey $ do
+                      now <- liftIO getCPUTime
+                      simulateLoop $ simulateFunction ((fromIntegral (now - start)::Double) / 10^9) model
+
+        simulateLoop model
+
+play' options sampleRate model drawFunction simulateFunction eventHamdler =
+        runCurses $ play options sampleRate model drawFunction simulateFunction eventHamdler
+play :: (Drawable a)
+     => Options
+     -> Integer
+     -> world
+     -> (world -> VisObject a)
+     -> (Double -> world -> world)
+     -> (Event -> world -> world)
+     -> Curses ()
+play options sampleRate model drawFunction simulateFunction eventHamdler = do
+        (colors, win) <- initWindow options
+        let playLoop model = do
+              start <- liftIO getCPUTime
+              updateWindow win $ clear >> rawDraw colors (drawFunction model)
+              render
+              event <- getEvent win $ Just sampleRate
+              now <- liftIO getCPUTime
+              let model' = simulateFunction ((fromIntegral (now - start)::Double) / 10^9) model
+                  model'' = case event of
+                              (Just event') -> eventHamdler event' model'
+                              _             -> model'
+              playLoop model''
+        playLoop model
+
+
+rawDraw :: Drawable a => ColorCache -> VisObject a -> Update ()
+rawDraw colors (VisObjects a) = sequence_ $ rawDraw colors <$> a
+rawDraw colors (Trans t d) = rawDraw colors $ translate t d
+rawDraw colors (Text pos t col) = do
+        moveCursor (pos^._x) (pos^._y)
+        sequence_ $ drawC <$> t
+        where drawC a = drawGlyph $ Glyph (a^.to c) [col2Attr colors col]
+rawDraw colors (Char pos a color) = do
+        moveCursor (pos^._x) (pos^._y)
+        drawGlyph $ Glyph (a^.to c) [color^.to attrColor]
+                where attrColor = col2Attr colors
+rawDraw colors (LineH pos a color) = do
+        moveCursor (pos^._x) 0
+        drawLineH (Just $ Glyph (a^.to c) [col2Attr colors color]) 20
+rawDraw colors (LineV pos a color) = do
+        moveCursor 0 (pos^._y)
+        drawLineV (Just $ Glyph (a^.to c) [col2Attr colors color]) 20
+
+col2Attr :: ColorCache -> Color -> Attribute
+col2Attr colors White = AttributeColor $ colors^.white
+col2Attr colors Black = AttributeColor $ colors^.black
+col2Attr colors Green = AttributeColor $ colors^.green
+col2Attr colors Red   = AttributeColor $ colors^.red
+
+translate :: V2 Integer -> VisObject a -> VisObject a
+translate t (VisObjects a) = VisObjects $ translate t <$> a
+translate t (Trans t' d) = translate (t+t') d
+translate t (Text pos a c) = Text (pos+t) a c
+translate t (LineV pos a c) = LineV (pos+t & _x .~ 0) a c
+translate t (LineH pos a c) = LineH (pos+t & _y .~ 0) a c
+translate t (Char pos a c) = Char (pos+t) a c
+

src/GameConfig.hs

+{-# Language TemplateHaskell #-}
+module GameConfig
+  ( GameConfig(..)
+  , defaultConfig
+  , getAction
+  , worldSize
+  , ncursesOpts
+  , keyMap
+  ) where
+
+import Draw
+import Control.Lens
+import GameTypes
+import Linear
+
+-- | Holds the basic configurations of the game.
+data GameConfig = GameConfig
+  { _worldSize   :: (Integer, Integer)
+  , _ncursesOpts :: Options
+  , _keyMap      :: Char -> Maybe Action
+  }
+
+-- | Specifies a game configuration for a given size, background color and key mapping.   
+makeConfig :: (Integer, Integer) -> Maybe Color -> (Char -> Maybe Action) -> GameConfig
+makeConfig size optBackgroundColor keyMapping = GameConfig size opts keyMapping
+  where opts = Options optBackgroundColor (Just $ size & _1 +~ 5 & _2 +~ 5) Nothing
+
+-- | Default game configuration.
+defaultConfig :: GameConfig
+defaultConfig = makeConfig (20, 32) (Just Red) getAction
+
+-- | Default key mapping.
+getAction :: Char -> Maybe Action
+getAction 'w' = Just $ Move North
+getAction 'a' = Just $ Move West
+getAction 's' = Just $ Move South
+getAction 'd' = Just $ Move East
+getAction ' ' = Just Attack
+getAction 'p' = Just Pause
+getAction 't' = Just SetTrap
+getAction _   = Nothing
+
+
+-- * Lenses for the GameConfig type
+
+$(makeLenses ''GameConfig)
+

src/GameDraw.hs

+module GameDraw 
+        ( toVisObject
+        , renderWorld
+        ) where
+
+import Draw
+import GameTypes
+import Linear
+import Control.Lens
+import qualified Data.Map as M
+
+toVisObject :: (V2 Integer, Entity) -> VisObject Char
+toVisObject (p, Hero s)  = 
+  VisObjects [ Text (V2 1 0) ("Life: " ++ s^.life.to show ++ " ") Green
+             , case () of
+                    _ | s^.orient == North -> Char p 'N' Green
+                      | s^.orient == South -> Char p 'S' Green
+                      | s^.orient == East  -> Char p 'E' Green
+                      | s^.orient == West  -> Char p 'W' Green
+             ]
+toVisObject (p, Boss s)  = 
+  VisObjects [ Text (V2 0 0) ("Bosslife: " ++ s^.life.to show ++ " ") Red
+             , Char p 'M' Black
+             ]
+toVisObject (p, Floor)                = Char p '-' White
+toVisObject (p, Wall)                 = Char p '#' Black
+toVisObject (p, Bomb _)               = Char p '💣' Black
+toVisObject (p, Fire s) | s^.life < 2 = Char p '🔥' Red
+                        | otherwise   = Char p '🔥' Red
+
+renderWorld :: World -> VisObject Char
+renderWorld w = 
+ let map = toVisObject . (_1._x +~ (2::Integer)) <$> (w^.entities.to M.toList)
+     wonMsg     = Text (V2 1 12) " WON! " Green
+     lostMsg    = Text (V2 1 12) " Lost " Red
+     heroIsDead = w^.entities.at (w^.heroPos)^?_Just._Hero.life.to (<=0) & and
+ in case w^.mode of
+         Ended | heroIsDead -> VisObjects $ lostMsg : map
+               | otherwise  -> VisObjects $ wonMsg  : map
+         _                  -> VisObjects map

src/GameLogic.hs

+module GameLogic where
+
+import GameTypes
+import Control.Lens
+import Linear
+import Data.Maybe
+import Data.Char
+import qualified Data.Map as M
+
+
+{- * Initialization -}
+
+-- | Generates a world with the hero and an endboss at a specific positions 
+--   in a dungeon with a specific size.
+newWorldWithBoss :: V2 Integer -> V2 Integer -> (Integer, Integer) -> World  -- XXX: ??! This looks very ugly. What does it even do? Some refactoring should be done. Also, use record syntax to make things clear..   
+newWorldWithBoss hPos mPos size = entities.at mPos._Just .~ Boss (Stats West 500)
+ $ entities.at hPos ?~ Hero (Stats East 100)
+ $ World Active 0 
+     (walls (atBorder size) $ M.fromList $ map (flip (,) Floor) $ V2 <$> [0..(size^._1)] <*> [0..(size^._2)]) 
+     hPos
+
+-- | Creates a new bomb with a certain life time and orientation.
+newBomb :: Integer -> Direction -> Entity
+newBomb l d = Bomb (Stats d l)
+
+-- | Creates a new small fire
+fire :: Entity
+fire = Fire (Stats North 1)
+
+-- | Creates a new big fire.
+bigFire :: Entity
+bigFire = Fire (Stats North 3)
+
+-- | Tests whether a position is on the edge of the map.
+atBorder :: (Integer,Integer) -> Position -> Bool
+atBorder (bx,by) (V2 x y) = x `elem` [bx,0] || y `elem` [by,0]
+
+-- | Places walls on the edge of the dungeon map.
+walls :: (V2 Integer -> Bool) -> Dungeon -> Dungeon
+walls test = M.mapWithKey (\pos c -> if test pos then Wall else c)
+
+
+{- * Game logic -}
+
+-- | Performs an action on the game state (world). 
+performAction :: World -> Action -> World
+performAction w a = 
+  case (w^.mode,a) of
+       (Active,Move dir) -> updateWorld.moveHero (toVector dir) $ w
+       (Active,Attack)   -> updateWorld.attack $ w
+       (Active,SetTrap)  -> w  -- TODO setTrap...
+       (Active,Pause)    -> mode.~Paused $ w
+       (Paused,Pause)    -> mode.~Active $ w
+       _                 -> w 
+
+-- | Updates the all the entities in the world by calling the function updateDungeon 
+--   and registers a game turn.
+updateWorld :: World -> World
+updateWorld = updateDungeon.count
+  where count = turn +~ 1
+
+-- | Updates all the entities in the dungeon.
+updateDungeon :: World -> World 
+updateDungeon w = M.foldrWithKey updateEnt w (w^.entities)
+  where updateEnt pos ent = 
+          case ent of
+               Bomb s | s^.life.to (<=0) -> explodeBomb pos
+                      | otherwise        -> moveBomb pos (s^.orient.to toVector)
+               Fire s | s^.life.to (<=0) -> entities %~ M.insert pos Floor
+                      | otherwise        -> entities.at pos._Just._Fire.life -~ 1
+               Boss s | s^.life.to (<=0) -> (mode .~ Ended) . (entities %~ M.insert pos (Boss s ))
+                      | otherwise        -> updateBoss pos
+               Hero s | s^.life.to (<=0) -> (mode .~ Ended) . (entities %~ M.insert pos (Hero s ))
+                      | otherwise        -> id
+               _                         -> id
+
+-- | Updates the boss at a given position. The bosses behavior depends on the turn counter. 
+--   Generally the boss tries to approach the hero and attack him by throwing bombs at him.  
+updateBoss :: Position -> World -> World
+updateBoss pos w = 
+  let atHero = badAiming $ w^.heroPos - pos
+      spawnPos = pos + atHero
+      withRandomTimer = w^.turn.to (\t -> 2 + (1 + mod t 5)*(1 + mod t 3))
+  in case w^.turn.to (`mod` 16) of
+          0  -> moveBoss  pos (V2 1 0) w
+          1  -> moveBoss  pos atHero w
+          2  -> throwBomb spawnPos withRandomTimer atHero w
+          3  -> w
+          4  -> moveBoss  pos (negate atHero) w
+          5  -> moveBoss  pos (V2 (-1) 0) w
+          6  -> moveBoss  pos (V2 0 (-1)) w
+          7  -> throwBomb spawnPos withRandomTimer atHero w
+          8  -> moveBoss  pos (negate atHero) w
+          9  -> moveBoss  pos atHero w
+          10 -> moveBoss  pos (V2 0 1) w
+          11 -> moveBoss  pos atHero w
+          12 -> moveBoss  pos atHero w
+          13 -> moveBoss  pos atHero w
+          14 -> moveBoss  pos atHero w
+          15 -> throwBomb spawnPos withRandomTimer atHero w
+          _  -> w
+
+-- | Calculates the approximate direction of the hero.
+badAiming :: DirVector -> DirVector
+badAiming relPos = 
+  case abs <$> relPos of
+       p | p^._x < p^._y -> signum relPos & _x .~ 0
+         | otherwise     -> signum relPos & _y .~ 0
+
+-- | If possible, this function moves the hero into a given direction by calling the function moveFrom. 
+--   Otherwise, only the orientation is changed towards the intended direction of movement.
+moveHero :: DirVector -> World -> World
+moveHero dir w = 
+  let pos  = w^.heroPos
+      aim  = pos + dir
+  in case w^.entities.at aim of
+          Just Floor    -> w & heroPos .~ aim & entities %~ moveFrom pos dir
+          Just (Fire _) -> w & heroPos .~ aim & entities.at pos._Just._Hero.life -~ 10 & entities %~ moveFrom pos dir  -- XXX magic number.. issue: implement damage system
+          _             -> w & entities.at pos._Just.stats.orient .~ (fromVector dir)
+
+-- | If possible, this function moves the boss into a given direction by calling the function moveFrom. 
+--   Otherwise, only the orientation is changed towards the intended direction of movement.
+moveBoss :: Position -> DirVector -> World -> World
+moveBoss pos dir w = 
+  let aim = pos + dir
+  in case w^.entities.at aim of
+          Just Floor -> w & entities %~ moveFrom pos dir
+          Just Trap  -> w -- TODO setTrap...
+          _          -> w & entities.at pos._Just.stats.orient .~ (fromVector dir)
+
+-- | If possible, this function moves a bomb at a given position into a given direction
+--   by calling the function moveFrom. Otherwise, the bomb explodes.
+moveBomb :: Position -> DirVector -> World -> World
+moveBomb pos dir w = 
+  let aim  = pos + dir
+  in case w^.entities.at aim of
+          Just Floor                  -> w & entities %~ moveFrom pos dir
+          Just (Fire s) | s^.life < 2 -> w & entities %~ moveFrom pos dir
+                        | otherwise   -> w & explodeBomb pos
+          _                           -> w & explodeBomb pos
+
+-- | Moves any movable entity with at a given position into a given direction.
+moveFrom :: Position -> DirVector -> Dungeon -> Dungeon
+moveFrom p d dungeon = 
+  case dungeon^.at p of
+       Just (Hero s) -> M.insert (p+d) (Hero (s & orient .~ fromVector d)) $ M.insert p Floor dungeon
+       Just (Bomb s) -> M.insert (p+d) (Bomb (s & life -~ 1))              $ M.insert p Floor dungeon
+       Just (Boss s) -> M.insert (p+d) (Boss (s & orient .~ fromVector d)) $ M.insert p Floor dungeon
+       _             -> dungeon
+
+-- | Attacks the location in front of the hero. Erases fires, harms enemies.
+attack :: World -> World
+attack w = 
+  let pos = w^.heroPos
+      maybeAim = w^.entities.at pos^?_Just.stats.orient.to ((pos +).toVector)
+  in case maybeAim >>= \aim -> (,) aim <$> w^.entities.at aim of
+           Just (aim,Boss s) -> w & entities.at aim._Just._Boss.life -~ 45  -- XXX magic number.. issue: implement damage system
+           Just (aim,Fire _) -> w & entities %~ M.insert aim Floor
+           _                 -> w
+
+-- | Sets a trap in front of the hero, that harms enemies if stepped on.
+setTrap :: World -> World
+setTrap w = w -- TODO setTrap...
+
+-- | Creates a bomb at a given position with specific detonation delay and orientation.
+throwBomb :: Position -> Integer -> DirVector -> World -> World
+throwBomb pos delay dir w = 
+  case w^.entities.at pos of
+       Just Floor -> w & entities %~ M.insert pos (newBomb delay $ fromVector dir)
+       _          -> w & explodeBomb pos
+
+-- | Creates a big fire at a given position and eight small fires adjacent to that position.
+--   If the hero is at one of these positions he gets damaged.
+explodeBomb :: Position -> World -> World
+explodeBomb p w = foldr maybeSetFire w (around p)
+  where
+    maybeSetFire pos w' = 
+      case w'^.entities.at pos of
+           Just (Bomb  _) | pos==p    -> w' & entities %~ M.insert pos bigFire
+                          | otherwise -> w' & entities %~ M.insert pos bigFire & explodeBomb pos
+           Just Floor                 -> w' & entities %~ M.insert pos fire
+           Just (Hero  s) | pos==p    -> w' & entities %~ M.insert pos (Hero (s & life -~ 30))  -- XXX magic number.. issue: implement damage system
+                          | otherwise -> w' & entities %~ M.insert pos (Hero (s & life -~ 10))  -- XXX magic number.. issue: implement damage system
+           _                          -> w'
+
+-- | Calculates the adjacent positions of a given position
+around :: Position -> [Position]
+around pos = (+pos) <$> (V2 <$> [-1..1] <*> [-1..1])

src/GameTypes.hs

+{-# Language TemplateHaskell #-}
+module GameTypes where
+
+import Control.Lens
+import Linear
+import qualified Data.Map as M
+
+{- * Types-}
+
+-- | World represents the current game state with a game mode, 
+--   a turn counter, a map of entitites and the hero's position.
+data World
+  = World
+  { _mode     :: Mode
+  , _turn     :: Integer
+  , _entities :: Dungeon
+  , _heroPos  :: Position
+  } deriving (Show,Eq)
+
+-- | Mode can be one of three things: 
+--
+--   - Active – the game is currently running; player can control hero 
+--   - Ended – the game has ended; hero or boss is dead 
+--   - Paused – the game is paused; player can only unpause or restart the game 
+data Mode 
+  = Active
+  | Ended
+  | Paused
+   deriving (Show,Eq)
+
+-- | A lazy Data.Map which associates all the entities in the 
+--   dungeon with its coordinates (Position)
+type Dungeon = M.Map Position Entity
+
+-- | Position of an entity in the world
+type Position = V2 Integer
+
+-- | Entity can be one of six things: 
+-- 
+--   - Hero – under the control of the player
+--   - Boss – controlled by the computer; fights the hero with bombs
+--   - Floor – empty tile in the dungeon
+--   - Wall – cannot be passed
+--   - Bomb – thrown by enemies; eventually exploding
+--   - Fire – burning tile emerging from explosions
+data Entity
+  = Hero  { _stats :: Stats }
+  | Boss  { _stats :: Stats }
+  | Bomb  { _stats :: Stats }
+  | Fire  { _stats :: Stats }
+  | Trap
+  | Floor
+  | Wall
+  deriving (Show, Eq)
+
+-- | Stats represents two things: 
+-- 
+--   - Orientation – the direction, in which an entity is oriented
+--   - Life – the life energy or (!) life time of an entity
+data Stats
+  = Stats
+  { _orient  :: Direction
+  , _life    :: Integer
+  } deriving (Show,Eq)
+
+-- | Direction vector
+type DirVector = V2 Integer
+
+-- | Direction of an entity in the world
+data Direction 
+  = North
+  | South
+  | West
+  | East
+  deriving (Show, Eq)
+
+-- | Converts to a vector (V2 Integer)
+toVector :: Direction -> DirVector
+toVector North = V2 (-1)  0
+toVector South = V2   1   0
+toVector West  = V2   0 (-1)
+toVector East  = V2   0   1
+
+-- | Gets a Direction from a vector (V2 Integer) 
+fromVector :: DirVector -> Direction
+fromVector vec =
+  case abs <$> vec of
+       v | v^._x >  v^._y && vec^._x >  0 -> South
+         | v^._x >  v^._y && vec^._x <= 0 -> North
+         | v^._x <= v^._y && vec^._y >  0 -> East
+         | otherwise                      -> West
+
+-- | Action can be one of three things
+-- 
+--   - Move – the player moves the hero in a specified direction
+--   - Attack – the player attacks the location in front of the hero
+--   - Pause – the player pauses the game
+--   - SetTrap – the player sets a trap in front of the hero
+data Action 
+  = Move  { _movDir :: Direction }
+  | Attack
+  | Pause
+  | SetTrap
+   deriving (Show,Eq)
+
+{- * Lenses for the World type -}
+$(makeLenses ''World)
+
+{- * Prisms for the Entity type -}
+$(makePrisms ''Entity)
+
+{- * Traversals for the Entity type -}
+$(makeLenses ''Entity)
+
+{- * Lenses for the Stats type -}
+$(makeLenses ''Stats)
+
+{- * Prisms for the Action type -}
+$(makePrisms ''Action)
+
+{- * Traversals for the Action type -}
+$(makeLenses ''Action)
+
+

src/Lib.hs

+module Lib
+    ( someFunc
+    ) where
+
+import GameTypes
+import GameLogic
+import GameDraw
+import GameConfig
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"

stack.yaml

+flags: {}
+extra-package-dbs: []
+packages:
+- '.'
+extra-deps:
+- ncurses-0.2.16
+resolver: lts-8.12

test/Game-Spec.hs

+{-# Language TypeSynonymInstances #-}
+{-# Language FlexibleInstances #-}
+import GameLogic
+import GameTypes
+import Test.QuickCheck
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+import Test.Framework.Runners.Console (defaultMain)
+import Linear
+import Control.Monad
+import Data.Map
+import Control.Lens hiding (elements)
+import Data.Maybe
+
+instance Arbitrary World  where
+        arbitrary = do
+                dx <- choose (4, 100)
+                dy <- choose (4, 100)
+                my <- choose (1, dy-1)
+                mx <- choose (1, dx-1)
+                hy <- choose (1, dy-1)
+                hx <- choose (1, dx-1) `suchThat` (\hx -> mx /= hx || my /= hy)
+                return $ newWorld (V2 hx hy) (V2 mx my) (dx, dy)
+
+type Step = V2 Integer
+
+instance Arbitrary Step where
+        arbitrary = elements (V2 <$> [-1,0,1] <*> [-1,0,1]) `suchThat` ((==1).quadrance) 
+
+bewegungProp1 :: World -> Step -> Property
+bewegungProp1 world d =
+        and ((world^.entities.to findMax._1.to (subtract d) - world^.heroPos)^..each.to (> 0)) &&
+        (world^.entities.at (world^.heroPos + d)^?_Just._Floor)^.to isJust ==>
+        world^.to (performAction (Just $ Move d)).heroPos == (world^.heroPos)
+
+bewegungTest1 = testProperty "Bewegung Test 1" bewegungProp1 -- FIXME: I think I'm broken. What's wrong with me?
+
+tests = [bewegungTest1]
+
+main :: IO ()
+main = defaultMain tests

zettel4.cabal

+name:                zettel4
+version:             0.1.0.0
+synopsis:            First Assignment of FFPiHaskell 2017
+description:         Zettel 4
+homepage:            https://github.com/FFPiHaskell/zettel4-skeleton#readme
+license:             BSD3
+license-file:        LICENSE
+author:              FFPiHaskell Tutors
+maintainer:          sdressel@techfak.uni-bielefeld.de
+copyright:           2017 FFPiHaskell Tutors
+category:            cli
+build-type:          Simple
+extra-source-files:  README.md
+cabal-version:       >=1.10
+
+
+-- library for all things common in all exercises/not neccessary for students
+-- to solve assignments
+library
+  hs-source-dirs:      src
+  exposed-modules:     Lib
+                     , GameLogic
+                     , GameTypes
+                     , GameConfig
+                     , GameDraw
+                     , Draw
+  build-depends:       base >= 4.7 && < 5
+                     , ncurses
+                     , IfElse
+                     , lens
+                     , linear
+                     , containers
+  default-language:    Haskell2010
+
+executable Game
+  hs-source-dirs:      app
+  main-is:             GameMain.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , zettel4
+                     , IfElse
+                     , lens
+                     , linear
+                     , containers
+  default-language:    Haskell2010
+
+test-suite Game-tests
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Game-Spec.hs
+  build-depends:       base
+                     , zettel4
+                     , test-framework
+                     , test-framework-quickcheck2
+                     , QuickCheck
+                     , linear
+                     , containers
+                     , lens
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  default-language:    Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/FFPiHaskell/zettel4-skeleton
+