{- | 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 bnds set) = Board bnds $ Set.union set $ shipArea ship shipArea :: Ship -> Set (Int, Int) shipArea (Ship size orient (x,y)) = Set.fromAscList $ case orient of Horizontal -> map (flip (,) y) [x .. x+size-1] Vertical -> map ((,) x) [y .. y+size-1] reduceSpace :: Ship -> Board -> Board reduceSpace ship (Board bnds set) = Board bnds $ Set.difference set $ shipOutline ship shipOutline :: Ship -> Set (Int, Int) shipOutline (Ship size orient (x,y)) = Set.fromAscList $ case orient of Horizontal -> liftM2 (,) [x-1 .. x+size] [y-1 .. y+1] Vertical -> liftM2 (,) [x-1 .. x+1] [y-1 .. y+size] data Box = Box (Int, Int) (Int, Int) shipBounds :: Ship -> Box shipBounds (Ship size orient (x,y)) = case orient of Horizontal -> Box (x,y) (x+size-1, y) Vertical -> Box (x,y) (x, y+size-1) moveShip :: (Int, Int) -> Ship -> Ship moveShip (dx,dy) (Ship size orient (x,y)) = Ship size orient (x+dx, y+dy) {- | Bounding box around two boxes. -} mergeBox :: Box -> Box -> Box mergeBox (Box (a0x,a0y) (a1x,a1y)) (Box (b0x,b0y) (b1x,b1y)) = Box (min a0x b0x, min a0y b0y) (max a1x b1x, max a1y 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 (a0x,a0y) (a1x,a1y)) (Box (b0x,b0y) (b1x,b1y)) = Box (max a0x b0x, max a0y b0y) (min a1x b1x, min a1y b1y) boxSizes :: Box -> (Int, Int) boxSizes (Box (a0x,a0y) (a1x,a1y)) = (a1x - a0x + 1, a1y - a0y + 1) emptyBoard :: (Int, Int) -> Board emptyBoard bnds = Board bnds Set.empty fullBoard :: (Int, Int) -> Board fullBoard bnds@(width,height) = Board bnds $ Set.fromAscList $ liftM2 (,) [0 .. width-1] [0 .. height-1] boardFromShips :: (Int, Int) -> [Ship] -> Board boardFromShips bnds = foldl (flip insertShip) (emptyBoard bnds) formatBoard :: Board -> String formatBoard (Board (width,height) set) = unlines $ map (\y -> map (\x -> if Set.member (x,y) set then 'x' else '.') [0 .. width-1]) [0 .. height-1] charmapFromShip :: Ship -> Map (Int, Int) Char charmapFromShip (Ship size orient (x,y)) = Map.fromAscList $ case orient of Horizontal -> ((x,y), '<') : map (\k -> ((k,y), '-')) [x+1 .. x+size-2] ++ ((x+size-1,y), '>') : [] Vertical -> ((x,y), 'A') : map (\k -> ((x,k), '|')) [y+1 .. y+size-2] ++ ((x,y+size-1), 'V') : [] formatShips :: (Int, Int) -> [Ship] -> String formatShips (width,height) ships = let charMap = Map.unions $ map charmapFromShip ships in unlines $ map (\y -> map (\x -> Map.findWithDefault '.' (x,y) charMap) [0 .. width-1]) [0 .. height-1] tryShip :: Bool -> Ship -> MS.StateT (Set (Int,Int)) [] Ship tryShip outline ship = do guard =<< MS.gets (Set.isSubsetOf (shipArea ship)) MS.modify (flip Set.difference (if' outline shipOutline shipArea ship)) return ship tryShipsOfOneSize :: Bool -> Int -> Int -> MS.StateT (Set (Int,Int)) [] [Ship] tryShipsOfOneSize outline size number = mapM (tryShip outline . uncurry (Ship size)) =<< MT.lift =<< MS.gets (tuples number . liftM2 (,) [Vertical, Horizontal] . Set.toList) fleetFromSizes :: [ShipSize] -> Fleet fleetFromSizes = Map.fromListWith (+) . map (flip (,) 1) standardFleet :: Fleet standardFleet = Map.fromList [(5,1), (4,2), (3,3), (2,4)] configurationsInFragment :: Bool -> Fleet -> Set (Int,Int) -> [[Ship]] configurationsInFragment outline fleet set = MS.evalStateT (fmap concat $ mapM (uncurry (tryShipsOfOneSize outline)) $ Map.toDescList fleet) set {- Enumerate all possible configurations in the Battleship game. -} configurations :: (Int,Int) -> Fleet -> [[Ship]] configurations bnds fleet = configurationsInFragment True fleet $ case fullBoard bnds of Board _ set -> set configurationsTouching :: (Int,Int) -> Fleet -> [[Ship]] configurationsTouching bnds fleet = configurationsInFragment False fleet $ case fullBoard bnds of Board _ set -> 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 = let bnds = (10, 10) in mapM_ (putStrLn . formatShips bnds) $ take 100 $ configurations bnds standardFleet {- | -} count :: (Int,Int) -> Fleet -> IO () count bnds fleet = do IO.hSetBuffering IO.stdout IO.LineBuffering mapM_ (\(n,configs) -> case configs of [] -> putStrLn $ "number of configurations: " ++ show (n::Integer) (c:_) -> when (mod n 1000000 == 0) $ do print n putStrLn "" putStrLn $ formatShips bnds c) $ zip [0..] $ tails $ configurationsTouching bnds fleet count8x8 :: IO () count8x8 = count (8, 8) (Map.fromList [(2,1), (3,2), (4,1), (5,1)]) {- non-touching: 16546192 touching: 571126760 time required for computation: real 41m36.880s user 41m23.183s sys 0m8.681s -} main :: IO () main = count8x8