From 78d26a57bf1c3516c20422bc91c2f6c6d1be3dd7 Mon Sep 17 00:00:00 2001 From: BergesJ Date: Mon, 15 May 2017 00:35:13 +0200 Subject: [PATCH] first commit --- .gitignore | 19 +++++ .travis.yml | 41 ++++++++++ LICENSE | 30 ++++++++ README.md | 88 +++++++++++++++++++++ Setup.hs | 2 + app/GameMain.hs | 71 +++++++++++++++++ src/Draw.hs | 191 ++++++++++++++++++++++++++++++++++++++++++++++ src/GameConfig.hs | 47 ++++++++++++ src/GameDraw.hs | 40 ++++++++++ src/GameLogic.hs | 188 +++++++++++++++++++++++++++++++++++++++++++++ src/GameTypes.hs | 124 ++++++++++++++++++++++++++++++ src/Lib.hs | 11 +++ stack.yaml | 7 ++ test/Game-Spec.hs | 40 ++++++++++ zettel4.cabal | 65 ++++++++++++++++ 15 files changed, 964 insertions(+) create mode 100644 .gitignore create mode 100644 .travis.yml create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 app/GameMain.hs create mode 100644 src/Draw.hs create mode 100644 src/GameConfig.hs create mode 100644 src/GameDraw.hs create mode 100644 src/GameLogic.hs create mode 100644 src/GameTypes.hs create mode 100644 src/Lib.hs create mode 100644 stack.yaml create mode 100644 test/Game-Spec.hs create mode 100644 zettel4.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a4ee41a --- /dev/null +++ b/.gitignore @@ -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 diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..5ccfeba --- /dev/null +++ b/.travis.yml @@ -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 + diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..6a042c2 --- /dev/null +++ b/LICENSE @@ -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. \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..fc322bd --- /dev/null +++ b/README.md @@ -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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/GameMain.hs b/app/GameMain.hs new file mode 100644 index 0000000..f1725ea --- /dev/null +++ b/app/GameMain.hs @@ -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 + + + + diff --git a/src/Draw.hs b/src/Draw.hs new file mode 100644 index 0000000..c23bafe --- /dev/null +++ b/src/Draw.hs @@ -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 + diff --git a/src/GameConfig.hs b/src/GameConfig.hs new file mode 100644 index 0000000..ff238df --- /dev/null +++ b/src/GameConfig.hs @@ -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) + diff --git a/src/GameDraw.hs b/src/GameDraw.hs new file mode 100644 index 0000000..2dbcca5 --- /dev/null +++ b/src/GameDraw.hs @@ -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 diff --git a/src/GameLogic.hs b/src/GameLogic.hs new file mode 100644 index 0000000..60605a8 --- /dev/null +++ b/src/GameLogic.hs @@ -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]) diff --git a/src/GameTypes.hs b/src/GameTypes.hs new file mode 100644 index 0000000..5c36cca --- /dev/null +++ b/src/GameTypes.hs @@ -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) + + diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 index 0000000..4f49e3b --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,11 @@ +module Lib + ( someFunc + ) where + +import GameTypes +import GameLogic +import GameDraw +import GameConfig + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..8f01093 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,7 @@ +flags: {} +extra-package-dbs: [] +packages: +- '.' +extra-deps: +- ncurses-0.2.16 +resolver: lts-8.12 diff --git a/test/Game-Spec.hs b/test/Game-Spec.hs new file mode 100644 index 0000000..f2cc857 --- /dev/null +++ b/test/Game-Spec.hs @@ -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 diff --git a/zettel4.cabal b/zettel4.cabal new file mode 100644 index 0000000..c392e04 --- /dev/null +++ b/zettel4.cabal @@ -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 +