----------------------------------------------------------------------------
-- |
-- Module : Logic.Types
-- Stability : experimental
-- Portability : semi-portable
--
-- Data structures and type classes of the battleships implementation.
--
module Logic.Types
(
-- * Typeclasses
AI (..)
, HasShipShape (..)
-- * Datatypes
, Action (..)
, GameState (..)
, DifficultyLevel (..)
, HitResponse (..)
, Movement (..)
, Orientation (..)
, Time (..)
, Player (..)
, PlayerState (..)
, Options (..)
, Rules (..)
, Ship (..)
, ShipShape (..)
, ShipMove (..)
, Shot (..)
, Turn (..)
-- * Type Synonyms
, Fleet
, FleetPlacement
, Grid
, Pos
, ShipID
, TrackingList
-- * Smart Constructors
, newGrid
-- * Serialization Helpers
, getPos
, getSmallGrid
, putPos
, putSmallGrid
) where
import Prelude
import Control.Applicative
import Control.Monad
import Control.Monad.Random
import Control.Monad.State.Class (MonadState)
import Data.Aeson hiding (Array, encode, decode)
import Data.Array
import Data.Bits
import Data.Function (on)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Serialize (Serialize (..), encode, decode)
import Data.Serialize.Get
import Data.Serialize.Put
import Data.Word
import Logic.Binary
import Yesod (PathPiece (..))
-------------------------------------------------------------------------------
-- * AI
-------------------------------------------------------------------------------
-- | Operations an artificial intelligence has to provide for playing this game.
class AI a where
-- | Initial state and fleet position
aiInit
:: MonadRandom m
=> Rules -- ^ game rules
-> m (a, FleetPlacement) -- ^ initial state
-- | Computes the next shot based on the current AI state
aiFire
:: (MonadRandom m, MonadState a m)
=> m Pos
-- | Feedback to `aiFire`
aiResponse
:: (MonadRandom m, MonadState a m)
=> Pos -- ^ target position
-> HitResponse -- ^ result of the last shot
-> m ()
-- | Computes the ship movement
aiMove
:: (MonadRandom m, MonadState a m)
=> Fleet -- ^ AI's fleet including IDs
-> TrackingList -- ^ enemy shots
-> m (Maybe (ShipID, Movement)) -- ^ ship and movement, if any
aiMove _ _ = return Nothing
-------------------------------------------------------------------------------
-- * Game State
-------------------------------------------------------------------------------
data Options = Options
{ againWhenHit :: Bool
, move :: Bool
, noviceMode :: Bool
, devMode :: Bool
, difficulty :: DifficultyLevel
} deriving (Show, Eq, Read)
data Rules = Rules
{ rulesAgainWhenHit :: Bool
, rulesMove :: Bool
, rulesDifficulty :: DifficultyLevel
, rulesMaximumTurns :: Int
, rulesCountdownTurns :: Int
}
-- | Playing strength of the AI.
data DifficultyLevel
= Easy
| Medium
| Hard
deriving (Enum, Eq, Show, Read)
-- | Reponse sent to the AI after a shot.
data HitResponse
= Water -- ^ the shot hit the water
| Hit -- ^ the shot hit a ship
| Sunk -- ^ the shot hit the last intact part of a ship
deriving (Eq, Enum)
data Orientation
= Horizontal
| Vertical
deriving (Enum, Bounded)
-- | Represents the last time (turn number) that an event happened,
-- if any, especially a ship hit in the Ship data type.
newtype Time = Time { unwrapTime :: Maybe Int }
-- | Maximum monoid.
-- Useful because we often want to know when the last time
-- was that something happened. (last -> maximum)
instance Monoid Time where
mempty = Time Nothing
mappend (Time Nothing) t = t
mappend (Time (Just t1)) t = Time . Just $ case t of { Time Nothing -> t1 ; Time (Just t2) -> max t1 t2 }
-- | Encodes a ships state using position, size and orientation
data ShipShape = ShipShape
{ shipPosition :: Pos
, shipSize :: Int
, shipOrientation :: Orientation
}
-- | A ship with unique id, a shape and current damage.
data Ship = Ship
{ shipID :: ShipID -- ^ unique ID of ship
, shipShape :: ShipShape -- ^ shape of ship (including position, orientation and size)
, shipDamage :: Array Int Time -- ^ damage at each position
}
instance Eq Ship where
(==) = (==) `on` shipID
-- | Used to allow lookup functions to work with both FleetPlacement and Fleet
class HasShipShape a where
getShipShape :: a -> ShipShape
instance HasShipShape Ship where
getShipShape = shipShape
instance HasShipShape ShipShape where
getShipShape = id
-- | State of the game for both players.
data GameState a = GameState
{ currentPlayer :: PlayerState -- ^ the current player's state
, otherPlayer :: PlayerState -- ^ the other player's state
, aiState :: a -- ^ state of the AI
, gameRules :: Rules
, noviceModeOpt :: Bool
, devModeOpt :: Bool
, expectedAction :: Action
, turnNumber :: Int
}
-- | The state belonging to one player
data PlayerState = PlayerState
{ playerShots :: TrackingList -- ^ the player's shots
, playerFleet :: Fleet -- ^ the player's fleet
, playerType :: Player
, playerMoves :: [ShipMove] -- ^ the player's moves
} deriving Eq
-- | type to distinguish between human and AI player
data Player
= HumanPlayer
| AIPlayer
deriving (Eq, Enum)
-- | the next action expected from the human player
data Action
= ActionFire
| ActionMove
deriving (Eq, Enum)
-- | keeps track of all relevant information for a fired shot
data Shot = Shot
{ shotPos :: Pos
, shotResult :: HitResponse
, shotTime :: Int
} deriving Eq
-- | a ship movement
data ShipMove = ShipMove
{ shipMoveID :: ShipID
, shipMoveDirection :: Movement
, shipMoveTime :: Int
} deriving (Eq, Show)
-- | A fleet is a map of ship ID's to ships
type Fleet = Map.Map ShipID Ship
-- | A fleet placement is a list of the ship shapes
type FleetPlacement = [ShipShape]
-- | A two-dimensional position stored with zero-based indices
type Pos = (Int,Int)
-- | A grid is an array indexed by positions with zero-based indices
type Grid a = Array Pos a
-- | A list of all shots. Easier to handle, because no index lookup is needed.
type TrackingList = [Shot]
-- | Used for identifying a ship.
type ShipID = Int
-- | Result of the turn with respect to the current player
data Turn = Over | Again | Next deriving Eq
-- | A ships movement
data Movement
= Forward -- ^ -1 for the respective coordinate
| Backward -- ^ +1 for the respective coordinate
deriving (Eq, Enum, Bounded, Show)
-------------------------------------------------------------------------------
-- * Smart Constructors
-------------------------------------------------------------------------------
-- | Creates a grid, filled with one value.
newGrid :: (Int, Int) -> a -> Grid a
newGrid (w, h) a
= array ((0, 0), (w - 1, h - 1))
[((x, y), a) | x <- [0 .. w - 1], y <- [0 .. h - 1]]
-------------------------------------------------------------------------------
-- * Random
-------------------------------------------------------------------------------
instance Random Orientation where
randomR (a, b) g = (toEnum r, g') where
(r, g') = randomR (fromEnum a, fromEnum b) g
random = randomR (minBound, maxBound)
instance Random Movement where
randomR (a, b) g = (toEnum r, g') where
(r, g') = randomR (fromEnum a, fromEnum b) g
random = randomR (minBound, maxBound)
-------------------------------------------------------------------------------
-- * JSON
-------------------------------------------------------------------------------
instance FromJSON ShipShape where
parseJSON (Object v) = curry ShipShape <$>
v .: "X" <*>
v .: "Y" <*>
v .: "Size" <*>
v .: "Orientation"
-- A non-Object value is of the wrong type, so fail.
parseJSON _ = mzero
instance FromJSON Orientation where
parseJSON (Number n) = return $ toEnum $ floor n
parseJSON _ = mzero
instance ToJSON Orientation where
toJSON = Number . fromIntegral . fromEnum
instance ToJSON ShipShape where
toJSON (ShipShape {..}) = object
[ "X" .= fst shipPosition
, "Y" .= snd shipPosition
, "Size" .= shipSize
, "Orientation" .= shipOrientation
]
-------------------------------------------------------------------------------
-- * Path Pieces
-------------------------------------------------------------------------------
instance PathPiece Options where
fromPathPiece = impBinary >=> eitherToMaybe . decode . toStrict
toPathPiece = expBinary . fromStrict . encode
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe e = case e of
Right x -> Just x
_ -> Nothing
-------------------------------------------------------------------------------
-- * Serialization
-------------------------------------------------------------------------------
instance Serialize a => Serialize (GameState a) where
get = GameState <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> getIntegral8
put GameState {..} = do
put currentPlayer
put otherPlayer
put aiState
put gameRules
put noviceModeOpt
put devModeOpt
put expectedAction
putIntegral8 turnNumber
instance Serialize PlayerState where
get = PlayerState <$> getList8 get <*> get <*> get <*> get
put PlayerState{..} = do
putList8 put playerShots
put playerFleet
put playerType
put playerMoves
instance Serialize Options where
get = Options <$> get <*> get <*> get <*> get <*> get
put Options {..} = do
put againWhenHit
put move
put noviceMode
put devMode
put difficulty
instance Serialize Rules where
get = Rules <$> get <*> get <*> get <*> getIntegral8 <*> getIntegral8
put Rules {..} = do
put rulesAgainWhenHit
put rulesMove
put rulesDifficulty
putIntegral8 rulesMaximumTurns
putIntegral8 rulesCountdownTurns
instance Serialize DifficultyLevel where
get = getEnum8
put = putEnum8
instance Serialize HitResponse where
get = getEnum8
put = putEnum8
instance Serialize Orientation where
get = getEnum8
put = putEnum8
instance Serialize Player where
get = getEnum8
put = putEnum8
instance Serialize Action where
get = getEnum8
put = putEnum8
instance Serialize Movement where
get = getEnum8
put = putEnum8
instance Serialize ShipShape where
get = ShipShape <$> getPos <*> getIntegral8 <*> get
put ShipShape{..} = do
putPos shipPosition
putIntegral8 shipSize
put shipOrientation
instance Serialize Time where
get = mkTime <$> getIntegral8 where
mkTime 0xFF = Time Nothing
mkTime i = Time $ Just i
put (Time t) = putIntegral8 $ fromMaybe 0xFF t
instance Serialize Ship where
get = Ship <$> getIntegral8 <*> get <*> get
put Ship{..} = do
putIntegral8 shipID
put shipShape
put shipDamage
instance Serialize Shot where
get = Shot <$> getPos <*> get <*> getIntegral8
put Shot{..} = do
putPos shotPos
put shotResult
putIntegral8 shotTime
instance Serialize ShipMove where
get = ShipMove <$> getIntegral8 <*> get <*> getIntegral8
put ShipMove{..} = do
putIntegral8 shipMoveID
put shipMoveDirection
putIntegral8 shipMoveTime
-------------------------------------------------------------------------------
-- * Specific Serialization Helpers
-------------------------------------------------------------------------------
putPos :: Putter Pos
putPos (x,y) = put (hi .|. lo :: Word8) where
hi = (fromIntegral x .&. 0x0F) `shiftL` 4
lo = fromIntegral y .&. 0x0F
getPos :: Get Pos
getPos = fromB <$> getWord8 where
fromB b = ( fromIntegral $ b `shiftR` 4
, fromIntegral $ b .&. 0x0F )
putSmallGrid :: Putter a -> Putter (Grid a)
putSmallGrid pel grid = do
let (_, upper) = bounds grid
putPos upper
mapM_ pel (elems grid)
getSmallGrid :: Get a -> Get (Grid a)
getSmallGrid gel = do
upper <- getPos
let count = rangeSize ((0,0), upper)
xs <- replicateM count gel
return $ listArray ((0,0), upper) xs