first commit
This commit is contained in:
BergesJ
commit
78d26a57bf
19
.gitignore
vendored
Normal file
19
.gitignore
vendored
Normal 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
41
.travis.yml
Normal 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
30
LICENSE
Normal 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
88
README.md
Normal 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
|
||||
|
||||
71
app/GameMain.hs
Normal file
71
app/GameMain.hs
Normal 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
191
src/Draw.hs
Normal 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
47
src/GameConfig.hs
Normal 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
40
src/GameDraw.hs
Normal 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
188
src/GameLogic.hs
Normal 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
124
src/GameTypes.hs
Normal 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
11
src/Lib.hs
Normal 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
7
stack.yaml
Normal 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
40
test/Game-Spec.hs
Normal 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
65
zettel4.cabal
Normal 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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user