Your post inspired me to write my own Battleship game. I had some fun while doing it, too. I don't really have any critiques for your code, but it might be nice for you to have something for comparison.
In case you're interested, I developed this from the bottom-up -- approximately, the reverse order of the sections below. I specifically avoided monads because (1) I don't really like them and (2) it turns I didn't really need them. Applicative FTW.
All it needs is some GUI and an AI. I might be open to collaborating further.
Anyway, enjoy:
LICENSE: maximally permissive, no attribution required. Please comment.
module Battleship (
Game,Ship,Player,ShipType,Orientation
, Board,Boards,Coord,Rectangle,ShipSpec
, initGame,startGame,endGame
, gameOver,winner
, places,removes,strikes
) where
import Control.Applicative ((<$>),(<*>))
-- For tuples: fst and snd are getters, first and second are setters
import Data.Bifunctor (first,second)
-- ======================================================
-- Types and Constants
-- ==================
data GameStage = Init | Playing | GameOver deriving (Show,Eq,Ord)
data Game = Game
{ activePlayer :: Player
, boards :: Boards
, stage :: GameStage
} deriving Show
data Ship = Ship
{ shipType :: ShipType
, shipRectangle :: Rectangle
, damage :: Damage
} deriving Show
data Player = Player1 | Player2 deriving (Show,Eq)
-- Patrol | Destroyer | Submarine | Battleship | Carrier
data ShipType = P | D | S | B | C deriving (Show,Eq)
data Orientation = H | V deriving Show
type Board = [Ship]
type Boards = (Board,Board)
type Effect a = a -> a
type ShipSpec = ((ShipType,Orientation),Coord)
type Damage = [Coord]
type Coord = (Int,Int)
type Rectangle = (Coord,Coord)
type Test a = a -> Bool
type Alter a = a -> Maybe a
gameRectangle :: Rectangle
gameRectangle = ((1,1) , (10,10))
extraLen :: ShipType -> Int
extraLen P = 1
extraLen D = 2
extraLen S = 2
extraLen B = 3
extraLen C = 4
opposing Player1 = Player2
opposing Player2 = Player1
-- ======================================================
-- Status and API
-- ==================
initGame :: Game
initGame = Game Player1 ([],[]) Init
-- the game won't start with a winner
startGame :: Effect Game
startGame game
| existsWinner game = game
| otherwise = game{ stage = Playing }
endGame :: Effect Game
endGame game = game{ stage = GameOver }
gameOver :: Test Game
gameOver = stageIs GameOver
-- Player1 wins if both are empty :)
winner :: Game -> Maybe Player
winner game = case boards game of
(_,[]) -> Just Player1
([],_) -> Just Player2
_ -> Nothing
places :: Player -> ShipSpec -> Effect Game
player `places` spec = inGame . butOnlyIf (stageIs Init)
$ player `affectedBy` shipPlacement spec
removes :: Player -> Coord -> Effect Game
player `removes` coord = inGame . butOnlyIf (stageIs Init)
$ player `affectedBy` shipRemoval coord
strikes :: Player -> Coord -> Effect Game
player `strikes` coord = gameReactsToStrike player
$ inGame . butOnlyIf
((&&) <$> stageIs Playing
<*> activePlayerIs player)
$ opposing player `affectedBy` strike coord
-- ======================================================
-- Game
-- ==================
inGame :: (Game -> Effect Boards) -> Effect Game
f `inGame` game = game{boards = f <*> boards $ game}
-- Effect (Effect Game) ...
gameReactsToStrike :: Player -> Effect Game -> Effect Game
gameReactsToStrike p s g = let game = s g in
if Init < stage game && existsWinner game
then game{ stage = GameOver }
else game{ activePlayer = opposing p }
existsWinner :: Game -> Bool
existsWinner game = Nothing /= winner game
-- effect guard -- always vigilant
butOnlyIf :: Test a -> Effect b -> (a -> Effect b)
butOnlyIf pred effect game = if pred game then effect else id
activePlayerIs :: Player -> Game -> Bool
activePlayerIs player game = player == activePlayer game
stageIs :: GameStage -> Game -> Bool
stageIs s game = s == stage game
-- ======================================================
-- Player
-- ==================
affectedBy :: Player -> Effect Board -> Effect Boards
Player1 `affectedBy` effect = first effect
Player2 `affectedBy` effect = second effect
-- ======================================================
-- Board
-- ==================
inbounds :: Rectangle -> Bool
inbounds = not.disjoint gameRectangle
shipPlacement :: ShipSpec -> Effect Board
shipPlacement s' ss
| s `fits` ss = s : ss
| otherwise = ss
where s = buildShip s'
shipRemoval :: Coord -> Effect Board
shipRemoval = deleteFirst . within
fits :: Ship -> Board -> Bool
s' `fits` ss' = let s = shipRectangle s'
ss = shipRectangle <$> ss'
in inbounds s
&& disjoint s `all` ss
-- ======================================================
-- Battle
-- ==================
criticalStrike :: Coord -> Effect Board
criticalStrike = shipRemoval
strike :: Coord -> Effect Board
strike = alterFirst <$> within <*> wreck
within :: Coord -> Test Ship
c `within` s = shipRectangle s `contains` c
wreck :: Coord -> Alter Ship
wreck c s = let d = c : damage s in
if d `sinks` s
then Nothing
else Just s{damage = d}
sinks :: Damage -> Ship -> Bool
d `sinks` s = length d >= (shipSize.shipType) s
-- ======================================================
-- Ship
-- ==================
shipSize :: ShipType -> Int
shipSize t = 1 + extraLen t
calcShip :: ShipSpec -> Rectangle
calcShip = uncurry.uncurry $ segment.extraLen
buildShip :: ShipSpec -> Ship
buildShip = Ship <$> fst.fst <*> calcShip <*> const []
-- ======================================================
-- Geometry
-- ==================
contains :: Rectangle -> Coord -> Bool
(x,x') `contains` c = x <= c && c <= x'
disjoint :: Rectangle -> Rectangle -> Bool
disjoint (x,x') (y,y') = x > y' || y > x'
segment :: Int -> Orientation -> Coord -> Rectangle
segment e H = (,) <$> id <*> second (+e)
segment e V = (,) <$> id <*> first (+e)
-- ======================================================
-- Utility
-- ==================
alterFirst :: Test a -> Alter a -> [a] -> [a]
alterFirst pred f (x:xs) =
if pred x
then case f x of
Just y -> y : xs -- modify
_ -> xs -- delete
else x : alterFirst pred f xs -- next
alterFirst _ _ _ = [] -- end
deleteFirst :: Test a -> [a] -> [a]
deleteFirst = flip alterFirst $ const Nothing