Learning Haskell - can you critique this code?

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
/r/haskellquestions Thread