From abe5a5dc85684de2d1863dada51f44f3a3ba4a18 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sat, 17 Nov 2018 19:11:36 +0100 Subject: [PATCH] Initializing repos with a basic websocket handler for a few basic messages --- .gitignore | 3 ++ ChangeLog.md | 5 +++ LICENSE | 30 ++++++++++++++++ Setup.hs | 2 ++ pokeNeige.cabal | 54 +++++++++++++++++++++++++++++ src/Area.hs | 52 ++++++++++++++++++++++++++++ src/Area/Climate.hs | 14 ++++++++ src/Area/NaturalElements.hs | 17 ++++++++++ src/Area/Tile.hs | 46 +++++++++++++++++++++++++ src/Automaton.hs | 30 ++++++++++++++++ src/Character.hs | 42 +++++++++++++++++++++++ src/Config.hs | 8 +++++ src/Game.hs | 67 ++++++++++++++++++++++++++++++++++++ src/Item.hs | 32 +++++++++++++++++ src/Main.hs | 39 +++++++++++++++++++++ src/Message.back.hs | 26 ++++++++++++++ src/Message.hs | 37 ++++++++++++++++++++ src/Message/Client.hs | 17 ++++++++++ src/Message/Server.hs | 22 ++++++++++++ src/Pokemon.hs | 33 ++++++++++++++++++ src/Pokemon/Move.hs | 57 +++++++++++++++++++++++++++++++ src/Pokemon/Species.hs | 27 +++++++++++++++ src/Pokemon/Stats.hs | 68 +++++++++++++++++++++++++++++++++++++ src/Pokemon/Status.hs | 14 ++++++++ src/Pokemon/Type.hs | 5 +++ src/Tool/Array.hs | 23 +++++++++++++ 26 files changed, 770 insertions(+) create mode 100644 .gitignore create mode 100644 ChangeLog.md create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 pokeNeige.cabal create mode 100644 src/Area.hs create mode 100644 src/Area/Climate.hs create mode 100644 src/Area/NaturalElements.hs create mode 100644 src/Area/Tile.hs create mode 100644 src/Automaton.hs create mode 100644 src/Character.hs create mode 100644 src/Config.hs create mode 100644 src/Game.hs create mode 100644 src/Item.hs create mode 100644 src/Main.hs create mode 100644 src/Message.back.hs create mode 100644 src/Message.hs create mode 100644 src/Message/Client.hs create mode 100644 src/Message/Server.hs create mode 100644 src/Pokemon.hs create mode 100644 src/Pokemon/Move.hs create mode 100644 src/Pokemon/Species.hs create mode 100644 src/Pokemon/Stats.hs create mode 100644 src/Pokemon/Status.hs create mode 100644 src/Pokemon/Type.hs create mode 100644 src/Tool/Array.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..3c6d70f --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +dist/ +.cabal-sandbox +cabal.sandbox.config diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..f540896 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for pokeNeige + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..961dd8f --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Tissevert + +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 Tissevert 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. 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/pokeNeige.cabal b/pokeNeige.cabal new file mode 100644 index 0000000..6d1de64 --- /dev/null +++ b/pokeNeige.cabal @@ -0,0 +1,54 @@ +-- Initial pokeNeige.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: pokeNeige +version: 0.1.0.0 +synopsis: A web pokemon game +-- description: +homepage: https://git.marvid.fr/PokeNeige +license: BSD3 +license-file: LICENSE +author: Tissevert +maintainer: tissevert+devel@marvid.fr +-- copyright: +category: Game +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +executable pokeNeige + main-is: Main.hs + other-modules: Area + , Area.Climate + , Area.NaturalElements + , Area.Tile + , Automaton + , Character + , Config + , Game + , Item + , Message + , Message.Client + , Message.Server + , Pokemon + , Pokemon.Move + , Pokemon.Species + , Pokemon.Stats + , Pokemon.Status + , Pokemon.Type + , Tool.Array + -- other-extensions: + build-depends: base >=4.11 && <4.12 + , aeson + , bytestring + , containers + , http-types + , mtl + , vector + , wai + , wai-websockets + , warp + , websockets + ghc-options: -Wall + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Area.hs b/src/Area.hs new file mode 100644 index 0000000..7d17d01 --- /dev/null +++ b/src/Area.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLists #-} +module Area ( + Area(..) + , Key + , dex + ) where + +import Data.Aeson (ToJSON(..), FromJSON(..), genericParseJSON, genericToEncoding, defaultOptions) +import Data.Vector (Vector) +import GHC.Generics (Generic) +import Area.Tile (Content(..), Tile(..), Terrain(..)) +import Area.Climate (Climate(..)) + +data Area = Area { + matrix :: Vector (Vector Tile) + } deriving (Generic) + +instance ToJSON Area where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Area where + parseJSON = genericParseJSON defaultOptions + +newtype Key = Key Int deriving (Generic) + +instance ToJSON Key where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Key where + parseJSON = genericParseJSON defaultOptions + +dex :: Vector Area +dex = [ + Area { + matrix = [ + [ground, ground] + , [ground, water] + ] + } + ] + where + ground = Tile { + terrain = Normal + , skin = "tiles/ground.png" + , climate = Mild + , content = Empty + } + water = Tile { + terrain = Water + , skin = "tiles/water.png" + , climate = Mild + , content = Empty + } diff --git a/src/Area/Climate.hs b/src/Area/Climate.hs new file mode 100644 index 0000000..4340cd7 --- /dev/null +++ b/src/Area/Climate.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveGeneric #-} +module Area.Climate ( + Climate(..) + ) where + +import Data.Aeson (ToJSON(..), FromJSON(..), genericToEncoding, genericParseJSON, defaultOptions) +import GHC.Generics (Generic) + +data Climate = Mild | Rain | Sand | Sun | Snow deriving (Generic) + +instance ToJSON Climate where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Climate where + parseJSON = genericParseJSON defaultOptions diff --git a/src/Area/NaturalElements.hs b/src/Area/NaturalElements.hs new file mode 100644 index 0000000..94123c3 --- /dev/null +++ b/src/Area/NaturalElements.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +module Area.NaturalElements ( + NaturalElements(..) + ) where + +import Data.Aeson (ToJSON(..), FromJSON(..), genericToEncoding, genericParseJSON, defaultOptions) +import GHC.Generics (Generic) + +data NaturalElements = NaturalElements { + name :: String + , skin :: FilePath + } deriving (Generic) + +instance ToJSON NaturalElements where + toEncoding = genericToEncoding defaultOptions +instance FromJSON NaturalElements where + parseJSON = genericParseJSON defaultOptions diff --git a/src/Area/Tile.hs b/src/Area/Tile.hs new file mode 100644 index 0000000..459e02e --- /dev/null +++ b/src/Area/Tile.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveGeneric #-} +module Area.Tile ( + Content(..) + , Terrain(..) + , Tile(..) + ) where + +import Data.Aeson (ToJSON(..), FromJSON(..), genericToEncoding, genericParseJSON, defaultOptions) +import GHC.Generics (Generic) +import Area.NaturalElements (NaturalElements) +import Area.Climate (Climate) +import qualified Character (Key) +import qualified Item (Key) +import qualified Pokemon (T) + +data Terrain = Normal | Water deriving (Generic) + +instance ToJSON Terrain where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Terrain where + parseJSON = genericParseJSON defaultOptions + +data Content = + Empty + | Item Item.Key + | Character Character.Key + | Pokemon Pokemon.T + | NaturalElements NaturalElements + deriving (Generic) + +instance ToJSON Content where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Content where + parseJSON = genericParseJSON defaultOptions + +data Tile = Tile { + terrain :: Terrain + , skin :: FilePath + , content :: Content + , climate :: Climate + } deriving (Generic) + +instance ToJSON Tile where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Tile where + parseJSON = genericParseJSON defaultOptions diff --git a/src/Automaton.hs b/src/Automaton.hs new file mode 100644 index 0000000..27f19a4 --- /dev/null +++ b/src/Automaton.hs @@ -0,0 +1,30 @@ +module Automaton ( + run + ) where + +import Control.Monad.State (get, put) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (encode) +import Data.ByteString.Lazy.Char8 (ByteString, putStrLn) +import Prelude hiding (log, putStrLn) +import Game (Game) +import Message (Connected, receive, send) +import qualified Message.Client as Client (Message(..)) +import qualified Message.Server as Server (Message(..)) + +edges :: Game -> Client.Message -> Connected Game +edges = undefined + +log :: ByteString -> Connected () +log line = + liftIO $ putStrLn line + +run :: Connected () +run = do + message <- Message.receive + game <- get + newGame <- edges game message + log $ encode newGame + put newGame + send $ Server.Update newGame + run diff --git a/src/Character.hs b/src/Character.hs new file mode 100644 index 0000000..37eeabe --- /dev/null +++ b/src/Character.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLists #-} +module Character ( + Character(..) + , Key + , dex + , stub + ) where + +import Data.Aeson (ToJSON(..), FromJSON(..), genericToEncoding, genericParseJSON, defaultOptions) +import Data.Vector (Vector) +import GHC.Generics (Generic) +import qualified Pokemon (T) +import Tool.Array (Array, malloc) + +data Character = Character { + name :: String + , skin :: FilePath + , pokemons :: Array Pokemon.T + } deriving (Generic) + +instance ToJSON Character where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Character where + parseJSON = genericParseJSON defaultOptions + +newtype Key = Key Int deriving (Generic) + +instance ToJSON Key where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Key where + parseJSON = genericParseJSON defaultOptions + +dex :: Vector Character +dex = [] + +stub :: Character +stub = Character { + name = "" + , skin = "" + , pokemons = malloc 6 + } diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 index 0000000..6d4cfbb --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,8 @@ +module Config ( + listenPort + ) where + +import Network.Wai.Handler.Warp (Port) + +listenPort :: Port +listenPort = 3000 diff --git a/src/Game.hs b/src/Game.hs new file mode 100644 index 0000000..6a51676 --- /dev/null +++ b/src/Game.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveGeneric #-} +module Game ( + Game(..) + , stub + ) where + +import Data.Aeson (ToJSON(..), FromJSON(..), genericToEncoding, genericParseJSON, defaultOptions) +import GHC.Generics (Generic) + +import Character (Character) +import qualified Character (stub) +import qualified Area (Key) + +data Position = Position { + area :: Area.Key + , x :: Int + , y :: Int + } deriving (Generic) + +instance ToJSON Position where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Position where + parseJSON = genericParseJSON defaultOptions + +data Turn = Player | Opponent deriving (Generic) + +instance ToJSON Turn where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Turn where + parseJSON = genericParseJSON defaultOptions + +data InitProcess = Name | Gender | OpponentsName deriving (Generic) + +instance ToJSON InitProcess where + toEncoding = genericToEncoding defaultOptions +instance FromJSON InitProcess where + parseJSON = genericParseJSON defaultOptions + +data State = + At Position + | Fighting { + at :: Position + , opponent :: Character + , turn :: Turn + } + | Initializing InitProcess deriving (Generic) + +instance ToJSON State where + toEncoding = genericToEncoding defaultOptions +instance FromJSON State where + parseJSON = genericParseJSON defaultOptions + +data Game = Game { + character :: Character + , state :: State + } deriving (Generic) + +instance ToJSON Game where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Game where + parseJSON = genericParseJSON defaultOptions + +stub :: Game +stub = Game { + character = Character.stub + , state = Initializing Name + } diff --git a/src/Item.hs b/src/Item.hs new file mode 100644 index 0000000..9e4b67b --- /dev/null +++ b/src/Item.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLists #-} +module Item ( + Item(..) + , Key + , Type(..) + , dex + ) where + +import Data.Aeson (ToJSON(..), FromJSON(..), genericToEncoding, genericParseJSON, defaultOptions) +import Data.Vector (Vector) +import GHC.Generics (Generic) +import qualified Pokemon (T) + +data Type = Hold | Transform (Pokemon.T -> Pokemon.T) | Special + +data Item = Item { + name :: String + , skin :: FilePath + , type_ :: Type + , inBattle :: Bool + } + +newtype Key = Key Int deriving (Generic) + +instance ToJSON Key where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Key where + parseJSON = genericParseJSON defaultOptions + +dex :: Vector Item +dex = [] diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..bb2c156 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +module Main where + +import Control.Monad.Reader (runReaderT) +import Control.Monad.State (evalStateT) +import Network.HTTP.Types.Status (badRequest400) +import Network.Wai (responseLBS) +import qualified Network.Wai.Handler.Warp as Warp (run) +import Network.Wai.Handler.WebSockets (websocketsOr) +import Network.WebSockets (ServerApp, acceptRequest, defaultConnectionOptions) +import qualified Automaton (run) +import Config (listenPort) +import qualified Game (stub) +import Message (receive, send) +import qualified Message.Client as Client (Message(..)) +import qualified Message.Server as Server (Message(..)) + +makeApp :: IO ServerApp +makeApp = + return $ \pending -> do + connection <- acceptRequest pending + putStrLn "New connection" + message <- runReaderT receive connection + game <- case message of + Client.NewGame -> do + let newGame = Game.stub + runReaderT (send (Server.Init newGame)) connection + putStrLn "New game" + return newGame + Client.Resume {Client.game} -> putStrLn "Loading game" >> return game + evalStateT (runReaderT Automaton.run connection) game + +main :: IO () +main = do + app <- makeApp + Warp.run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS + where + blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket") diff --git a/src/Message.back.hs b/src/Message.back.hs new file mode 100644 index 0000000..9840269 --- /dev/null +++ b/src/Message.back.hs @@ -0,0 +1,26 @@ +module Message ( + Connected + , receive + , send + ) where + +import Control.Monad.Reader (ReaderT, ask, lift) +import Network.WebSockets (Connection, receiveData, sendTextData) +import Data.Aeson (encode, eitherDecode') +import qualified Message.Client as Client (Message) +import qualified Message.Server as Server (Message(..)) + +type Connected a = ReaderT Connection IO a + +send :: Server.Message -> Connected () +send message = do + connection <- ask + lift $ sendTextData connection $ encode message + +receive :: Connected Client.Message +receive = do + connection <- ask + received <- lift $ receiveData connection + case eitherDecode' received of + Left message -> send (Server.Error message) >> receive + Right message -> return message diff --git a/src/Message.hs b/src/Message.hs new file mode 100644 index 0000000..0385a6c --- /dev/null +++ b/src/Message.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleContexts #-} +{- LANGUAGE MultiParamTypeClasses #-} +module Message ( + Connected + , receive + , send + ) where + +import Control.Monad.Reader (MonadReader, ReaderT, ask) +import Control.Monad.State (StateT) +import Control.Monad.IO.Class (MonadIO(..)) +import Network.WebSockets (Connection, receiveData, sendTextData) +import Data.Aeson (encode, eitherDecode') +import Game (Game) +import qualified Message.Client as Client (Message) +import qualified Message.Server as Server (Message(..)) + +type Connected a = ReaderT Connection (StateT Game IO) a + +{- +class ReaderIO t c where + f :: t a -> t c + liftIO :: (a -> IO b) -> a -> t b +-} + +send :: (MonadReader Connection t, MonadIO t) => Server.Message -> t () +send message = do + connection <- ask + liftIO $ sendTextData connection $ encode message + +receive :: (MonadReader Connection t, MonadIO t) => t Client.Message +receive = do + connection <- ask + received <- liftIO $ receiveData connection + case eitherDecode' received of + Left message -> send (Server.Error message) >> receive + Right message -> return message diff --git a/src/Message/Client.hs b/src/Message/Client.hs new file mode 100644 index 0000000..2b46902 --- /dev/null +++ b/src/Message/Client.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +module Message.Client ( + Message(..) + ) where + +import Data.Aeson (FromJSON(..), genericParseJSON, defaultOptions) +import Game (Game) +import GHC.Generics (Generic) + +data Message = + NewGame + | Resume { + game :: Game + } deriving (Generic) + +instance FromJSON Message where + parseJSON = genericParseJSON defaultOptions diff --git a/src/Message/Server.hs b/src/Message/Server.hs new file mode 100644 index 0000000..dbe57c9 --- /dev/null +++ b/src/Message/Server.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveGeneric #-} +module Message.Server ( + Message(..) + ) where + +import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions) +import Game (Game) +import GHC.Generics (Generic) + +data Message = + Init { + game :: Game + } + | Update { + game :: Game + } + | Error { + error :: String + } deriving (Generic) + +instance ToJSON Message where + toEncoding = genericToEncoding defaultOptions diff --git a/src/Pokemon.hs b/src/Pokemon.hs new file mode 100644 index 0000000..7cf681b --- /dev/null +++ b/src/Pokemon.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveGeneric #-} +{- LANGUAGE FlexibleInstances #-} +module Pokemon ( + T(..) + ) where + +import Data.Aeson (ToJSON(..), FromJSON(..), genericToEncoding, genericParseJSON, defaultOptions) +import GHC.Generics (Generic) + +import qualified Pokemon.Species as Species (Key) +import Pokemon.Status (Status) +import qualified Pokemon.Move as Move (Key) +import Tool.Array (Array) + +data Gender = M | F | NB deriving (Generic) + +instance ToJSON Gender where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Gender + +data T = T { + nick :: Maybe String + , species :: Species.Key + , gender :: Gender + , level :: Int + , status :: Status + , moves :: Array Move.Key + } deriving (Generic) + +instance ToJSON T where + toEncoding = genericToEncoding defaultOptions +instance FromJSON T where + parseJSON = genericParseJSON defaultOptions diff --git a/src/Pokemon/Move.hs b/src/Pokemon/Move.hs new file mode 100644 index 0000000..494809d --- /dev/null +++ b/src/Pokemon/Move.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLists #-} +module Pokemon.Move ( + Effect(..) + , Key + , Move(..) + , dex + ) where + +import Data.Aeson (ToJSON(..), FromJSON(..), genericToEncoding, genericParseJSON, defaultOptions) +import Data.Vector (Vector) +import GHC.Generics (Generic) +import Area.Climate (Climate) +import Pokemon.Status (Status) +import Pokemon.Type (Type(..)) +import Pokemon.Stats (Stats) +import qualified Pokemon.Stats as Stats (modify, precision) + +data Effect = + Blow { damage :: Int } + | StatusChange { changeStatus :: Status -> Maybe Status } + | StatsChange { changeStats :: Stats -> Maybe Stats } + | Flee + | Expell + | Switch + | Corner + | Climatic Climate + +data Move = Move { + name :: String + , type_ :: Type + , precision :: Int + , effects :: [Effect] + } + +newtype Key = Key Int deriving (Generic) + +instance ToJSON Key where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Key where + parseJSON = genericParseJSON defaultOptions + +dex :: Vector Move +dex = [ + Move { + name = "charge" + , type_ = Normal + , precision = 100 + , effects = [ Blow { damage = 30 } ] + } + , Move { + name = "mimi-queue" + , type_ = Normal + , precision = 80 + , effects = [ StatsChange { changeStats = Stats.modify Stats.precision (\x -> x-10) 30 } ] + } + ] diff --git a/src/Pokemon/Species.hs b/src/Pokemon/Species.hs new file mode 100644 index 0000000..47c2c02 --- /dev/null +++ b/src/Pokemon/Species.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveGeneric #-} +module Pokemon.Species ( + Key + , Species(..) + ) where + +import Data.Aeson (ToJSON(..), FromJSON(..), genericToEncoding, genericParseJSON, defaultOptions) +import GHC.Generics (Generic) + +import Pokemon.Type (Type) +import Pokemon.Move (Move) +import Data.Map (Map) + +data Species = Species { + name :: String + , number :: Int + , type_ :: Type + , skin :: FilePath + , moves :: Map Int Move + } + +newtype Key = Key Int deriving (Generic) + +instance ToJSON Key where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Key where + parseJSON = genericParseJSON defaultOptions diff --git a/src/Pokemon/Stats.hs b/src/Pokemon/Stats.hs new file mode 100644 index 0000000..e509628 --- /dev/null +++ b/src/Pokemon/Stats.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedLists #-} +module Pokemon.Stats ( + Proto(..) + , Stat + , Stats + , attack + , defense + , speed + , precision + , specialAttack + , specialDefense + , index + , get + , modify + ) where + +import Data.Vector (Vector, (!), (//)) + +newtype Stat = Stat Int + +attack :: Stat +attack = Stat 0 + +defense :: Stat +defense = Stat 1 + +speed :: Stat +speed = Stat 2 + +precision :: Stat +precision = Stat 3 + +specialAttack :: Stat +specialAttack = Stat 4 + +specialDefense :: Stat +specialDefense = Stat 5 + +data Proto = Proto { + attack_ :: Int + , defense_ :: Int + , speed_ :: Int + , precision_ :: Int + , specialAttack_ :: Int + , specialDefense_ :: Int + } + +newtype Stats = Stats (Vector Int) + +index :: Proto -> Stats +index proto = Stats [ + (attack_ proto) + , (defense_ proto) + , (speed_ proto) + , (precision_ proto) + , (specialAttack_ proto) + , (specialDefense_ proto) + ] + +get :: Stats -> Stat -> Int +get (Stats v) (Stat s) = v ! s + +modify :: Stat -> (Int -> Int) -> Int -> Stats -> Maybe Stats +modify stat@(Stat s) f threshold stats@(Stats v) = + let result = f $ stats `get` stat in + if result < threshold + then Nothing + else Just . Stats $ v // [(s, result)] diff --git a/src/Pokemon/Status.hs b/src/Pokemon/Status.hs new file mode 100644 index 0000000..b3895f8 --- /dev/null +++ b/src/Pokemon/Status.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveGeneric #-} +module Pokemon.Status ( + Status(..) + ) where + +import Data.Aeson (ToJSON(..), FromJSON(..), genericToEncoding, genericParseJSON, defaultOptions) +import GHC.Generics (Generic) + +data Status = Normal | Sleeping | Frozen | Poisoned | Burning | Confused | InLove deriving (Generic) + +instance ToJSON Status where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Status where + parseJSON = genericParseJSON defaultOptions diff --git a/src/Pokemon/Type.hs b/src/Pokemon/Type.hs new file mode 100644 index 0000000..8bebcf8 --- /dev/null +++ b/src/Pokemon/Type.hs @@ -0,0 +1,5 @@ +module Pokemon.Type ( + Type(..) + ) where + +data Type = Water | Fire | Eletric | Plant | Rock | Ground | Psy | Ice | Fly | Normal | Ghost diff --git a/src/Tool/Array.hs b/src/Tool/Array.hs new file mode 100644 index 0000000..89761a2 --- /dev/null +++ b/src/Tool/Array.hs @@ -0,0 +1,23 @@ +module Tool.Array ( + Array + , (!) + , clear + , malloc + ) where + +import Data.Vector (Vector, (!?), (//)) +import qualified Data.Vector as Vector (replicate) + +type Array a = Vector (Maybe a) + +(!) :: Array a -> Int -> Maybe a +t ! k = + case t !? k of + Nothing -> Nothing + Just a -> a + +clear :: Array a -> Int -> Array a +clear t k = t // [(k, Nothing)] + +malloc :: Int -> Array a +malloc size = Vector.replicate size Nothing