FFPiH/uebung2017-4
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

first commit

Browse Source
This commit is contained in:
BergesJ 2017-05-15 00:35:13 +02:00
commit 78d26a57bf
15 changed files with 964 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
.gitignore vendored Normal file
View File

@ -0,0 +1,19 @@
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

41
.travis.yml Normal file
View File

@ -0,0 +1,41 @@
# 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

30
LICENSE Normal file
View File

@ -0,0 +1,30 @@
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.

88
README.md Normal file
View File

@ -0,0 +1,88 @@
Ü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

2
Setup.hs Normal file
View File

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

71
app/GameMain.hs Normal file
View File

@ -0,0 +1,71 @@
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

191
src/Draw.hs Normal file
View File

@ -0,0 +1,191 @@
{-# 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

47
src/GameConfig.hs Normal file
View File

@ -0,0 +1,47 @@
{-# 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)

40
src/GameDraw.hs Normal file
View File

@ -0,0 +1,40 @@
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

188
src/GameLogic.hs Normal file
View File

@ -0,0 +1,188 @@
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])

124
src/GameTypes.hs Normal file
View File

@ -0,0 +1,124 @@
{-# 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)

11
src/Lib.hs Normal file
View File

@ -0,0 +1,11 @@
module Lib
( someFunc
) where
import GameTypes
import GameLogic
import GameDraw
import GameConfig
someFunc :: IO ()
someFunc = putStrLn "someFunc"

7
stack.yaml Normal file
View File

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

40
test/Game-Spec.hs Normal file
View File

@ -0,0 +1,40 @@
{-# 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

65
zettel4.cabal Normal file
View File

@ -0,0 +1,65 @@
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