Battleship domain model

.gitignore

.stack-work

README.md

Battleship domain model

$ stack setup && stack build
$ stack exec battleship

battleship.cabal

name:                battleship
version:             0.1.0.0
synopsis:            Simple project template from stack
description:         Please see README.md
homepage:            https://github.com/jaseemabid/battleship#readme
license:             BSD3
license-file:        LICENSE
author:              Jaseem Abid
maintainer:          jaseemabid@gmail.com
copyright:           2016 Jaseem Abid
category:            Web
build-type:          Simple
cabal-version:       >=1.10

executable battleship
  hs-source-dirs:      .
  main-is:             Main.hs
  default-language:    Haskell2010
  build-depends:       base >= 4.7 && < 5
                     , data-default
                     , random

LICENSE

Copyright Jaseem Abid (c) 2016

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 Jaseem Abid 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.

Main.hs

{-# LANGUAGE FlexibleInstances #-}

-- Improvements and TODOs
-- 1. Run could be cleaned up with a State + Either monad transformer
-- 2. There must be a nicer way to define `Board` and avoid boilerplate

module Main where

import Data.Default
import Data.Maybe
import System.Random

data Ship = Carrier | Battleship | Submarine | Cruiser | Patrol
  deriving (Show, Enum)

data X = One | Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten
    deriving (Show, Eq, Ord, Enum, Bounded)

data Y = A | B | C | D | E | F | G | H | I | J
    deriving (Show, Eq, Ord, Enum, Bounded)

data Point = Point X Y
data Position = Position Point Point -- Start and end

-- Specific ships instead of an array encodes more information statically, Ie
-- user cannot have 6 or 4 ships. Makes checking for a hit/miss more
-- complicated, but it doesnt matter at this scale.
data Board = Board
  { carrier :: Maybe Position
  , battleship :: Maybe Position
  , submarine :: Maybe Position
  , cruiser :: Maybe Position
  , patrol :: Maybe Position }

data Attack = Hit | Miss | Unknown
type Attacks = [[Attack]]

-- Player knows about his ships, his attacks and opponent's attacks
data Player = Player Board Attacks

data Game = Game Player Player

---
--- Instances
---

instance Default Board where
    def = Board { carrier = Nothing
                , battleship = Nothing
                , submarine = Nothing
                , cruiser = Nothing
                , patrol = Nothing }

instance Default Player where
    def = Player (def :: Board) $ replicate 10 $ replicate 10 Unknown

instance Default Game where
    def = Game (def :: Player) (def :: Player)

instance Bounded Point where
    minBound = Point minBound minBound
    maxBound = Point maxBound maxBound

instance Random Point where
  randomR (Point x1 y1, Point x2 y2) g = (Point (toEnum x) (toEnum y), g2)
      where
        (x, g1) = randomR (fromEnum x1, fromEnum x2) g
        (y, g2) = randomR (fromEnum y1, fromEnum y2) g1

  random = randomR (minBound, maxBound)

instance Show Point where
    show (Point x y) = concat ["(", show x, ",", show y, ")"]

instance Show Position where
    -- Example: (4,4) -> (4,4)
    show (Position head tail) = concat [show head, " -> ", show tail]

instance Show Attack where
    show Hit = "❌"
    show Miss = "✓"
    show Unknown = "."

instance Show Board where
    show board = concat [
        "\nCarrier     : ",
        show $ carrier board,
        "\nBattle Ship : ",
        show $ battleship board,
        "\nSub         : ",
        show $ submarine board,
        "\nCruiser     : ",
        show $ cruiser board,
        "\nPatrol      : ",
        show $ patrol board]

instance Show Player where
    show (Player board attacks)
      = concat [show board,
                "\n\nAttacks : \n",
                unlines $ map (concatMap show) attacks]

---
--- Functions
---

-- Insert a ship into a board after all validations
insert :: Board -> Ship -> Position -> Either String Board
insert board ship pos@(Position (Point x1 y1) (Point x2 y2)) =
  case valid of
    Nothing -> Right $ insert' ship
    Just err -> Left err

  where
    valid = listToMaybe $ catMaybes [sizep, overflowp, overlappp]

    -- Ensure size of ship is equal to length of vector
    sizep = if len pos /= size ship
            then Just $ "Size mismatch for " ++ show ship
            else Nothing

    -- Ensure position wont overflow
    overflowp = if any (> maxBound) [x1, x2] || any (> maxBound) [y1, y2]
                then Just $ "Overflow on " ++ show pos
                else Nothing

    -- Ensure there are no overlaps
    overlappp = if any (overlap pos) $ ships board
                then Just $ "Overlapping ships " ++ (show . ships $ board)
                else Nothing

    -- TODO: Get rid of this boilerplate. There has to be a way
    insert' Carrier = board {carrier = Just pos}
    insert' Battleship = board {battleship = Just pos}
    insert' Submarine = board {submarine = Just pos}
    insert' Cruiser = board {cruiser = Just pos}
    insert' Patrol = board {patrol = Just pos}

ships :: Board -> [Position]
ships b = map fromJust $ filter isJust ships'
  where
    ships' = [carrier b, battleship b, submarine b, cruiser b, patrol b]

size :: Ship -> Int
size ship = 5 - fromEnum ship

len :: Position -> Int
len p@(Position (Point x1 y1) (Point x2 y2))
  | x1 == x2 = fromEnum y2 - fromEnum y1 + 1
  | y1 == y2 = fromEnum x2 - fromEnum x1 + 1
  | otherwise = error $ "Tilted vector " ++ show p

overlap :: Position -> Position -> Bool
overlap (Position (Point ahx ahy) (Point atx aty))
  (Position (Point bhx bhy) (Point btx bty)) =
    -- Invariant: ahx == atx, bhy == bty
    (between bhx btx ahx && between ahy aty bhy) ||
    (between ahx atx bhx && between bhy bty ahy)
  where
    -- Check if x is b/w a and b
    between a b x = min a b <= x && max a b >= x

-- Max bound starting point for ship
-- Ex: Battleship => (Seven,G)
maxPoint :: Ship -> Point
maxPoint ship = Point (toEnum limit) (toEnum limit)
  where
    limit = 10 - size ship

-- Try to insert a ship into the board, this might take a while!
try :: StdGen -> Ship -> Board -> Board
try g ship board = case insert board ship pos of
    Right board' -> board'
    Left err -> try g' ship board

  where
    -- Pick an orientation for the ship
    (flip, g'') = random g :: (Bool, StdGen)

    -- Pick a start point
    (start@(Point x y), g') = randomR (Point One A, maxPoint ship) g

    -- Compute end point from start point and orientation
    end = if flip
          then Point x (inc y $ size ship)
          else Point (inc x $ size ship) y

    pos = Position start end

    -- Increment X or Y count times
    inc x count = last $ take count $ iterate succ x

--- *** ---

run :: StdGen -> Either String Board
run g = do

    -- Task 1: Create an empty board.
    let b0 = def :: Board

    -- Task 2: Place a ship on the board.
    b1 <- insert b0 Carrier $ Position (Point Two A) (Point Two E)
    b2 <- insert b1 Carrier $ Position (Point Three A) (Point Three E)

    -- Task 3: Create a random board with the ships already placed.
    return $ foldr (try g) b0 [Carrier .. Patrol]

-- https://github.com/commercialhaskell/intero/issues/114
-- Weird bug, unable to run main function from intero REPL
main :: IO ()
main = do
    g <- getStdGen
    print (run g)

Setup.hs

import Distribution.Simple
main = defaultMain

stack.yaml

resolver: lts-7.5