{- |
Enumerate all possible configurations in the Battleship game.
-}
module Combinatorics.Battleship.Enumeration where

import Combinatorics.Battleship
         (Fleet, ShipSize, Orientation(..), Ship(Ship), Board(Board), )
import Combinatorics (tuples)

import Data.Map (Map, )
import Data.Set (Set, )
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Control.Monad.Trans.State as MS
import qualified Control.Monad.Trans.Class as MT
import Control.Monad (liftM2, guard, when, )
import Data.List.HT (tails, )
import Data.Bool.HT (if', )

import qualified System.IO as IO


insertShip :: Ship -> Board -> Board
insertShip :: Ship -> Board -> Board
insertShip Ship
ship (Board (Int, Int)
bnds Set (Int, Int)
set) =
   (Int, Int) -> Set (Int, Int) -> Board
Board (Int, Int)
bnds (Set (Int, Int) -> Board) -> Set (Int, Int) -> Board
forall a b. (a -> b) -> a -> b
$ Set (Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (Int, Int)
set (Set (Int, Int) -> Set (Int, Int))
-> Set (Int, Int) -> Set (Int, Int)
forall a b. (a -> b) -> a -> b
$ Ship -> Set (Int, Int)
shipArea Ship
ship

shipArea :: Ship -> Set (Int, Int)
shipArea :: Ship -> Set (Int, Int)
shipArea (Ship Int
size Orientation
orient (Int
x,Int
y)) =
   [(Int, Int)] -> Set (Int, Int)
forall a. Eq a => [a] -> Set a
Set.fromAscList ([(Int, Int)] -> Set (Int, Int)) -> [(Int, Int)] -> Set (Int, Int)
forall a b. (a -> b) -> a -> b
$
      case Orientation
orient of
         Orientation
Horizontal -> (Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int -> (Int, Int)) -> Int -> Int -> (Int, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) Int
y) [Int
x .. Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
         Orientation
Vertical -> (Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) Int
x) [Int
y .. Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]

reduceSpace :: Ship -> Board -> Board
reduceSpace :: Ship -> Board -> Board
reduceSpace Ship
ship (Board (Int, Int)
bnds Set (Int, Int)
set) =
   (Int, Int) -> Set (Int, Int) -> Board
Board (Int, Int)
bnds (Set (Int, Int) -> Board) -> Set (Int, Int) -> Board
forall a b. (a -> b) -> a -> b
$
   Set (Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set (Int, Int)
set (Set (Int, Int) -> Set (Int, Int))
-> Set (Int, Int) -> Set (Int, Int)
forall a b. (a -> b) -> a -> b
$
   Ship -> Set (Int, Int)
shipOutline Ship
ship

shipOutline :: Ship -> Set (Int, Int)
shipOutline :: Ship -> Set (Int, Int)
shipOutline (Ship Int
size Orientation
orient (Int
x,Int
y)) =
   [(Int, Int)] -> Set (Int, Int)
forall a. Eq a => [a] -> Set a
Set.fromAscList ([(Int, Int)] -> Set (Int, Int)) -> [(Int, Int)] -> Set (Int, Int)
forall a b. (a -> b) -> a -> b
$
      case Orientation
orient of
         Orientation
Horizontal -> (Int -> Int -> (Int, Int)) -> [Int] -> [Int] -> [(Int, Int)]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) [Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 .. Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
size] [Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 .. Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1]
         Orientation
Vertical -> (Int -> Int -> (Int, Int)) -> [Int] -> [Int] -> [(Int, Int)]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) [Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 .. Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1] [Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 .. Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
size]


data Box = Box (Int, Int) (Int, Int)

shipBounds :: Ship -> Box
shipBounds :: Ship -> Box
shipBounds (Ship Int
size Orientation
orient (Int
x,Int
y)) =
   case Orientation
orient of
      Orientation
Horizontal -> (Int, Int) -> (Int, Int) -> Box
Box (Int
x,Int
y) (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, Int
y)
      Orientation
Vertical -> (Int, Int) -> (Int, Int) -> Box
Box (Int
x,Int
y) (Int
x, Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

moveShip :: (Int, Int) -> Ship -> Ship
moveShip :: (Int, Int) -> Ship -> Ship
moveShip (Int
dx,Int
dy) (Ship Int
size Orientation
orient (Int
x,Int
y)) =
   Int -> Orientation -> (Int, Int) -> Ship
Ship Int
size Orientation
orient (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
dx, Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
dy)

{- |
Bounding box around two boxes.
-}
mergeBox :: Box -> Box -> Box
mergeBox :: Box -> Box -> Box
mergeBox (Box (Int
a0x,Int
a0y) (Int
a1x,Int
a1y)) (Box (Int
b0x,Int
b0y) (Int
b1x,Int
b1y)) =
   (Int, Int) -> (Int, Int) -> Box
Box (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
a0x Int
b0x, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
a0y Int
b0y) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
a1x Int
b1x, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
a1y Int
b1y)

{- |
Intersection of two boxes.
If the intersection is empty,
then the box will have left and right boundaries
or upper and lower boundaries in swapped order.
-}
intersectBox :: Box -> Box -> Box
intersectBox :: Box -> Box -> Box
intersectBox (Box (Int
a0x,Int
a0y) (Int
a1x,Int
a1y)) (Box (Int
b0x,Int
b0y) (Int
b1x,Int
b1y)) =
   (Int, Int) -> (Int, Int) -> Box
Box (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
a0x Int
b0x, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
a0y Int
b0y) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
a1x Int
b1x, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
a1y Int
b1y)

boxSizes :: Box -> (Int, Int)
boxSizes :: Box -> (Int, Int)
boxSizes (Box (Int
a0x,Int
a0y) (Int
a1x,Int
a1y)) = (Int
a1x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a0x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
a1y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a0y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)


emptyBoard :: (Int, Int) -> Board
emptyBoard :: (Int, Int) -> Board
emptyBoard (Int, Int)
bnds = (Int, Int) -> Set (Int, Int) -> Board
Board (Int, Int)
bnds Set (Int, Int)
forall a. Set a
Set.empty

fullBoard :: (Int, Int) -> Board
fullBoard :: (Int, Int) -> Board
fullBoard bnds :: (Int, Int)
bnds@(Int
width,Int
height) =
   (Int, Int) -> Set (Int, Int) -> Board
Board (Int, Int)
bnds (Set (Int, Int) -> Board) -> Set (Int, Int) -> Board
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> Set (Int, Int)
forall a. Eq a => [a] -> Set a
Set.fromAscList ([(Int, Int)] -> Set (Int, Int)) -> [(Int, Int)] -> Set (Int, Int)
forall a b. (a -> b) -> a -> b
$
   (Int -> Int -> (Int, Int)) -> [Int] -> [Int] -> [(Int, Int)]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) [Int
0 .. Int
widthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] [Int
0 .. Int
heightInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]

boardFromShips :: (Int, Int) -> [Ship] -> Board
boardFromShips :: (Int, Int) -> [Ship] -> Board
boardFromShips (Int, Int)
bnds =
   (Board -> Ship -> Board) -> Board -> [Ship] -> Board
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Ship -> Board -> Board) -> Board -> Ship -> Board
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ship -> Board -> Board
insertShip) ((Int, Int) -> Board
emptyBoard (Int, Int)
bnds)

formatBoard :: Board -> String
formatBoard :: Board -> String
formatBoard (Board (Int
width,Int
height) Set (Int, Int)
set) =
   [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
   (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
      (\Int
y ->
         (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map
            (\Int
x -> if (Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Int
x,Int
y) Set (Int, Int)
set then Char
'x' else Char
'.')
            [Int
0 .. Int
widthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1])
      [Int
0 .. Int
heightInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]

charmapFromShip :: Ship -> Map (Int, Int) Char
charmapFromShip :: Ship -> Map (Int, Int) Char
charmapFromShip (Ship Int
size Orientation
orient (Int
x,Int
y)) =
   [((Int, Int), Char)] -> Map (Int, Int) Char
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList ([((Int, Int), Char)] -> Map (Int, Int) Char)
-> [((Int, Int), Char)] -> Map (Int, Int) Char
forall a b. (a -> b) -> a -> b
$
      case Orientation
orient of
         Orientation
Horizontal ->
            ((Int
x,Int
y), Char
'<') ((Int, Int), Char) -> [((Int, Int), Char)] -> [((Int, Int), Char)]
forall a. a -> [a] -> [a]
:
            (Int -> ((Int, Int), Char)) -> [Int] -> [((Int, Int), Char)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
k -> ((Int
k,Int
y), Char
'-')) [Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 .. Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2] [((Int, Int), Char)]
-> [((Int, Int), Char)] -> [((Int, Int), Char)]
forall a. [a] -> [a] -> [a]
++
            ((Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
y), Char
'>') ((Int, Int), Char) -> [((Int, Int), Char)] -> [((Int, Int), Char)]
forall a. a -> [a] -> [a]
:
            []
         Orientation
Vertical ->
            ((Int
x,Int
y), Char
'A') ((Int, Int), Char) -> [((Int, Int), Char)] -> [((Int, Int), Char)]
forall a. a -> [a] -> [a]
:
            (Int -> ((Int, Int), Char)) -> [Int] -> [((Int, Int), Char)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
k -> ((Int
x,Int
k), Char
'|')) [Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 .. Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2] [((Int, Int), Char)]
-> [((Int, Int), Char)] -> [((Int, Int), Char)]
forall a. [a] -> [a] -> [a]
++
            ((Int
x,Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1), Char
'V') ((Int, Int), Char) -> [((Int, Int), Char)] -> [((Int, Int), Char)]
forall a. a -> [a] -> [a]
:
            []

formatShips :: (Int, Int) -> [Ship] -> String
formatShips :: (Int, Int) -> [Ship] -> String
formatShips (Int
width,Int
height) [Ship]
ships =
   let charMap :: Map (Int, Int) Char
charMap = [Map (Int, Int) Char] -> Map (Int, Int) Char
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([Map (Int, Int) Char] -> Map (Int, Int) Char)
-> [Map (Int, Int) Char] -> Map (Int, Int) Char
forall a b. (a -> b) -> a -> b
$ (Ship -> Map (Int, Int) Char) -> [Ship] -> [Map (Int, Int) Char]
forall a b. (a -> b) -> [a] -> [b]
map Ship -> Map (Int, Int) Char
charmapFromShip [Ship]
ships
   in  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
       (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
          (\Int
y ->
             (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map
                (\Int
x -> Char -> (Int, Int) -> Map (Int, Int) Char -> Char
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Char
'.' (Int
x,Int
y) Map (Int, Int) Char
charMap)
                [Int
0 .. Int
widthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1])
          [Int
0 .. Int
heightInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]


tryShip ::
   Bool -> Ship -> MS.StateT (Set (Int,Int)) [] Ship
tryShip :: Bool -> Ship -> StateT (Set (Int, Int)) [] Ship
tryShip Bool
outline Ship
ship = do
   Bool -> StateT (Set (Int, Int)) [] ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> StateT (Set (Int, Int)) [] ())
-> StateT (Set (Int, Int)) [] Bool -> StateT (Set (Int, Int)) [] ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Set (Int, Int) -> Bool) -> StateT (Set (Int, Int)) [] Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
MS.gets (Set (Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf (Ship -> Set (Int, Int)
shipArea Ship
ship))
   (Set (Int, Int) -> Set (Int, Int)) -> StateT (Set (Int, Int)) [] ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
MS.modify ((Set (Int, Int) -> Set (Int, Int) -> Set (Int, Int))
-> Set (Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Set (Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => Set a -> Set a -> Set a
Set.difference (Bool
-> (Ship -> Set (Int, Int))
-> (Ship -> Set (Int, Int))
-> Ship
-> Set (Int, Int)
forall a. Bool -> a -> a -> a
if' Bool
outline Ship -> Set (Int, Int)
shipOutline Ship -> Set (Int, Int)
shipArea Ship
ship))
   Ship -> StateT (Set (Int, Int)) [] Ship
forall (m :: * -> *) a. Monad m => a -> m a
return Ship
ship


tryShipsOfOneSize ::
   Bool -> Int -> Int ->
   MS.StateT (Set (Int,Int)) [] [Ship]
tryShipsOfOneSize :: Bool -> Int -> Int -> StateT (Set (Int, Int)) [] [Ship]
tryShipsOfOneSize Bool
outline Int
size Int
number =
   ((Orientation, (Int, Int)) -> StateT (Set (Int, Int)) [] Ship)
-> [(Orientation, (Int, Int))] -> StateT (Set (Int, Int)) [] [Ship]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Ship -> StateT (Set (Int, Int)) [] Ship
tryShip Bool
outline (Ship -> StateT (Set (Int, Int)) [] Ship)
-> ((Orientation, (Int, Int)) -> Ship)
-> (Orientation, (Int, Int))
-> StateT (Set (Int, Int)) [] Ship
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Orientation -> (Int, Int) -> Ship)
-> (Orientation, (Int, Int)) -> Ship
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int -> Orientation -> (Int, Int) -> Ship
Ship Int
size))
    ([(Orientation, (Int, Int))] -> StateT (Set (Int, Int)) [] [Ship])
-> StateT (Set (Int, Int)) [] [(Orientation, (Int, Int))]
-> StateT (Set (Int, Int)) [] [Ship]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [[(Orientation, (Int, Int))]]
-> StateT (Set (Int, Int)) [] [(Orientation, (Int, Int))]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift
    ([[(Orientation, (Int, Int))]]
 -> StateT (Set (Int, Int)) [] [(Orientation, (Int, Int))])
-> StateT (Set (Int, Int)) [] [[(Orientation, (Int, Int))]]
-> StateT (Set (Int, Int)) [] [(Orientation, (Int, Int))]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Set (Int, Int) -> [[(Orientation, (Int, Int))]])
-> StateT (Set (Int, Int)) [] [[(Orientation, (Int, Int))]]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
MS.gets (Int -> [(Orientation, (Int, Int))] -> [[(Orientation, (Int, Int))]]
forall a. Int -> [a] -> [[a]]
tuples Int
number ([(Orientation, (Int, Int))] -> [[(Orientation, (Int, Int))]])
-> (Set (Int, Int) -> [(Orientation, (Int, Int))])
-> Set (Int, Int)
-> [[(Orientation, (Int, Int))]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Orientation -> (Int, Int) -> (Orientation, (Int, Int)))
-> [Orientation] -> [(Int, Int)] -> [(Orientation, (Int, Int))]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) [Orientation
Vertical, Orientation
Horizontal] ([(Int, Int)] -> [(Orientation, (Int, Int))])
-> (Set (Int, Int) -> [(Int, Int)])
-> Set (Int, Int)
-> [(Orientation, (Int, Int))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Int, Int) -> [(Int, Int)]
forall a. Set a -> [a]
Set.toList)


fleetFromSizes :: [ShipSize] -> Fleet
fleetFromSizes :: [Int] -> Fleet
fleetFromSizes = (Int -> Int -> Int) -> [(Int, Int)] -> Fleet
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ([(Int, Int)] -> Fleet)
-> ([Int] -> [(Int, Int)]) -> [Int] -> Fleet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int -> (Int, Int)) -> Int -> Int -> (Int, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) Int
1)

standardFleet :: Fleet
standardFleet :: Fleet
standardFleet = [(Int, Int)] -> Fleet
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Int
5,Int
1), (Int
4,Int
2), (Int
3,Int
3), (Int
2,Int
4)]

configurationsInFragment :: Bool -> Fleet -> Set (Int,Int) -> [[Ship]]
configurationsInFragment :: Bool -> Fleet -> Set (Int, Int) -> [[Ship]]
configurationsInFragment Bool
outline Fleet
fleet Set (Int, Int)
set =
   StateT (Set (Int, Int)) [] [Ship] -> Set (Int, Int) -> [[Ship]]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
MS.evalStateT
      (([[Ship]] -> [Ship])
-> StateT (Set (Int, Int)) [] [[Ship]]
-> StateT (Set (Int, Int)) [] [Ship]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Ship]] -> [Ship]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (StateT (Set (Int, Int)) [] [[Ship]]
 -> StateT (Set (Int, Int)) [] [Ship])
-> StateT (Set (Int, Int)) [] [[Ship]]
-> StateT (Set (Int, Int)) [] [Ship]
forall a b. (a -> b) -> a -> b
$
       ((Int, Int) -> StateT (Set (Int, Int)) [] [Ship])
-> [(Int, Int)] -> StateT (Set (Int, Int)) [] [[Ship]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Int -> Int -> StateT (Set (Int, Int)) [] [Ship])
-> (Int, Int) -> StateT (Set (Int, Int)) [] [Ship]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Bool -> Int -> Int -> StateT (Set (Int, Int)) [] [Ship]
tryShipsOfOneSize Bool
outline)) ([(Int, Int)] -> StateT (Set (Int, Int)) [] [[Ship]])
-> [(Int, Int)] -> StateT (Set (Int, Int)) [] [[Ship]]
forall a b. (a -> b) -> a -> b
$
       Fleet -> [(Int, Int)]
forall k a. Map k a -> [(k, a)]
Map.toDescList Fleet
fleet)
      Set (Int, Int)
set

{-
Enumerate all possible configurations in the Battleship game.
-}
configurations :: (Int,Int) -> Fleet -> [[Ship]]
configurations :: (Int, Int) -> Fleet -> [[Ship]]
configurations (Int, Int)
bnds Fleet
fleet =
   Bool -> Fleet -> Set (Int, Int) -> [[Ship]]
configurationsInFragment Bool
True Fleet
fleet (Set (Int, Int) -> [[Ship]]) -> Set (Int, Int) -> [[Ship]]
forall a b. (a -> b) -> a -> b
$
      case (Int, Int) -> Board
fullBoard (Int, Int)
bnds of Board (Int, Int)
_ Set (Int, Int)
set -> Set (Int, Int)
set

configurationsTouching :: (Int,Int) -> Fleet -> [[Ship]]
configurationsTouching :: (Int, Int) -> Fleet -> [[Ship]]
configurationsTouching (Int, Int)
bnds Fleet
fleet =
   Bool -> Fleet -> Set (Int, Int) -> [[Ship]]
configurationsInFragment Bool
False Fleet
fleet (Set (Int, Int) -> [[Ship]]) -> Set (Int, Int) -> [[Ship]]
forall a b. (a -> b) -> a -> b
$
      case (Int, Int) -> Board
fullBoard (Int, Int)
bnds of Board (Int, Int)
_ Set (Int, Int)
set -> Set (Int, Int)
set

{-
*Combinatorics.Battleship.Enumeration> length $ configurations (9,9) (Map.fromList [(5,1)])
90
*Combinatorics.Battleship.Enumeration> length $ configurations (9,9) (Map.fromList [(4,2)])
3826
*Combinatorics.Battleship.Enumeration> length $ configurations (9,9) (Map.fromList [(3,3)])
134436
*Combinatorics.Battleship.Enumeration> length $ configurations (9,9) (Map.fromList [(2,4)])
5534214

*Combinatorics.Battleship.Enumeration> length $ configurations (10,10) (Map.fromList [(5,1)])
120
*Combinatorics.Battleship.Enumeration> length $ configurations (10,10) (Map.fromList [(4,2)])
6996
*Combinatorics.Battleship.Enumeration> length $ configurations (10,10) (Map.fromList [(3,3)])
330840
*Combinatorics.Battleship.Enumeration> length $ configurations (10,10) (Map.fromList [(2,4)])
17086631

*Combinatorics.Battleship.Enumeration> length $ configurations (10,10) (Map.fromList [(5,1),(4,2)])
371048
*Combinatorics.Battleship.Enumeration> length $ configurations (10,10) (Map.fromList [(5,1),(3,3)])
13477504
-}


enumerateStandard :: IO ()
enumerateStandard :: IO ()
enumerateStandard =
   let bnds :: (Int, Int)
bnds = (Int
10, Int
10)
   in  ([Ship] -> IO ()) -> [[Ship]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ()) -> ([Ship] -> String) -> [Ship] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> [Ship] -> String
formatShips (Int, Int)
bnds) ([[Ship]] -> IO ()) -> [[Ship]] -> IO ()
forall a b. (a -> b) -> a -> b
$
       Int -> [[Ship]] -> [[Ship]]
forall a. Int -> [a] -> [a]
take Int
100 ([[Ship]] -> [[Ship]]) -> [[Ship]] -> [[Ship]]
forall a b. (a -> b) -> a -> b
$
       (Int, Int) -> Fleet -> [[Ship]]
configurations (Int, Int)
bnds Fleet
standardFleet


{- |
<http://math.stackexchange.com/questions/58769/how-many-ways-can-we-place-these-ships-on-this-board>
-}
count :: (Int,Int) -> Fleet -> IO ()
count :: (Int, Int) -> Fleet -> IO ()
count (Int, Int)
bnds Fleet
fleet =
       do Handle -> BufferMode -> IO ()
IO.hSetBuffering Handle
IO.stdout BufferMode
IO.LineBuffering
          ((Integer, [[Ship]]) -> IO ()) -> [(Integer, [[Ship]])] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
             (\(Integer
n,[[Ship]]
configs) ->
                case [[Ship]]
configs of
                   [] -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"number of configurations: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Integer
n::Integer)
                   ([Ship]
c:[[Ship]]
_) ->
                      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod Integer
n Integer
1000000 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                         Integer -> IO ()
forall a. Show a => a -> IO ()
print Integer
n
                         String -> IO ()
putStrLn String
""
                         String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [Ship] -> String
formatShips (Int, Int)
bnds [Ship]
c) ([(Integer, [[Ship]])] -> IO ()) -> [(Integer, [[Ship]])] -> IO ()
forall a b. (a -> b) -> a -> b
$
             [Integer] -> [[[Ship]]] -> [(Integer, [[Ship]])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] ([[[Ship]]] -> [(Integer, [[Ship]])])
-> [[[Ship]]] -> [(Integer, [[Ship]])]
forall a b. (a -> b) -> a -> b
$ [[Ship]] -> [[[Ship]]]
forall a. [a] -> [[a]]
tails ([[Ship]] -> [[[Ship]]]) -> [[Ship]] -> [[[Ship]]]
forall a b. (a -> b) -> a -> b
$
             (Int, Int) -> Fleet -> [[Ship]]
configurationsTouching (Int, Int)
bnds Fleet
fleet

count8x8 :: IO ()
count8x8 :: IO ()
count8x8 = (Int, Int) -> Fleet -> IO ()
count (Int
8, Int
8) ([(Int, Int)] -> Fleet
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Int
2,Int
1), (Int
3,Int
2), (Int
4,Int
1), (Int
5,Int
1)])
{-
non-touching:
16546192


touching:
571126760

time required for computation:
real    41m36.880s
user    41m23.183s
sys     0m8.681s
-}

main :: IO ()
main :: IO ()
main = IO ()
count8x8