diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Henning Thielemann 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: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/battleship-combinatorics.cabal b/battleship-combinatorics.cabal new file mode 100644 --- /dev/null +++ b/battleship-combinatorics.cabal @@ -0,0 +1,89 @@ +Name: battleship-combinatorics +Version: 0.0 +License: BSD3 +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: http://hub.darcs.net/thielema/battleship-combinatorics/ +Category: Math +Synopsis: Compute number of possible arrangements in the battleship game +Description: + Compute number of possible arrangements in the battleship game + with different methods. + . + +Tested-With: GHC==7.4.2, GHC==7.8.4 +Cabal-Version: >=1.14 +Build-Type: Simple + +Source-Repository this + Tag: 0.0 + Type: darcs + Location: http://hub.darcs.net/thielema/battleship-combinatorics/ + +Source-Repository head + Type: darcs + Location: http://hub.darcs.net/thielema/battleship-combinatorics/ + +Library + Build-Depends: + QuickCheck >=2.5 && <3.0, + pooled-io >=0.0.2 && <0.1, + combinatorial >=0.0 && <0.2, + set-cover >=0.0.7 && <0.1, + temporary >=1.1 && <1.3, + directory >=1.1 && <1.4, + filepath >=1.3 && <1.5, + random >=1.0 && <1.2, + storable-record >=0.0.3 && <0.1, + storablevector >=0.2.11 && <0.3, + containers >=0.4.2 && <0.6, + deepseq >=1.3 && <1.5, + non-empty >=0.2.1 && <0.4, + transformers >=0.3 && <0.6, + utility-ht >=0.0.8 && <0.13, + prelude-compat >=0.0 && <0.0.1, + base >=4.5 && <5 + + GHC-Options: -Wall + Hs-Source-Dirs: src + Default-Language: Haskell98 + Exposed-Modules: + Combinatorics.Battleship + Combinatorics.Battleship.Fleet + Combinatorics.Battleship.Size + Combinatorics.Battleship.Count.Counter + Combinatorics.Battleship.Count.CountMap + Combinatorics.Battleship.Count.Frontier + Combinatorics.Battleship.Count.ShortenShip + Combinatorics.Battleship.Count.ShortenShip.Distribution + Combinatorics.Battleship.Count.Estimate + Combinatorics.Battleship.SetCover + Combinatorics.Battleship.Enumeration + Other-Modules: + Combinatorics.Battleship.Allocation + -- experimental + Combinatorics.Battleship.Count.DiagonalFrontier + Combinatorics.Battleship.Count.InclusionExclusion + Combinatorics.Battleship.Count.SquareBySquare + Combinatorics.Battleship.Count.Cumulative + +Executable battleship-combinatorics + Build-Depends: + battleship-combinatorics, + containers, + base + Main-Is: main/Main.hs + GHC-Options: -Wall -rtsopts -threaded + GHC-Prof-Options: -fprof-auto -rtsopts + Default-Language: Haskell98 + +Test-Suite battleship-combinatorics-test + Type: exitcode-stdio-1.0 + Build-Depends: + battleship-combinatorics, + QuickCheck, + base + Main-Is: test/Test.hs + GHC-Options: -Wall + Default-Language: Haskell98 diff --git a/main/Main.hs b/main/Main.hs new file mode 100644 --- /dev/null +++ b/main/Main.hs @@ -0,0 +1,27 @@ +module Main where + +import qualified Combinatorics.Battleship.SetCover as SetCover +import qualified Combinatorics.Battleship.Count.ShortenShip.Distribution as + Distribution +import qualified Combinatorics.Battleship.Count.ShortenShip as ShortenShip +import qualified Combinatorics.Battleship.Enumeration as Enumeration +import qualified Combinatorics.Battleship.Fleet as Fleet +import Combinatorics.Battleship.Size (n6) + +import qualified Data.Map as Map + + +main :: IO () +main = + case fromInteger 20 :: Int of + 00 -> Enumeration.count8x8 + 01 -> Enumeration.count (10,10) (Map.fromList [(2,1),(4,1),(5,1)]) + 10 -> SetCover.estimateDistribution + 11 -> ShortenShip.printMapSizes + 12 -> ShortenShip.countExternal + 13 -> ShortenShip.count8x8 + 14 -> print $ ShortenShip.count (n6,6) $ Fleet.fromList [(2,2), (3,2)] + 15 -> ShortenShip.countFleets + 20 -> Distribution.countExternal + 21 -> Distribution.countExternal >> SetCover.exactDistribution + _ -> return () diff --git a/src/Combinatorics/Battleship.hs b/src/Combinatorics/Battleship.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship.hs @@ -0,0 +1,18 @@ +module Combinatorics.Battleship where + +import Data.Map (Map, ) +import Data.Set (Set, ) + + +type ShipSize = Int +type NumberOfShips = Int +type Fleet = Map ShipSize NumberOfShips + + +data Orientation = Horizontal | Vertical + deriving (Show, Eq, Ord) + +data Ship = Ship ShipSize Orientation (Int, Int) + deriving (Show, Eq, Ord) + +data Board = Board (Int, Int) (Set (Int, Int)) diff --git a/src/Combinatorics/Battleship/Allocation.hs b/src/Combinatorics/Battleship/Allocation.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Allocation.hs @@ -0,0 +1,43 @@ +module Combinatorics.Battleship.Allocation where + + +import Data.Set (Set, ) +import qualified Data.Set as Set + +import Data.Tuple.HT (mapPair, ) + + +type T = Set (Int, Int) + + +fatten, fattenHorizontal, fattenVertical :: T -> T +fatten = fattenHorizontal . fattenVertical + +fattenHorizontal set = + Set.mapMonotonic (\(x,y) -> (x-1,y)) set + `Set.union` + set + `Set.union` + Set.mapMonotonic (\(x,y) -> (x+1,y)) set + +fattenVertical set = + Set.mapMonotonic (\(x,y) -> (x,y-1)) set + `Set.union` + set + `Set.union` + Set.mapMonotonic (\(x,y) -> (x,y+1)) set + +sizes :: T -> (Int, Int) +sizes = + let size cs = maximum cs - minimum cs + 1 + in mapPair (size, size) . unzip . Set.toList + +boundingBox :: T -> ((Int, Int), (Int, Int)) +boundingBox = + (\(xs,ys) -> ((minimum xs, minimum ys), (maximum xs, maximum ys))) . + unzip . Set.toList + +normalize :: T -> T +normalize set = + let (minx,miny) = fst $ boundingBox set + in Set.mapMonotonic (\(x,y) -> (x-minx,y-miny)) set diff --git a/src/Combinatorics/Battleship/Count/CountMap.hs b/src/Combinatorics/Battleship/Count/CountMap.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Count/CountMap.hs @@ -0,0 +1,270 @@ +module Combinatorics.Battleship.Count.CountMap ( + T, + KeyCount, + + Path(Path), + readFile, + writeFile, + + fromList, + fromListStorable, + fromListExternal, + writeSorted, + fromMap, + singleton, + size, + toAscList, + toMap, + + mergeMany, + + propMerge, + ) where + +import qualified Combinatorics.Battleship.Count.Frontier as Frontier +import qualified Combinatorics.Battleship.Count.Counter as Counter +import qualified Combinatorics.Battleship.Fleet as Fleet +import Combinatorics.Battleship.Count.Counter (add) +import Combinatorics.Battleship.Size (Nat, N10, ) + +import qualified System.IO.Temp as Temp +import System.Directory (removeFile, ) +import System.FilePath ((), ) + +import qualified Data.StorableVector.Lazy.Pointer as SVP +import qualified Data.StorableVector.Lazy as SVL + +import Data.Map (Map, ) +import qualified Data.Map as Map + +import qualified Control.Concurrent.PooledIO.Independent as Pool +import Control.DeepSeq (NFData, rnf, ) +import Control.Monad (liftM2, zipWithM_, foldM, forM_, ) +import Control.Applicative ((<$>), ) +import Control.Functor.HT (void, ) + +import qualified Data.NonEmpty as NonEmpty +import qualified Data.List.Match as Match +import Data.Monoid (Monoid, mempty, mappend, mconcat, ) +import Data.List.HT (sliceVertical, ) +import Text.Printf (printf, ) + +import Data.Word (Word64, ) + +import Foreign.Storable + (Storable, sizeOf, alignment, + poke, peek, pokeByteOff, peekByteOff, ) + +import Prelude hiding (readFile, writeFile, ) + + +type Count64 = Word64 +type Count128 = Counter.Composed Word64 Word64 + +{- | +Represents a @Map Key Count@ +by a lazy ByteString containing the (key,count) pairs in ascending order. +-} +newtype T w a = Cons (SVL.Vector (Element w a)) + deriving (Eq) + +instance (Nat w, Show a, Storable a) => Show (T w a) where + showsPrec prec (Cons x) = + showParen (prec>10) $ + showString "CountMap.fromAscList " . + shows (SVL.unpack x) + +instance (Storable a) => NFData (T w a) where + rnf (Cons x) = rnf x + + +data Element w a = + Element { + _elementKey :: Key w, + _elementCount :: a + } deriving (Eq, Show) + +type Key w = (Frontier.T w, Fleet.T) +type KeyCount w a = (Key w, a) + +instance (Storable a) => Storable (Element w a) where + sizeOf ~(Element ~(front, fleet) cnt) = + sizeOf front + sizeOf fleet + sizeOf cnt + alignment ~(Element ~(front, fleet) cnt) = + alignment front `lcm` alignment fleet `lcm` alignment cnt + poke ptr (Element (front, fleet) cnt) = do + pokeByteOff ptr 0 front + pokeByteOff ptr (sizeOf front) fleet + pokeByteOff ptr (sizeOf front + sizeOf fleet) cnt + peek ptr = do + front <- peekByteOff ptr 0 + fleet <- peekByteOff ptr (sizeOf front) + cnt <- peekByteOff ptr (sizeOf front + sizeOf fleet) + return (Element (front, fleet) cnt) + + +defaultChunkSize :: SVL.ChunkSize +defaultChunkSize = SVL.chunkSize 512 + +fromAscList :: (Storable a) => [KeyCount w a] -> T w a +fromAscList = + Cons . SVL.pack defaultChunkSize . map (uncurry Element) + +fromMap :: (Storable a) => Map (Key w) a -> T w a +fromMap = fromAscList . Map.toAscList + +fromList :: (Counter.C a, Storable a) => [KeyCount w a] -> T w a +fromList = fromMap . Map.fromListWith add + +fromListStorable :: (Counter.C a, Storable a) => [KeyCount w a] -> T w a +fromListStorable = mconcat . map (uncurry singleton) + + +toAscList :: (Storable a) => T w a -> [KeyCount w a] +toAscList (Cons m) = map pairFromElement $ SVL.unpack m + +toMap :: (Storable a) => T w a -> Map (Key w) a +toMap = Map.fromAscList . toAscList + + +singleton :: (Storable a) => Key w -> a -> T w a +singleton key cnt = Cons $ SVL.singleton $ Element key cnt + +pairFromElement :: Element w a -> KeyCount w a +pairFromElement (Element key cnt) = (key, cnt) + + +size :: T w a -> Int +size (Cons x) = SVL.length x + + +newtype Path w a = Path {getPath :: FilePath} + +writeFile :: (Storable a) => Path w a -> T w a -> IO () +writeFile (Path path) (Cons xs) = SVL.writeFile path xs + +{- | +It silently drops IO exceptions +and does not check whether the loaded data is valid. +-} +readFile :: (Storable a) => Path w a -> IO (T w a) +readFile (Path path) = + Cons . snd <$> SVL.readFileAsync defaultChunkSize path + +formatPath :: FilePath -> Int -> Path w a +formatPath dir = Path . (dir ) . printf "extsort%04d" + +{- | +It deletes the input files after the merge. +This saves a lot of disk space when running 'fromListExternal'. +-} +mergeFiles :: + (Counter.C a, Storable a) => Path w a -> Path w a -> Path w a -> IO () +mergeFiles input0 input1 output = do + writeFile output =<< liftM2 merge (readFile input0) (readFile input1) + removeFile $ getPath input0 + removeFile $ getPath input1 + +sequenceLast :: (Monad m) => a -> [m a] -> m a +sequenceLast deflt = foldM (\_ act -> act) deflt + +{- | +Create a @CountMap@ from a large list of elements. +Neither the argument nor the result needs to fit in memory. +You only have to provide enough space on disk. +The result is lazily read from a temporary file. +That is, this file should neither be modified +nor deleted while processing the result. +Even more, 'fromListExternal' must not be called again +while processing the result. +You may better choose 'writeSorted'. +-} +fromListExternal :: + (Counter.C a, Storable a) => Int -> [KeyCount w a] -> IO (T w a) +fromListExternal bucketSize xs = do + let dir = "/tmp" + lastN <- + sequenceLast (-1) $ + zipWith + (\n bucket -> writeFile (formatPath dir n) bucket >> return n) + [0 ..] $ + map fromList $ + sliceVertical bucketSize xs + case formatPath dir (2*lastN) of + finalPath -> do + forM_ (take lastN $ zip (iterate (2+) 0) [lastN+1 ..]) $ + \(srcN, dstN) -> + mergeFiles + (formatPath dir srcN) + (formatPath dir (srcN+1)) + (formatPath dir dstN `asTypeOf` finalPath) + readFile finalPath + +pairs :: [a] -> [(a,a)] +pairs (x0:x1:xs) = (x0,x1) : pairs xs +pairs (_:_) = [] +pairs [] = error "pairs: even number of elements" + +{- +The final external sort is bound by disk access time, +thus we only sort the buckets individually in parallel. +-} +writeSorted :: + (Counter.C a, Storable a) => Path w a -> [[KeyCount w a]] -> IO () +writeSorted dst xs = + Temp.withSystemTempDirectory "battleship" $ \dir -> do + let chunks = map fromList xs + let unary = void chunks + let paths = + {- + Matching with () makes sure + that references from 'unary' to 'chunks' are removed + as chunks are written to disk. + They can then be reclaimed by the garbage collector. + -} + zipWith (\() -> formatPath dir) (init $ init $ unary ++ unary) [0..] + ++ + [dst] + Pool.run $ zipWith writeFile paths chunks + zipWithM_ (uncurry mergeFiles) (pairs paths) (Match.drop unary paths) + + +empty :: (Storable a) => T w a +empty = Cons SVL.empty + +merge :: (Counter.C a, Storable a) => T w a -> T w a -> T w a +merge (Cons xs0) (Cons ys0) = + Cons $ + SVL.unfoldr defaultChunkSize + (\(xt,yt) -> + case (SVP.viewL xt, SVP.viewL yt) of + (Nothing, Nothing) -> Nothing + (Just (x,xs), Nothing) -> Just (x, (xs,yt)) + (Nothing, Just (y,ys)) -> Just (y, (xt,ys)) + (Just (Element xkey xcnt, xs), + Just (Element ykey ycnt, ys)) -> Just $ + case compare xkey ykey of + EQ -> (Element xkey (add xcnt ycnt), (xs,ys)) + LT -> (Element xkey xcnt, (xs,yt)) + GT -> (Element ykey ycnt, (xt,ys))) + (SVP.cons xs0, SVP.cons ys0) + +propMerge :: [KeyCount N10 Count64] -> [KeyCount N10 Count64] -> Bool +propMerge xs ys = + let xm = Map.fromListWith add xs + ym = Map.fromListWith add ys + in merge (fromMap xm) (fromMap ym) + == + fromMap (Map.unionWith add xm ym) + + +{-# SPECIALISE mergeMany :: [T w Count64] -> T w Count64 #-} +{-# SPECIALISE mergeMany :: [T w Count128] -> T w Count128 #-} +{-# INLINEABLE mergeMany #-} +mergeMany :: (Counter.C a, Storable a) => [T w a] -> T w a +mergeMany = maybe empty (NonEmpty.foldBalanced merge) . NonEmpty.fetch + +instance (Counter.C a, Storable a) => Monoid (T w a) where + mempty = empty + mappend = merge + mconcat = mergeMany diff --git a/src/Combinatorics/Battleship/Count/Counter.hs b/src/Combinatorics/Battleship/Count/Counter.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Count/Counter.hs @@ -0,0 +1,102 @@ +module Combinatorics.Battleship.Count.Counter ( + C, + Composed, + zero, + one, + add, + sum, + toInteger, + propAdd, + ) where + +import Control.Monad (liftM2, ) + +import qualified Data.List as List +import Data.Bits (shiftL, ) +import Data.Word (Word8, Word32, Word64, ) + +import Foreign.Storable + (Storable, sizeOf, alignment, + poke, peek, pokeByteOff, peekByteOff, ) + +import qualified Test.QuickCheck as QC + +import Prelude hiding (sum, toInteger, ) + + +class C a where + zero, one :: a + add :: a -> a -> a + +class (C a, Ord a) => Integ a where + toInteger :: a -> Integer + rangeSize :: a -> Integer + +instance C Word8 where + zero = 0; one = 1 + add = (+) + +instance Integ Word8 where + toInteger = fromIntegral + rangeSize _ = shiftL 1 8 + +instance C Word32 where + zero = 0; one = 1 + add = (+) + +instance Integ Word32 where + toInteger = fromIntegral + rangeSize _ = shiftL 1 32 + +instance C Word64 where + zero = 0; one = 1 + add = (+) + +instance Integ Word64 where + toInteger = fromIntegral + rangeSize _ = shiftL 1 64 + +sum :: (C a) => [a] -> a +sum = List.foldl' add zero + +data Composed hi lo = Composed !hi !lo + deriving (Eq, Ord) + +instance (C hi, C lo, Ord lo) => C (Composed hi lo) where + zero = Composed zero zero + one = Composed zero one + add (Composed xh xl) (Composed yh yl) = + let zh = add xh yh; zl = add xl yl + in Composed (if zl < xl then add zh one else zh) zl + +instance (Integ hi, Integ lo) => Integ (Composed hi lo) where + rangeSize ~(Composed hi lo) = rangeSize hi * rangeSize lo + toInteger (Composed hi lo) = + toInteger hi * rangeSize lo + toInteger lo + +instance (Integ hi, Integ lo) => Show (Composed hi lo) where + show = show . toInteger + +-- | This instance expects that there is no need for padding for alignment +instance (Storable a, Storable b) => Storable (Composed a b) where + sizeOf ~(Composed a b) = sizeOf a + sizeOf b + alignment ~(Composed a b) = alignment a `lcm` alignment b + poke ptr (Composed a b) = do + pokeByteOff ptr 0 a + pokeByteOff ptr (sizeOf a) b + peek ptr = do + a <- peekByteOff ptr 0 + b <- peekByteOff ptr (sizeOf a) + return $ Composed a b + + +instance (QC.Arbitrary a, QC.Arbitrary b) => QC.Arbitrary (Composed a b) where + arbitrary = liftM2 Composed QC.arbitrary QC.arbitrary + shrink (Composed hi lo) = map (uncurry Composed) $ QC.shrink (hi,lo) + +propAdd :: + Composed (Composed Word64 Word32) (Composed Word32 Word32) -> + Composed (Composed Word64 Word32) (Composed Word32 Word32) -> + Bool +propAdd a b = + toInteger (add a b) == mod (toInteger a + toInteger b) (rangeSize a) diff --git a/src/Combinatorics/Battleship/Count/Cumulative.hs b/src/Combinatorics/Battleship/Count/Cumulative.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Count/Cumulative.hs @@ -0,0 +1,67 @@ +module Combinatorics.Battleship.Count.Cumulative where + +import qualified Data.Foldable as Fold +import qualified Data.Map as Map +import Data.Map (Map, ) + +import Control.Monad (liftM2, ) + +import Text.Printf (printf, ) + + +size :: Int +size = 10 + +{- | +If the map contains @n@ at position @(x,y)@ +this means that there are @n@ possible arrangements +of a certain number of 2-ships, +where you can place another 2-ship beginning at position @(x,y)@. +-} +type Board = Map (Int, Int) Integer + +init2 :: Board +init2 = Map.fromList $ do + x <- [0 .. pred size] + y <- [0 .. pred size] + return $ ((x,y), if y String +formatBoard board = + unlines $ + map + (\y -> + concatMap + (\x -> printf "%10d" $ board Map.! (x,y)) + [0 .. pred size]) + [0 .. pred size] + +iter :: Board -> Board +iter board = foldl1 (Map.intersectionWith (+)) $ do + x <- [0 .. pred size] + y <- [0 .. pred size] + let n = board Map.! (x,y) + return $ fmap (n*) $ deleteFromBoard (x,y) board + +deleteFromBoard :: (Int, Int) -> Board -> Board +deleteFromBoard (x,y) board = + foldl (flip $ Map.adjust (const 0)) board $ + liftM2 (,) [x-1 .. x+1] [y-2 .. y+2] + +{- +correct numbers found by exhaustive enumeration +for 2-ships all vertically oriented. + +no. ships no. placements + +1 90 (* 1) +2 3504 (* 2) +3 77856 (* 6) +4 1097615 (*24) +-} + +main :: IO () +main = do + print $ Fold.sum init2 -- correct + print $ Fold.sum $ iter init2 -- correct + print $ Fold.sum $ iter $ iter init2 -- too big diff --git a/src/Combinatorics/Battleship/Count/DiagonalFrontier.hs b/src/Combinatorics/Battleship/Count/DiagonalFrontier.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Count/DiagonalFrontier.hs @@ -0,0 +1,325 @@ +{- | +In this approach we try to count the number of battleship configurations +pushing a diagonal frontier over the board. +The frontier is not exactly diagonal but monotonic. + + +Attention! + +This counting approach counts configurations twice. +The smallest known of such configurations is: + +..* +... +*.. + + +However, you can use this counting for getting an upper bound. +If the upper bound is zero, then there is no possibility to layout the ships. +This way we can prove, +that the 8x8 area cannot be filled with the fleet of 10x10 board game. +-} + +{- +possible optimizations: + + - do not cache, but compute counts for single ships + - do not cache count for empty fleets + - use bitvector for Frontier + - use bitvector for Fleet +-} + +module Combinatorics.Battleship.Count.DiagonalFrontier where + +import Combinatorics.Battleship.Enumeration (configurationsInFragment, ) +import Combinatorics.Battleship (Fleet, ) + +import Data.Map (Map, ) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Control.Monad (guard, ) +import Data.Traversable (forM, ) + +import Data.List.HT (mapAdjacent, ) +import Data.Maybe.HT (toMaybe, ) +import Data.Maybe (fromMaybe, ) + + +{- +(map fst frontier) must be strictly increasing +and (map snd frontier) must be strictly decreasing. + +E.g. the following area + + xxxxxxx... + xxxxxxx... + xxx....... + xxx....... + xxx....... + xxx....... + xx........ + xx........ + xx........ + xx........ + +is represented by the frontier + + [(2,6), (3,2), (7,0)] + +. + +We could represent a frontier more efficiently by a bit vector +that tells whether an edge (of one square) in the frontier +is vertical or horizontal. +For the example above we would get the sequence: + + hhvvvvhvvvvhhhhvvhhh +-} +type Frontier = [(Int, Int)] + +areaWithinFrontier :: (Int, Int) -> Frontier -> Int +areaWithinFrontier (width, height) corners = + sum $ + zipWith (*) + (map ((width - ) . fst) corners) + (mapAdjacent (-) $ height : map snd corners) + +borderFromFrontier :: Frontier -> Frontier +borderFromFrontier = + map (\(x,y) -> (x-1,y-1)) + +{- +It must hold: +areaWithinFrontier bnds frontier == + length (positionsWithinFrontier bnds frontier) +-} +positionsWithinFrontier :: (Int, Int) -> Frontier -> [(Int,Int)] +positionsWithinFrontier (width, height) corners = do + (x0,(y1,y0)) <- + zipWith (,) + (map fst corners) + (mapAdjacent (,) $ height : map snd corners) + x <- [x0 .. width-1] + y <- [y0 .. y1-1] + return (x,y) + +clipBottomFrontier :: Int -> Frontier -> Frontier +clipBottomFrontier height xys = + dropWhile ((height<) . snd) xys + +clipRightFrontier :: Int -> Frontier -> Frontier +clipRightFrontier width xys = + takeWhile ((<=width) . fst) xys + +clipBottomFrontier0 :: Int -> Frontier -> Frontier +clipBottomFrontier0 height xys = + dropWhile ((height<=) . snd) xys + +clipRightFrontier0 :: Int -> Frontier -> Frontier +clipRightFrontier0 width xys = + takeWhile (( Frontier -> Frontier +clipBottomFrontier height xys = + let (left, right) = span ((height<=) . snd) xys + in if null left + then right + else (fst $ last left, height) : right + +clipRightFrontier :: Int -> Frontier -> Frontier +clipRightFrontier width xys = + let (lower, upper) = span (( Frontier -> Int -> [(Int, Int)] +cornersForShip (width, height) frontier shipSize = + (map (\(x,y) -> (x+2, y+shipSize+1)) $ + positionsWithinFrontier (width, height-shipSize+1) $ + clipBottomFrontier (height-shipSize) frontier) + ++ + (map (\(x,y) -> (x+shipSize+1, y+2)) $ + positionsWithinFrontier (width-shipSize+1, height) $ + clipRightFrontier (width-shipSize) frontier) + +{- +Reduce area in frontier by cutting away a top-left aligned rectangle +specified by its width and height. +-} +moveFrontier :: (Int, Int) -> Frontier -> Frontier +moveFrontier (cx,cy) xys = + let (left, right) = span ((cy<) . snd) xys + (lower, upper) = span ((<=cx) . fst) right + in normalizeFrontier $ + left ++ + (if null lower + then [] + else [(fst $ head lower, cy), (cx, snd $ last lower)]) ++ + upper + +normalizeFrontier :: Frontier -> Frontier +normalizeFrontier ((x0,y0):xys0@((x1,y1):xys1)) = + if x0 == x1 + then normalizeFrontier xys0 + else + if y0 == y1 + then normalizeFrontier $ (x0,y0) : xys1 + else (x0,y0) : normalizeFrontier xys0 +normalizeFrontier xys = xys + +{- +This works for a frontier representation by bottom-right corners. + +moveFrontier :: (Int, Int) -> Frontier -> Frontier +moveFrontier cxy@(cx,cy) xys = + let (left, right) = span ((cy<=) . snd) xys + (lower, upper) = span ((cx>=) . fst) right + in left ++ (if null lower then [] else [cxy]) ++ upper +-} + +{- +It holds @length (allFrontiers (w,h)) + 1 == binomial (w+h) h@. +We omit the frontier that has no area. + +If we could generate the frontiers in a lexicographically sorted way, +then we could use an efficient Map.fromAscList. +-} +allFrontiers :: (Int, Int) -> [Frontier] +allFrontiers (width, height) = do + x <- [0 .. width-1] + y <- [0 .. height-1] + allFrontiersAt (x,y) (width-x, height-y) + +allFrontiersAt :: (Int, Int) -> (Int, Int) -> [Frontier] +allFrontiersAt (x,y) (width, height) = + [(x,y)] : do + dx <- [1 .. width-1] + dy <- [1 .. height-1] + poss <- allFrontiersAt (x+dx,y) (width-dx, dy) + return $ (x,y+dy) : poss + + +minimumAreaForFleet :: Fleet -> Int +minimumAreaForFleet = + sum . map (\(size,num) -> (size+1)*2*num) . Map.toList + + +countPartial :: + Map (Frontier, Fleet) Integer -> + (Int, Int) -> Frontier -> Fleet -> Integer +countPartial cnts bnds@(width,height) frontier fleet = + if Map.null fleet + then 1 + else sum $ do + shipSize <- Map.keys fleet + let restFleet = + Map.update + (\n0 -> let n1 = n0-1 in toMaybe (n1>0) n1) + shipSize fleet + newCorner <- + cornersForShip bnds frontier shipSize + return $ + fromMaybe 0 $ + Map.lookup + (clipBottomFrontier0 height $ + clipRightFrontier0 width $ + moveFrontier newCorner frontier, + restFleet) + cnts + +countAll :: (Int, Int) -> Fleet -> Map (Frontier, Fleet) Integer +countAll bnds fleet = + let cnts = + Map.fromList $ do + frontier <- [] : allFrontiers bnds + let freeArea = + areaWithinFrontier bnds $ + borderFromFrontier frontier + partialFleet0 <- + forM fleet $ \num -> [0 .. num] + let partialFleet = Map.filter (0/=) partialFleet0 + guard $ minimumAreaForFleet partialFleet <= freeArea + return ((frontier, partialFleet), + countPartial cnts bnds frontier partialFleet) + in cnts + +count :: (Int, Int) -> Fleet -> Integer +count bnds fleet = + Map.findWithDefault + (error "count: did not find largest frontier") + ([(0,0)], fleet) $ + countAll bnds fleet + + + + +testCountAll :: + (Int, Int) -> Fleet -> Map (Frontier, Fleet) (Integer, Integer) +testCountAll bnds = + Map.filter (uncurry (/=)) . + Map.mapWithKey (\(frontier, fleet) cnt -> + (cnt, + fromIntegral $ length $ configurationsInFragment True fleet $ + Set.fromList $ positionsWithinFrontier bnds frontier)) . + countAll bnds + + +{- +other ideas for counting: + +- make an induction over the ship size and count layouts in connected areas + i.e. place the 5-size-ship somewhere, + divide the remaining free space into connected components, + count the number of layouts of the [4:2, 3:3, 2:4] fleet + for all of these components. + For all possible component shapes place the two 4-size ships + and divide the remaining space into connected components. + And so on, and so on. + In order to be efficient we need an efficient map + from component shapes to numbers. + We could represent a component shape using a bit vector, + and use this bit vector as key of a Map. + But it is certainly also a good idea to avoid rebalancing. + Can we find a lazy trie structure, that saves enough space + by not evaluating impossible component shapes? + We could use the outline of the shape, but a component may contain holes. + +- Sort the ships lexicographically according to their left-top corner. + Try all positions for the lexicographically first ship. + Maintain a frontier + that is a horizontal sequence of heights of free space. + E.g. the following area + + xxxxxx..xx + xxxx....xx + .xxx....xx + .......... + .......... + + is represented by the frontier + + [3,2,2,2,4,4,5,5,2,2] + + The frontier itself has a maximum height of 6, + since ships with lexicographically smaller positions + than the already layouted ones are not possible + and maximum size of a ship is 5. + The maximum number of frontiers is thus 5*6^10. + There are less such frontiers, + since not all jump heights in such a frontier are possible. + We might employ a specialised Trie + that saves memory by not evaluating certain frontiers. + The key of the trie consists of the fleet size, the frontier, + and the lexicographically next position. + The next position can be merged into the frontier, + by removing a single square from the free space. + The keys in the trie should somehow combine the fleet size + and the frontier height, + since for small frontier heights and big fleets + the number of layouts is zero and we do not need to store that. +-} diff --git a/src/Combinatorics/Battleship/Count/Estimate.hs b/src/Combinatorics/Battleship/Count/Estimate.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Count/Estimate.hs @@ -0,0 +1,60 @@ +module Combinatorics.Battleship.Count.Estimate ( + overlapping, + occupying, + ) where + +import qualified Combinatorics.Battleship.Fleet as Fleet + +import qualified Data.NonEmpty as NonEmpty + + +overlapping :: (Int,Int) -> Fleet.T -> Integer +overlapping (width,height) = + product . + map + (\(size,count) -> + (fromIntegral height * fromIntegral (max 0 (width-size+1)) + + fromIntegral width * fromIntegral (max 0 (height-size+1))) + ^ count) . + Fleet.toList + + +{- +This takes into account +that every ship occupies spaces that cannot be used for other ships anymore. +We reduce the available area ship by ship +and then estimate the number of remaining positions for each ship. +Unfortunately, we do not know the shape of the area - +it depends on the position of the placed ships. +We work-around this problem by selecting rectangles +that have at least the required area. +This leads to an upper bound, given that a shape of a certain area +provides a maximum of ship positions if it is rectangular. +-} +occupying :: (Int,Int) -> Fleet.T -> Integer +occupying (width,height) fleet = + let sizes = reverse $ Fleet.toSizes fleet + in product $ map toInteger $ + zipWith (flip $ maxPositionsInArea (width+1,height+1)) sizes $ + scanl (-) ((width+1)*(height+1)) $ + map (\size -> 2*(fromIntegral size + 1)) sizes + +maxPositionsInArea :: (Int,Int) -> Int -> Int -> Int +maxPositionsInArea (maxWidth,maxHeight) area size = + NonEmpty.maximum $ NonEmpty.cons 0 $ + concatMap + (\(width,height) -> [(width-size)*(height-1), (width-1)*(height-size)]) $ + filter + (\(width,height) -> + width<=maxWidth && height<=maxHeight + || + height<=maxWidth && width<=maxHeight) $ + rectangles area + +rectangles :: Int -> [(Int,Int)] +rectangles area = + takeWhile (uncurry (<=)) $ map (\a -> (a, divUp area a)) [2..] + +-- cf. numeric-prelude:Algebra.IntegralDomain.divUp +divUp :: (Integral a) => a -> a -> a +divUp n m = - div (-n) m diff --git a/src/Combinatorics/Battleship/Count/Frontier.hs b/src/Combinatorics/Battleship/Count/Frontier.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Count/Frontier.hs @@ -0,0 +1,494 @@ +module Combinatorics.Battleship.Count.Frontier ( + T, + Position, + maxShipSize, + + Use(Blocked, Free, Vertical), + blockBounded, + empty, + insertNew, + isFree, + dilate, + lookup, + reverse, Reverse, + foldMap, + toList, + mapToVector, + + fromList, + fromString, + + propDilate, + propReverse4, + propReverse5, + propReverse6, + propReverse7, + propReverse8, + propReverse9, + propReverse10, + ) where + +import qualified Combinatorics.Battleship.Size as Size +import Combinatorics.Battleship.Size + (Nat, Size(Size), N4, N5, N6, N7, N8, N9, N10, N11) + +import qualified Foreign.Storable.Newtype as Store +import qualified Foreign.Storable as St +import Foreign.Storable (Storable, alignment, poke, peek, ) + +import Control.Applicative ((<$>), ) + +import qualified Data.StorableVector.Lazy.Builder as SVBuilder +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import qualified Data.Monoid.HT as Mn +import Data.Bits (Bits, (.&.), (.|.), shiftL, shiftR, complement, ) +import Data.Word (Word32, Word64, ) +import Data.Char (ord, chr, ) + +import Data.Monoid (Monoid, mempty, mappend, ) +import Data.Function.HT (nest, ) +import Data.Bool.HT (if', ) + +import qualified Test.QuickCheck as QC + +import Prelude2010 hiding (lookup, reverse, ) +import Prelude () + + +type Position = Int + +data Use = + Free + | Blocked + | Vertical Int + deriving (Eq, Show) + +{- | +Efficient representation of a (Map Position Use). + +We need it for description of a cut of a board with ships. + +> ....#..... +> ....#..... +> .......... +> ####...... +> .......... +> ___...#...#..___ +> ##.#...#.. +> ...#...... +> ...#..###. +> .......... + +Say, we are constructing the board with ships beginning from the bottom. +Using information from the cut, +we want to know at what positions in the upper plane are ships allowed. +In the example the frontier at the cut would be + +> fromString "xxx3x.x1x." + +The numbers 3 and 1 denotes lengths of the parts of vertical ships below the cut. +The @x@'s denote blocked columns, +i.e. in these columns it is not allowed to place ships +immediately above the cut. +-} +newtype T w = Cons {decons :: Word32} + deriving (Eq, Ord) -- for use as key in a Map + + +instance (Nat w) => Show (T w) where + showsPrec prec x = + showParen (prec>10) $ + showString "Frontier.fromString " . + shows (toString x) + +instance Storable (T w) where + sizeOf = Store.sizeOf decons + alignment = Store.alignment decons + poke = Store.poke decons + peek = Store.peek Cons + + +debug :: Bool +debug = False + +{-# INLINE checkPos #-} +checkPos :: String -> Size w -> Position -> a -> a +checkPos name (Size size) pos = + if' (debug && (pos<0 || size<=pos)) $ + error $ name ++ ": position " ++ show pos ++ " out of range" + +{-# INLINE validUse #-} +validUse :: Use -> Bool +validUse use = + case use of + Vertical k -> 0 True + +{-# INLINE checkUse #-} +checkUse :: String -> Use -> a -> a +checkUse name use = + if' (debug && not (validUse use)) $ + error $ name ++ ": invalid use " ++ show use + +{-# INLINE checkFree #-} +checkFree :: String -> Bool -> a -> a +checkFree name free = + if' (debug && not free) $ + error $ name ++ ": position not free" + +bitsPerNumber :: Int +bitsPerNumber = 3 + +mask :: Word32 +mask = shiftL 1 bitsPerNumber - 1 + +maxShipSize :: Int +maxShipSize = fromIntegral mask - 1 + +bitsFromUse :: Use -> Word32 +bitsFromUse use = + case use of + Free -> 0 + Blocked -> mask + Vertical n -> fromIntegral n + +useFromBits :: Word32 -> Use +useFromBits bits = + if' (bits==0) Free $ + if' (bits==mask) Blocked $ + Vertical $ fromIntegral bits + +useFromChar :: Char -> Use +useFromChar c = + case c of + '.' -> Free + 'x' -> Blocked + _ -> + if' ('1'<=c && c<='9') + (Vertical (ord c - ord '0')) + (error $ "useFromChar: illegal charactor '" ++ c : "'") + +empty :: T w +empty = Cons 0 + +fromList :: [Use] -> T w +fromList = + Cons . foldl (.|.) 0 . + zipWith (\pos x -> shiftL x (pos*bitsPerNumber)) [0..] . + map bitsFromUse + +fromString :: String -> T w +fromString = + fromList . map useFromChar + +sizeOf :: (Nat w) => T w -> Size w +sizeOf _ = Size.size + +lookup :: (Nat w) => T w -> Position -> Use +lookup frontier@(Cons bits) pos = + checkPos "Frontier.lookup" (sizeOf frontier) pos $ useFromBits $ + shiftR bits (pos*bitsPerNumber) .&. mask + +isFree :: (Nat w) => T w -> Position -> Bool +isFree frontier pos = + lookup frontier pos == Free + +{- | +Only allowed at positions containing 'Free'. +-} +insertNew :: (Nat w) => Position -> Use -> T w -> T w +insertNew pos use frontier@(Cons bits) = + let name = "Frontier.insertNew" + in checkPos name (sizeOf frontier) pos $ checkUse name use $ + checkFree name (isFree frontier pos) $ + Cons $ bits .|. shiftL (bitsFromUse use) (pos*bitsPerNumber) + +{- | +Inserts at positions outside of the bounds are ignored. +You may overwrite Free or Blocked fields, but not Vertical ones. +-} +blockBounded :: (Nat w) => Size w -> Position -> T w -> T w +blockBounded (Size size) pos frontier@(Cons bits) = + if' (pos<0 || size<=pos) frontier $ + if' (debug && case lookup frontier pos of Vertical _ -> True; _ -> False) + (error $ "Frontier.insertBounded: tried to overwrite Vertical at position " ++ show pos) + (Cons $ bits .|. shiftL (bitsFromUse Blocked) (pos*bitsPerNumber)) + + +dilate :: Size w -> T w -> T w +dilate = dilateComb + +dilateComb :: Size w -> T w -> T w +dilateComb (Size size) = + let comb = replicateOne size 1 + in \(Cons bits) -> + let occupied = bits .|. shiftR bits 1 .|. shiftR bits 2 + additional = + (shiftL occupied bitsPerNumber .|. shiftR occupied bitsPerNumber) + .&. + complement occupied + .&. + comb + in Cons $ bits .|. + additional .|. shiftL additional 1 .|. shiftL additional 2 + +dilateGen :: (Nat w) => Size w -> T w -> T w +dilateGen width@(Size size) frontier = + foldl (flip $ blockBounded width) frontier $ + filter (isFree frontier) $ + concatMap (\k -> Mn.when (k>0) [k-1] ++ Mn.when (k + Size.reifyInt n + (\size -> QC.forAllShrink QC.arbitrary QC.shrink $ propDilateTyped size) + +propDilateTyped :: (Nat w) => Size w -> T w -> Bool +propDilateTyped size frontier = + dilateComb size frontier == dilateGen size frontier + +mapToVector :: + (Nat w, Storable a) => Size w -> (Use -> a) -> T w -> SV.Vector a +mapToVector (Size size) f frontier = + SV.sample size $ f . lookup frontier + +_mapToVector :: + (Nat w, Storable a) => Size w -> (Use -> a) -> T w -> SV.Vector a +_mapToVector (Size size) f = + SV.concat . SVL.chunks . + SVBuilder.toLazyStorableVector (SVL.chunkSize size) . + foldMap (SVBuilder.put . f) + + +{- | +Can be faster than 'toList' since it does not build a list. +It ignores 'Free' squares at the end of the frontier. +-} +{-# INLINE foldMap #-} +foldMap :: (Monoid m) => (Use -> m) -> T w -> m +foldMap f = + let go m bits = + if bits==0 + then m + else go (mappend m (f $ useFromBits $ bits .&. mask)) $ + shiftR bits bitsPerNumber + in go mempty . decons + +toListWithSize :: (Nat w) => Size w -> T w -> [Use] +toListWithSize (Size width) frontier = map (lookup frontier) $ take width [0 ..] + +toList :: (Nat w) => T w -> [Use] +toList = toListWithSize Size.size + +charFromUse :: Use -> Char +charFromUse u = + case u of + Free -> '.' + Blocked -> 'x' + Vertical n -> + if' (1<=n && n<=9) + (chr (n + ord '0')) + (error $ "charFromUse: illegal vertical number " ++ show n) + +toString :: (Nat w) => T w -> String +toString = map charFromUse . toList + + +newtype Reverse w = Reverse {runReverse :: T w -> T w} +newtype Reverse1 w = Reverse1 {runReverse1 :: T (Size.P1 w) -> T (Size.P1 w)} +newtype Reverse2 w = Reverse2 {runReverse2 :: T (Size.P2 w) -> T (Size.P2 w)} +newtype Reverse3 w = Reverse3 {runReverse3 :: T (Size.P3 w) -> T (Size.P3 w)} +newtype Reverse4 w = Reverse4 {runReverse4 :: T (Size.P4 w) -> T (Size.P4 w)} +newtype Reverse5 w = Reverse5 {runReverse5 :: T (Size.P5 w) -> T (Size.P5 w)} +newtype Reverse6 w = Reverse6 {runReverse6 :: T (Size.P6 w) -> T (Size.P6 w)} +newtype Reverse7 w = Reverse7 {runReverse7 :: T (Size.P7 w) -> T (Size.P7 w)} +newtype Reverse8 w = Reverse8 {runReverse8 :: T (Size.P8 w) -> T (Size.P8 w)} +newtype Reverse9 w = Reverse9 {runReverse9 :: T (Size.P9 w) -> T (Size.P9 w)} +newtype Reverse10 w = Reverse10 {runReverse10 :: T (Size.P10 w) -> T (Size.P10 w)} + +reverse :: Nat w => T w -> T w +reverse = + runReverse $ Size.switch (Reverse id) $ Reverse $ + runReverse1 $ Size.switch (Reverse1 id) $ Reverse1 $ + runReverse2 $ Size.switch (Reverse2 $ reverseGen Size.size) $ Reverse2 $ + runReverse3 $ Size.switch (Reverse3 $ reverseGen Size.size) $ Reverse3 $ + runReverse4 $ Size.switch (Reverse4 reverse4spread) $ Reverse4 $ + runReverse5 $ Size.switch (Reverse5 reverse5spread) $ Reverse5 $ + runReverse6 $ Size.switch (Reverse6 reverse6up) $ Reverse6 $ + runReverse7 $ Size.switch (Reverse7 reverse7up) $ Reverse7 $ + runReverse8 $ Size.switch (Reverse8 reverse8up) $ Reverse8 $ + runReverse9 $ Size.switch (Reverse9 reverse9up) $ Reverse9 $ + runReverse10 $ Size.switch (Reverse10 reverse10up) $ Reverse10 $ + reverseGen Size.size + + +reverseGen :: Size w -> T w -> T w +reverseGen (Size size) (Cons bits) = + Cons $ snd $ + nest size + (\(src, dst) -> + (shiftR src bitsPerNumber, + shiftL dst bitsPerNumber .|. (mask .&. src))) + (bits, 0) + +{-# INLINE swap #-} +swap :: Int -> Word32 -> Word32 -> Word32 +swap n m bits = + shiftL (bits .&. m) (n*bitsPerNumber) .|. + (shiftR bits (n*bitsPerNumber) .&. m) + +reverse6up :: T N6 -> T N6 +reverse6up (Cons bits0) = + let bits1 = swap 1 0o070707 bits0 + in Cons $ swap 4 0o000077 bits1 .|. bits1 .&. 0o007700 + +reverse7up :: T N7 -> T N7 +reverse7up (Cons bits0) = + let bits1 = swap 2 0o0070007 bits0 .|. bits0 .&. 0o0700070 + in Cons $ swap 4 0o0000777 bits1 .|. bits0 .&. 0o0007000 + +reverse8up :: T N8 -> T N8 +reverse8up (Cons bits0) = + let bits1 = swap 1 0o07070707 bits0 + bits2 = swap 2 0o00770077 bits1 + in Cons $ swap 4 0o00007777 bits2 + +reverse9up :: T N9 -> T N9 +reverse9up (Cons bits0) = + let bits1 = swap 1 0o070700707 bits0 + bits2 = swap 2 0o007700077 bits1 + in Cons $ swap 5 0o000007777 bits2 .|. bits0 .&. 0o000070000 + +reverse10up :: T N10 -> T N10 +reverse10up (Cons bits0) = + let bits1 = swap 1 0o0707070707 bits0 + bits2 = swap 2 0o0077000077 bits1 + in Cons $ swap 6 0o0000007777 bits2 .|. bits1 .&. 0o0000770000 + +reverse10down :: T N10 -> T N10 +reverse10down (Cons bits0) = + let bits1 = swap 5 0o0000077777 bits0 + bits2 = swap 3 0o0007700077 bits1 + in Cons $ swap 1 0o0700707007 bits2 .|. bits1 .&. 0o0070000700 + +reverse11up :: T N11 -> T N11 +reverse11up (Cons bits0) = + let bits1 = swap 1 0o07007007007 bits0 + bits2 = swap 3 0o00077000077 bits1 .|. bits0 .&. 0o00700000700 + in Cons $ swap 6 0o00000077777 bits2 .|. bits0 .&. 0o00000700000 + + +reverse4spread :: T N4 -> T N4 +reverse4spread (Cons bits) = + Cons $ + let full = 0o7777 + in if bits == full + then full + else fromIntegral $ mod ((bits * 0o10000010) .&. 0o7070070700) full +{- +dcba + +0abc d00a bcd0 + |^ ^ ^ ^ +-} + +reverse5spread :: T N5 -> T N5 +reverse5spread (Cons bits) = + Cons $ fromIntegral $ + mod + ((fromIntegral bits * 0o10000000100000001) + .&. 0o70070007007000000700) + (0o777777 :: Word64) +{- + ((fromIntegral bits * 0o_010000_000100_000001) + .&. 0o70 070007 007000 000700) + + edcba + +000abc de000a bcde00 0abcde + |^ ^ ^ ^ ^ +-} + +reverse10spread :: T N10 -> T N10 +reverse10spread = + let full = multiMask 10 + spread = shiftL (replicateOne 5 12) bitsPerNumber + revMask = replicateOne 5 11 * 0o70000700000 + in \(Cons bits) -> + Cons $ + if bits == full + then full + else + fromInteger $ + mod ((toInteger bits * spread) .&. revMask) (toInteger full) +{- + jihgfedcba + +...abcde fghij00abc defghij00a bcdefghij0 + ^ ^ ^ ^ ^ ^ +-} + +reverse10splitSpread :: T N10 -> T N10 +reverse10splitSpread (Cons bits) = + Cons $ + shiftL + (decons $ reverse5spread $ Cons $ bits .&. 0o77777) (5*bitsPerNumber) + .|. + (decons $ reverse5spread $ Cons $ shiftR bits (5*bitsPerNumber)) + + +{-# INLINE multiMask #-} +multiMask :: (Bits a, Integral a) => Int -> a +multiMask n = shiftL 1 (n*bitsPerNumber) - 1 + +{-# INLINE replicateOne #-} +replicateOne :: (Bits a, Integral a) => Int -> Int -> a +replicateOne n k = multiMask (n*k) `div` multiMask k + + + +cons :: Size w -> Word32 -> T w +cons (Size width) bits = Cons $ multiMask width .&. bits + +instance (Nat w) => QC.Arbitrary (T w) where + arbitrary = cons Size.size <$> QC.choose (minBound, maxBound) + shrink = map (cons Size.size) . QC.shrink . decons + +propReverse4 :: T N4 -> Bool +propReverse4 frontier = + reverseGen Size.size frontier == reverse4spread frontier + +propReverse5 :: T N5 -> Bool +propReverse5 frontier = + reverseGen Size.size frontier == reverse5spread frontier + +propReverse6 :: T N6 -> Bool +propReverse6 frontier = + reverseGen Size.size frontier == reverse6up frontier + +propReverse7 :: T N7 -> Bool +propReverse7 frontier = + reverseGen Size.size frontier == reverse7up frontier + +propReverse8 :: T N8 -> Bool +propReverse8 frontier = + reverseGen Size.size frontier == reverse8up frontier + +propReverse9 :: T N9 -> Bool +propReverse9 frontier = + reverseGen Size.size frontier == reverse9up frontier + +propReverse10 :: T N10 -> Bool +propReverse10 frontier = + reverseGen Size.size frontier == reverse10up frontier && + reverseGen Size.size frontier == reverse10down frontier && + reverseGen Size.size frontier == reverse10spread frontier && + reverseGen Size.size frontier == reverse10splitSpread frontier + +-- too big for Word32 +_propReverse11 :: T N11 -> Bool +_propReverse11 frontier = + reverseGen Size.size frontier == reverse11up frontier diff --git a/src/Combinatorics/Battleship/Count/InclusionExclusion.hs b/src/Combinatorics/Battleship/Count/InclusionExclusion.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Count/InclusionExclusion.hs @@ -0,0 +1,338 @@ +module Combinatorics.Battleship.Count.InclusionExclusion where + +import qualified Combinatorics.Battleship.Allocation as Alloc +import qualified Combinatorics.Battleship.Enumeration as BS +import Combinatorics.Battleship (Board(Board), Ship(Ship), Orientation(..), ) + +import Data.List (tails, ) +import Data.Set (Set, ) +import qualified Data.Set as Set +import qualified Data.Ix as Ix + +import Control.Monad (guard, liftM2, liftM3, ) + + +allOverlaps :: Int -> Orientation -> Alloc.T -> [Ship] +allOverlaps size orient set = do + let fatset = Alloc.fatten set + let ((minx,miny),maxc) = Alloc.boundingBox fatset + pos <- + Ix.range $ + (case orient of + Horizontal -> (minx-size+1, miny) + Vertical -> (minx, miny-size+1), + maxc) + let ship = Ship size orient pos + area = BS.shipArea ship + guard $ not $ Set.null $ Set.intersection fatset area + return ship + +allOverlapsHV :: Int -> Alloc.T -> [Ship] +allOverlapsHV size set = + allOverlaps size Horizontal set ++ + allOverlaps size Vertical set + +allOverlapsHVShip :: Int -> Ship -> [Set Ship] +allOverlapsHVShip size ship = + let set = BS.shipArea ship + in map (flip Set.insert (Set.singleton ship)) $ + allOverlaps size Horizontal set ++ + allOverlaps size Vertical set + +allOverlapsHVShips :: Int -> Set Ship -> [Set Ship] +allOverlapsHVShips size ships = + let set = Set.unions $ map BS.shipArea $ Set.toList ships + in map (flip Set.insert ships) $ + allOverlaps size Horizontal set ++ + allOverlaps size Vertical set + +countOverlaps :: (Int, Int) -> Int -> Int -> Orientation -> Integer +countOverlaps bnds size0 size1 orient1 = + sum $ + countMovedOverlaps bnds =<< + (allOverlapsHVShip size0 $ Ship size1 orient1 (0,0)) + +shipsBoxSizes :: Set Ship -> (Int, Int) +shipsBoxSizes = + BS.boxSizes . foldl1 BS.mergeBox . map BS.shipBounds . Set.toList + +countMovedOverlaps :: (Int, Int) -> Set Ship -> [Integer] +countMovedOverlaps (width, height) ovl = do + let (w,h) = shipsBoxSizes ovl + wc = width + 1 - w + hc = height + 1 - h + guard $ wc>=0 && hc>=0 + return $ fromIntegral wc * fromIntegral hc + +count2_3 :: Integer +count2_3 = + let bnds@(w,h) = (6,6) + wh = fromIntegral $ w+h + in (8*wh) * (9*wh) + - countOverlaps bnds 2 3 Horizontal + - countOverlaps bnds 2 3 Vertical + +count4_5 :: Integer +count4_5 = + let bnds = (10, 10) + count size = + sum $ + countMovedOverlaps bnds + =<< map Set.singleton + [Ship size Horizontal (0,0), + Ship size Vertical (0,0)] + in count 4 * count 5 + - countOverlaps bnds 4 5 Horizontal + - countOverlaps bnds 4 5 Vertical + +count4_4 :: Integer +count4_4 = + let w = 10 + h = 10 + bnds = (fromInteger w, fromInteger h) + in div ((w*(h+1-4) + (w+1-4)*h)^(2::Int) + - countOverlaps bnds 4 4 Horizontal + - countOverlaps bnds 4 4 Vertical) 2 + + +overlap :: Ship -> Ship -> Bool +overlap a b = + let (BS.Box a0 (a1x,a1y)) = BS.shipBounds a + (BS.Box b0 (b1x,b1y)) = BS.shipBounds b + (BS.Box (c0x,c0y) (c1x,c1y)) = + BS.intersectBox (BS.Box a0 (a1x+1,a1y+1)) (BS.Box b0 (b1x+1,b1y+1)) + in c0x<=c1x && c0y<=c1y + + +enumerate3_4_5 :: (Int, Int) -> [(Ship, Ship, Ship)] +enumerate3_4_5 (w,h) = + let ships size = + map (Ship size Horizontal) (liftM2 (,) [0..w-size] [0..h-1]) + ++ + map (Ship size Vertical) (liftM2 (,) [0..w-1] [0..h-size]) + in liftM3 (,,) (ships 3) (ships 4) (ships 5) + +enumerateOverlaps3_4_5_pairs :: (Integer, Integer, Integer) +enumerateOverlaps3_4_5_pairs = + let bnds = (6,6) + in (fromIntegral $ length $ + filter (\(_s3,s4,s5) -> overlap s4 s5) $ + enumerate3_4_5 bnds, + fromIntegral $ length $ + filter (\(s3,_s4,s5) -> overlap s3 s5) $ + enumerate3_4_5 bnds, + fromIntegral $ length $ + filter (\(s3,s4,_s5) -> overlap s3 s4) $ + enumerate3_4_5 bnds) + +enumerateOverlaps3_4_5_pairs2 :: (Integer, Integer, Integer) +enumerateOverlaps3_4_5_pairs2 = + let bnds = (6,6) + in (fromIntegral $ length $ + filter (\(s3,s4,s5) -> + overlap s3 s4 && overlap s3 s5) $ + enumerate3_4_5 bnds, + fromIntegral $ length $ + filter (\(s3,s4,s5) -> + overlap s3 s4 && overlap s4 s5) $ + enumerate3_4_5 bnds, + fromIntegral $ length $ + filter (\(s3,s4,s5) -> + overlap s3 s5 && overlap s4 s5) $ + enumerate3_4_5 bnds) + +enumerateOverlaps3_4_5_pairs3 :: Integer +enumerateOverlaps3_4_5_pairs3 = + let bnds = (6,6) + in fromIntegral $ length $ + filter (\(s3,s4,s5) -> + overlap s3 s4 && overlap s4 s5 && overlap s3 s5) $ + enumerate3_4_5 bnds + +enumerateOverlaps3_4_5_noOverlap :: Integer +enumerateOverlaps3_4_5_noOverlap = + let bnds = (6,6) + in fromIntegral $ length $ + filter (\(s3,s4,s5) -> + not (overlap s3 s4 || overlap s4 s5 || overlap s3 s5)) $ + enumerate3_4_5 bnds + +enumerateOverlaps3_4_5_noOverlapTest :: Bool +enumerateOverlaps3_4_5_noOverlapTest = + enumerateOverlaps3_4_5_noOverlap + == + let sum3 (x,y,z) = x+y+z + in fromIntegral (length (enumerate3_4_5 (6,6))) + - + sum3 enumerateOverlaps3_4_5_pairs + + + sum3 enumerateOverlaps3_4_5_pairs2 + - + enumerateOverlaps3_4_5_pairs3 + +enumerateOverlaps3_4_5_triples :: Integer +enumerateOverlaps3_4_5_triples = + let bnds = (6,6) + in (fromIntegral $ length $ + filter (\(s3,s4,s5) -> + overlap s3 s4 && overlap s3 s5 || + overlap s3 s4 && overlap s4 s5 || + overlap s3 s5 && overlap s4 s5) $ + enumerate3_4_5 bnds) + + + +enumerate4_4 :: (Int, Int) -> [(Ship, Ship)] +enumerate4_4 (w,h) = + let ships size = + map (Ship size Horizontal) (liftM2 (,) [0..w-size] [0..h-1]) + ++ + map (Ship size Vertical) (liftM2 (,) [0..w-1] [0..h-size]) + in liftM2 (,) (ships 4) (ships 4) + +enumerateOverlaps4_4_noOverlap :: Integer +enumerateOverlaps4_4_noOverlap = + let bnds = (6,7) + in fromIntegral $ length $ + filter (\(s4a,s4b) -> not (overlap s4a s4b)) $ + enumerate4_4 bnds + + + +{- +This configuration can only be reached in one order: + +<---> + A + | + V + <--> + +In contrast to that, +the following configuration can be reached in more than one order: + +<---> + A<--> + | + V + +Thus we have to check for duplicates manually. +-} +count3_4_5test :: (Integer, Integer, Integer) +count3_4_5test = + let bnds = (6,6) + ov3_4 = allOverlapsHVShip 3 $ Ship 4 Horizontal (0,0) + ov3_5 = allOverlapsHVShip 3 $ Ship 5 Horizontal (0,0) + ov4_5 = allOverlapsHVShip 4 $ Ship 5 Horizontal (0,0) + in (sum (countMovedOverlaps bnds =<< allOverlapsHVShips 3 =<< ov4_5), + sum (countMovedOverlaps bnds =<< allOverlapsHVShips 4 =<< ov3_5), + sum (countMovedOverlaps bnds =<< allOverlapsHVShips 5 =<< ov3_4)) + +count3_4_5overlaps :: (Int, Int) -> Integer +count3_4_5overlaps bnds = + let ov3_5 = allOverlapsHVShip 3 $ Ship 5 Horizontal (0,0) + ov4_5 = allOverlapsHVShip 4 $ Ship 5 Horizontal (0,0) + in sum $ concatMap (countMovedOverlaps bnds) $ + Set.toList $ Set.fromList $ + (allOverlapsHVShips 3 =<< ov4_5) ++ + (allOverlapsHVShips 4 =<< ov3_5) + +normalize :: Set Ship -> Set Ship +normalize ss = + let (BS.Box (dx,dy) _) = + foldl1 BS.mergeBox . map BS.shipBounds . Set.toList $ ss + in Set.map (BS.moveShip (-dx,-dy)) ss + +count3_4_5overlaps2 :: (Int, Int) -> Integer +count3_4_5overlaps2 bnds = + let ships size = + map (\orient -> Ship size orient (0,0)) [Horizontal, Vertical] + ov3_4 = allOverlapsHVShip 3 =<< ships 4 + ov3_5 = allOverlapsHVShip 3 =<< ships 5 + ov4_5 = allOverlapsHVShip 4 =<< ships 5 + in sum $ concatMap (countMovedOverlaps bnds) $ + Set.toList $ Set.fromList $ map normalize $ concat $ + [allOverlapsHVShips 3 =<< ov4_5, + allOverlapsHVShips 4 =<< ov3_5, + allOverlapsHVShips 5 =<< ov3_4] + +count3_4_5overlapsTestA :: Bool +count3_4_5overlapsTestA = + count3_4_5overlaps2 (6,6) == 2 * count3_4_5overlaps (6,6) + +count3_4_5overlapsTestB :: Bool +count3_4_5overlapsTestB = + count3_4_5overlaps2 (6,6) == enumerateOverlaps3_4_5_triples + +count3_4_5_ov2 :: (Integer, Integer, Integer) +count3_4_5_ov2 = + let bnds = (6,6) + ov4_5 = allOverlapsHVShip 4 $ Ship 5 Horizontal (0,0) + ov3_5 = allOverlapsHVShip 3 $ Ship 5 Horizontal (0,0) + ov3_4 = allOverlapsHVShip 3 $ Ship 4 Horizontal (0,0) + in (sum (countMovedOverlaps bnds =<< ov4_5), + sum (countMovedOverlaps bnds =<< ov3_5), + sum (countMovedOverlaps bnds =<< ov3_4)) + +count3_4_5_ov2mult :: (Integer, Integer, Integer) +count3_4_5_ov2mult = + let n = 6 + bnds = (fromIntegral n, fromIntegral n) + ov4_5 = allOverlapsHVShip 4 $ Ship 5 Horizontal (0,0) + ov3_5 = allOverlapsHVShip 3 $ Ship 5 Horizontal (0,0) + ov3_4 = allOverlapsHVShip 3 $ Ship 4 Horizontal (0,0) + in (sum (countMovedOverlaps bnds =<< ov4_5) * 2*n*(n+1-3) * 2, + sum (countMovedOverlaps bnds =<< ov3_5) * 2*n*(n+1-4) * 2, + sum (countMovedOverlaps bnds =<< ov3_4) * 2*n*(n+1-5) * 2) + +count3_4_5_ov2multTest :: Bool +count3_4_5_ov2multTest = + count3_4_5_ov2mult == enumerateOverlaps3_4_5_pairs + +count3_4_5overlaps3 :: (Int, Int) -> Integer +count3_4_5overlaps3 bnds = + let makeShips size = + map (\orient -> Ship size orient (0,0)) [Horizontal, Vertical] + ov3_4 = allOverlapsHVShip 3 =<< makeShips 4 + ov3_5 = allOverlapsHVShip 3 =<< makeShips 5 + ov4_5 = allOverlapsHVShip 4 =<< makeShips 5 + coeff ships = + (\n -> + case length n of + 2 -> 1 + 3 -> 2 + _ -> error "impossible length of list") $ + do (s0:ss) <- tails ships + s1 <- ss + guard $ overlap s0 s1 + return () + in sum $ + concatMap + (\ships -> + fmap (coeff (Set.toList ships) *) $ + countMovedOverlaps bnds ships) $ + Set.toList $ Set.fromList $ map normalize $ concat $ + [allOverlapsHVShips 3 =<< ov4_5, + allOverlapsHVShips 4 =<< ov3_5, + allOverlapsHVShips 5 =<< ov3_4] + +count3_4_5 :: Integer +count3_4_5 = + let n = 10 + bnds = (fromIntegral n, fromIntegral n) + ov3_4 = allOverlapsHVShip 3 $ Ship 4 Horizontal (0,0) + ov3_5 = allOverlapsHVShip 3 $ Ship 5 Horizontal (0,0) + ov4_5 = allOverlapsHVShip 4 $ Ship 5 Horizontal (0,0) + in (2*n*(n+1-5)) * (2*n*(n+1-4)) * (2*n*(n+1-3)) + - 2 * (sum (countMovedOverlaps bnds =<< ov3_4) * (2*n*(n+1-5)) + + sum (countMovedOverlaps bnds =<< ov3_5) * (2*n*(n+1-4)) + + sum (countMovedOverlaps bnds =<< ov4_5) * (2*n*(n+1-3))) + + count3_4_5overlaps3 bnds + + +main :: IO () +main = + mapM_ (putStrLn . BS.formatBoard . + (\(Board bnds field) -> Board bnds $ Alloc.normalize field) . + BS.boardFromShips (10,10) . Set.toList) $ + allOverlapsHVShip 4 $ Ship 5 Vertical (0,0) diff --git a/src/Combinatorics/Battleship/Count/ShortenShip.hs b/src/Combinatorics/Battleship/Count/ShortenShip.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Count/ShortenShip.hs @@ -0,0 +1,782 @@ +{- | +In this approach I construct the board row by row from the bottom to the top. +In every step I maintain the necessary information +in order to know, what ships and positions and orientations +are allowed in the next row. +This information is stored in the Frontier. + +possible optimization: + "meet in the middle" + compute counts for 5x10 boards and put them together, + problem: + for a given frontier there are many other half boards that may match +-} +module Combinatorics.Battleship.Count.ShortenShip where + +import qualified Combinatorics.Battleship.Count.CountMap as CountMap +import qualified Combinatorics.Battleship.Count.Counter as Counter +import qualified Combinatorics.Battleship.Count.Frontier as Frontier +import qualified Combinatorics.Battleship.Fleet as Fleet +import qualified Combinatorics.Battleship.Size as Size +import Combinatorics.Battleship.Size (Nat, Size(Size), n6, n8, n10, ) + +import qualified Control.Monad.Trans.State.Strict as MS +import Control.Monad (when, guard, zipWithM_, forM_, ) +import Control.Applicative (Alternative, (<|>), ) + +import Foreign.Storable (Storable, ) +import Data.Word (Word64, ) + +import qualified Data.Map as Map +import qualified Data.List.Match as Match +import qualified Data.List.HT as ListHT +import qualified Data.Foldable as Fold +import Data.Map (Map, ) +import Data.Monoid (mappend, ) +import Data.Tuple.HT (mapFst, mapSnd, ) + +import Data.Function.HT (nest, ) +import Data.List (intercalate, ) +import Text.Printf (printf, ) + +import qualified Test.QuickCheck.Monadic as QCM +import qualified Test.QuickCheck as QC + + +type Count = Counter.Composed Word64 Word64 +type CountMap w = CountMap.T w Count +type CountMapPath w = CountMap.Path w Count +-- type Count = Integer +-- type CountMap w = Map (CountMap.Key w) Count + + +-- * count all possible fleets on a board with given width + +baseCase :: Size w -> CountMap w +baseCase _size = + CountMap.singleton (Frontier.empty, Fleet.empty) Counter.one + +asumTakeFrontier :: + (Nat w, Alternative f) => + Frontier.T w -> Frontier.Position -> Size w -> [f a] -> f a +asumTakeFrontier frontier pos (Size size) = + Fold.asum . Match.take (takeWhile (Frontier.isFree frontier) [pos .. size-1]) + +widthRange :: (Nat w) => Size w -> [Int] +widthRange (Size size) = take size [0 ..] + +atEnd :: Size w -> Int -> Bool +atEnd (Size size) pos = pos>=size + +maxShipSize :: Fleet.ShipSize +maxShipSize = min Fleet.maxSize Frontier.maxShipSize + + +guardCumulativeSubset :: Fleet.T -> MS.StateT (Frontier.T w, Fleet.T) [] () +guardCumulativeSubset cumMaxFleet = do + (frontier, fleet) <- MS.get + guard $ + Fleet.subset + (Fleet.cumulate $ addFrontierFleet frontier fleet) + cumMaxFleet + +newShip :: + Fleet.T -> Fleet.T -> + Fleet.ShipSize -> MS.StateT (Frontier.T w, Fleet.T) [] () +newShip cumMaxFleet maxFleet shipSize = do + MS.modify $ mapSnd $ Fleet.inc shipSize + guard . flip Fleet.subset maxFleet =<< MS.gets snd + guardCumulativeSubset cumMaxFleet + +insertVertical :: + (Nat w) => + Fleet.T -> Int -> + Frontier.Position -> MS.StateT (Frontier.T w, Fleet.T) [] () +insertVertical cumMaxFleet n pos = do + MS.modify $ mapFst $ Frontier.insertNew pos (Frontier.Vertical n) + guardCumulativeSubset cumMaxFleet + + +{- | +In this approach, the fleet contains all ships +also the ones at the frontier. +-} +nextFrontier :: (Nat w) => Size w -> CountMap w -> CountMap w +nextFrontier width = + CountMap.mergeMany . + map + (\((frontier,fleet), cnt) -> + CountMap.fromList $ + map (flip (,) cnt) $ mergeSymmetricFrontiers $ + map (mapFst (Frontier.dilate width)) $ + transitionFrontier width frontier fleet) . + CountMap.toAscList + +transitionFrontier :: + (Nat w) => Size w -> Frontier.T w -> Fleet.T -> [(Frontier.T w, Fleet.T)] +transitionFrontier width oldFrontier = + let go pos = + when (not $ atEnd width pos) $ do + let insertVert n = + MS.modify $ mapFst $ + Frontier.insertNew pos (Frontier.Vertical n) + let updateFleet = MS.modify . mapSnd + (frontier,fleet) <- MS.get + case Frontier.lookup oldFrontier pos of + Frontier.Blocked -> go (pos+1) + Frontier.Vertical n -> + go (pos+2) + <|> + (do guard (n < maxShipSize) + insertVert (n+1) + updateFleet (Fleet.inc (n+1) . Fleet.dec n) + go (pos+2)) + Frontier.Free -> + go (pos+1) + <|> + (do insertVert 1 + updateFleet (Fleet.inc 1) + go (pos+2)) + <|> + (asumTakeFrontier oldFrontier pos width $ + zipWith3 + (\newPos shipSize newFrontierUpdate -> do + MS.put (newFrontierUpdate, fleet) + updateFleet (Fleet.inc shipSize) + go newPos) + [pos+2 ..] + [1 .. Fleet.maxSize] + (tail $ + scanl + (flip (Frontier.blockBounded width)) + frontier [pos ..])) + in MS.execStateT (go 0) . (,) Frontier.empty + + +count :: (Nat w) => (Size w, Int) -> Fleet.T -> Count +count (width,height) reqFleet = + Counter.sum $ + map snd $ + filter (\((_front,fleet), _) -> fleet == reqFleet) $ + CountMap.toAscList $ + nest height (nextFrontier width) $ baseCase width + + +-- * count fleets with an upper bound + +{- | +Here we save memory and speed up the computation in the following way: +We stop searching deeper if + +1. the fleet becomes larger than the requested fleet + ("larger" means, that for at least one ship size + the number of ships is larger than in the requested fleet) + +2. the cumulated fleet becomes larger than the cumulated requested fleet + This is necessary, since we do not know the final length + of the vertical ships at the frontier. + +In this approach, +the fleet does not contain the vertical ships at the frontier. +-} +nextFrontierBounded :: (Nat w) => Size w -> Fleet.T -> CountMap w -> CountMap w +nextFrontierBounded width maxFleet = +-- foldMap is not efficient enough +-- foldl mappend mempty . -- not efficient enough + CountMap.mergeMany . + map + (\((frontier,fleet), cnt) -> + CountMap.fromList $ + map (flip (,) cnt) $ mergeSymmetricFrontiers $ + map (mapFst (Frontier.dilate width)) $ + transitionFrontierBounded width maxFleet frontier fleet) . + CountMap.toAscList + +nextFrontierBoundedExternal :: + (Nat w) => Size w -> Fleet.T -> CountMapPath w -> CountMap w -> IO () +nextFrontierBoundedExternal width maxFleet path = + CountMap.writeSorted path . + map + (concatMap + (\((frontier,fleet), cnt) -> + map (flip (,) cnt) $ mergeSymmetricFrontiers $ + map (mapFst (Frontier.dilate width)) $ + transitionFrontierBounded width maxFleet frontier fleet)) . + ListHT.sliceVertical bucketSize . + CountMap.toAscList + +transitionFrontierBounded :: + (Nat w) => + Size w -> Fleet.T -> Frontier.T w -> Fleet.T -> + [(Frontier.T w, Fleet.T)] +transitionFrontierBounded width maxFleet oldFrontier = + let cumMaxFleet = Fleet.cumulate maxFleet + go pos = + when (not $ atEnd width pos) $ do + (frontier,fleet) <- MS.get + case Frontier.lookup oldFrontier pos of + Frontier.Blocked -> go (pos+1) + Frontier.Vertical n -> + (newShip cumMaxFleet maxFleet n + <|> + (guard (n < maxShipSize) >> + insertVertical cumMaxFleet (n+1) pos) + >> + go (pos+2)) + Frontier.Free -> + go (pos+1) + <|> + (insertVertical cumMaxFleet 1 pos >> go (pos+2)) + <|> + (asumTakeFrontier oldFrontier pos width $ + zipWith3 + (\newPos shipSize frontierUpdate -> do + MS.put (frontierUpdate,fleet) + newShip cumMaxFleet maxFleet shipSize + go newPos) + [pos+2 ..] + [1 .. Fleet.maxSize] + (tail $ + scanl + (flip (Frontier.blockBounded width)) + frontier [pos ..])) + in MS.execStateT (go 0) . (,) Frontier.empty + + +countBounded :: (Nat w) => (Size w, Int) -> Fleet.T -> Count +countBounded (width,height) reqFleet = + countBoundedFromMap reqFleet $ + nest height (nextFrontierBounded width reqFleet) $ baseCase width + + +{- | +This solves a different problem. +In this variant the ships are allowed to touch each other. +-} +nextFrontierTouching :: (Nat w) => Size w -> Fleet.T -> CountMap w -> CountMap w +nextFrontierTouching width maxFleet = + CountMap.mergeMany . + map + (\((frontier,fleet), cnt) -> + CountMap.fromList $ + map (flip (,) cnt) $ mergeSymmetricFrontiers $ + transitionFrontierTouching width maxFleet frontier fleet) . + CountMap.toAscList + +nextFrontierTouchingExternal :: + (Nat w) => Size w -> Fleet.T -> CountMapPath w -> CountMap w -> IO () +nextFrontierTouchingExternal width maxFleet path = + CountMap.writeSorted path . + map + (concatMap + (\((frontier,fleet), cnt) -> + map (flip (,) cnt) $ mergeSymmetricFrontiers $ + transitionFrontierTouching width maxFleet frontier fleet)) . + ListHT.sliceVertical bucketSize . + CountMap.toAscList + +transitionFrontierTouching :: + (Nat w) => + Size w -> Fleet.T -> Frontier.T w -> Fleet.T -> [(Frontier.T w, Fleet.T)] +transitionFrontierTouching width maxFleet oldFrontier = + let cumMaxFleet = Fleet.cumulate maxFleet + finishVerticals pos = + case Frontier.lookup oldFrontier pos of + Frontier.Blocked -> + error "in touching mode there must be no blocked fields" + Frontier.Vertical n -> + (guard (n < maxShipSize) >> + insertVertical cumMaxFleet (n+1) pos) + <|> + newShip cumMaxFleet maxFleet n + Frontier.Free -> return () + + startNewShips pos = + when (not $ atEnd width pos) $ do + frontier <- MS.gets fst + case Frontier.lookup frontier pos of + Frontier.Blocked -> + error "finishVerticals must not block fields" + Frontier.Vertical _ -> + startNewShips (pos+1) + Frontier.Free -> + startNewShips (pos+1) + <|> + (insertVertical cumMaxFleet 1 pos >> startNewShips (pos+1)) + <|> + (asumTakeFrontier frontier pos width $ + map + (\shipSize -> + newShip cumMaxFleet maxFleet shipSize >> + startNewShips (pos+shipSize)) $ + [1 .. Fleet.maxSize]) + + in \fleet -> flip MS.execStateT (Frontier.empty, fleet) $ do + mapM_ finishVerticals (widthRange width) + startNewShips 0 + +countTouching :: (Nat w) => (Size w, Int) -> Fleet.T -> Count +countTouching (width,height) reqFleet = + countBoundedFromMap reqFleet $ + nest height (nextFrontierTouching width reqFleet) $ baseCase width + +canonicalFrontier :: (Nat w) => Frontier.T w -> Frontier.T w +canonicalFrontier fr = min fr (Frontier.reverse fr) + +mergeSymmetricFrontiers :: + (Nat w) => [(Frontier.T w, fleet)] -> [(Frontier.T w, fleet)] +mergeSymmetricFrontiers = map (mapFst canonicalFrontier) + + +fleetAtFrontier :: Frontier.T w -> Fleet.T +fleetAtFrontier = + Frontier.foldMap + (\use -> + case use of + Frontier.Vertical n -> Fleet.singleton n 1 + _ -> Fleet.empty) + + +addFrontierFleet :: Frontier.T w -> Fleet.T -> Fleet.T +addFrontierFleet frontier = mappend $ fleetAtFrontier frontier + + +-- * retrieve counts from count maps + +{-# SPECIALISE countBoundedFromMap :: Fleet.T -> CountMap w -> Count #-} +countBoundedFromMap :: + (Counter.C a, Storable a) => Fleet.T -> CountMap.T w a -> a +countBoundedFromMap reqFleet = + Counter.sum . + map snd . + filter (\((front,fleet), _) -> + addFrontierFleet front fleet == reqFleet) . + CountMap.toAscList + +countBoundedFleetsFromMap :: CountMap w -> Map Fleet.T Integer +countBoundedFleetsFromMap = + Map.fromListWith (+) . + map (\((front,fleet), cnt) -> + (addFrontierFleet front fleet, + Counter.toInteger cnt)) . + CountMap.toAscList + +{- +maybe this is not lazy enough and thus requires to much memory at once +-} +countBoundedFleetsFromMap_ :: CountMap w -> Map Fleet.T Integer +countBoundedFleetsFromMap_ = + Map.mapKeysWith (+) (uncurry addFrontierFleet) . + fmap Counter.toInteger . + CountMap.toMap + + +{- +*ShortenShip> let height=3::Int; width=10::Int; reqFleet = Fleet.fromList [(2,3),(3,1)] +(0.01 secs, 524480 bytes) + +*ShortenShip> let counts = nest height (nextFrontier width) $ baseCase width in (Map.size counts, Fold.sum counts, Fold.maximum counts) +(658486,37986080,16640) +(77.32 secs, 9147062872 bytes) + +*ShortenShip> let counts = nest height (nextFrontierBounded width reqFleet) $ baseCase width in (Map.size counts, Fold.sum counts, Fold.maximum counts) +(59485,870317,2295) +(41.05 secs, 4961028184 bytes) + +This was computed, where we marked horizontal ships +instead of blocked columns. + +*ShortenShip> let width=10::Int; reqFleet = Fleet.german +*ShortenShip> map Map.size $ iterate (nextFrontierBounded width reqFleet) $ baseCase width +[1,976,9441,129247,727781,Interrupted. + +Here we switched to blocked columns and thus could merge some cases. +*ShortenShip> map Map.size $ iterate (nextFrontierBounded width reqFleet) $ baseCase width +[1,762,8712,110276,671283,Heap exhausted + +Now merge symmetric cases. +*ShortenShip> map Map.size $ iterate (nextFrontierBounded width reqFleet) $ baseCase width +[1,400,4209,53897,331185,Heap exhausted + +Now correctly stop searching, when we exceed the requested fleet +in a cumulative way. +*ShortenShip> map Map.size $ iterate (nextFrontierBounded width reqFleet) $ baseCase width +[1,400,2780,33861,156962,596354,1078596, +-} + + +countSingleKind :: IO () +countSingleKind = + mapM_ + (print . countBounded (n10,10) . Fleet.fromList . (:[])) + [(5,1), (4,2), (3,3), (2,4)] + +{- | +-} +count8x8 :: IO () +count8x8 = +{- + print $ countTouching (n8,8) Fleet.english +-} + let reqFleet = Fleet.english + width = n8 + height = 8 + in reportCounts + (baseCase width) (nextFrontierTouchingExternal width) + height reqFleet + +{- +0 +0 +0 +24348 +712180 +8705828 +50637316 +193553688 +571126760 +-} + +countTouchingExternalReturn :: + Nat w => (Size w, Int) -> Fleet.T -> IO Count +countTouchingExternalReturn (width, height) = + countExternalGen (baseCase width) (nextFrontierTouchingExternal width) height + + +{- | +http://mathoverflow.net/questions/8374/battleship-permutations +-} +count10x10 :: IO () +count10x10 = + print $ countBounded (n10,10) Fleet.english + +{- +width = 10 +reqFleet = Fleet.english + +0 (height 0) +0 +0 +28 +3216 +665992 +7459236 +49267288 +212572080 +703662748 +1925751392 (height 10) +4558265312 +9655606528 +-} + + +countStandard :: IO () +countStandard = + let -- reqFleet = Fleet.german + reqFleet = Fleet.english + -- reqFleet = Fleet.fromList [(5,3), (3,3), (2,4)] + -- reqFleet = Fleet.fromList [(5,1), (4,5), (2,4)] + -- reqFleet = Fleet.fromList [(5,1), (4,2), (3,7)] + -- reqFleet = Fleet.fromList [(5,1), (4,2), (3,3)] + width = n10 + height = 12 + in mapM_ (print . countBoundedFromMap reqFleet) $ + take (height+1) $ + iterate (nextFrontierBounded width reqFleet) $ + baseCase width + +{- +width = 8 + +0 (height 0) +0 +0 +0 +0 +0 +0 +0 +0 +41590204 +7638426604 (height 10) +362492015926 +7519320122520 +-} + +{- +width = 9 + +0 (height 0) +0 +0 +0 +0 +0 +0 +3436 +41590204 (height 8) +14057667720 +810429191552 +19372254431062 +259204457356150 (height 12) +-} + +bucketSize :: Int +bucketSize = 2^(14::Int) + +tmpPath :: Int -> CountMap.Path w a +tmpPath = CountMap.Path . printf "/tmp/battleship%02d" + +writeTmpCountMap :: Int -> CountMap w -> IO () +writeTmpCountMap = CountMap.writeFile . tmpPath + +writeTmps :: IO () +writeTmps = + let width = n10 + in zipWithM_ writeTmpCountMap [0 ..] $ + iterate (nextFrontierBounded width Fleet.german) $ + baseCase width + + +countExternalGen :: + (Counter.C a, Storable a) => + CountMap w -> + (Fleet.T -> CountMap.Path w a -> CountMap.T w a -> IO ()) -> + Int -> Fleet.T -> IO a +countExternalGen base next height fleet = do + writeTmpCountMap 0 base + let pathPairs = ListHT.mapAdjacent (,) $ map tmpPath [0 .. height] + forM_ pathPairs $ \(src,dst) -> + next fleet dst =<< CountMap.readFile src + fmap (countBoundedFromMap fleet) $ CountMap.readFile $ tmpPath height + +countExternalReturn :: + Nat w => (Size w, Int) -> Fleet.T -> IO Count +countExternalReturn (width, height) = + countExternalGen (baseCase width) (nextFrontierBoundedExternal width) height + +reportCounts :: + (Counter.C a, Storable a, Show a) => + CountMap w -> + (Fleet.T -> CountMap.Path w a -> CountMap.T w a -> IO ()) -> + Int -> Fleet.T -> IO () +reportCounts base next height fleet = do + writeTmpCountMap 0 base + let pathPairs = ListHT.mapAdjacent (,) $ map tmpPath [0 .. height] + forM_ pathPairs $ \(src,dst) -> do + next fleet dst =<< CountMap.readFile src + print . countBoundedFromMap fleet =<< CountMap.readFile dst + +countExternal :: IO () +countExternal = + let width = n10 + height = 10 + in reportCounts + (baseCase width) (nextFrontierBoundedExternal width) + height Fleet.german + +{- +width = 10 + +0 (height 6) +13662566 +7638426604 +810429191552 +26509655816984 (height 10) +430299058359872 +4354180199012068 +31106813918568460 +170879359784006832 +764137344189527328 (height 15) +2898295265655126580 +9610725684470910308 +28507470306925125256 +76991108526373642970 +191979866440965078136 (height 20) +446937970915638578082 +980266021942073496100 +2040665261937921277448 +4057034306861698428948 +7742825845480094358032 +14247628010376642047600 +25372084886315737302592 +43866177282362611934648 +73835392689835032947938 +121284466564264656560792 (height 30) +194834219987709759902080 +306653595670979763499532 +473656349424114922202508 +719020031938684168649088 +1074093940268573906015112 +1580772674048252559547360 +2294422842530289843193622 +3287462379238476844672168 +4653704875700525771264888 +6513595388626319121164932 (height 40) +9020479350315319743053840 +12368062564291338311417712 +16799237841455675768629728 +22616472670702007858720088 +30193972466229549593717002 +39991855436006321943166520 +52572598016253033812617552 +68620034159721482069184188 +88961217595210753573463188 +114591483536481178478783072 (height 50) +146703075254771226052685400 +186717731484777645553381392 +236323662853505427847380798 +297517379449112891075247688 +372650867327049668352192392 +464484649227692889820652980 +576247304097610697944846232 +711702061209803706344169808 +875221127811075401295007088 +1071868454331343083880616712 (height 60) +1307491688314503052228073010 +1588824117417688619931354072 +1923597453119688551212343968 +2320666360224207858208417388 +2790145692883833943588101532 +3343561455750300075076754240 +3994016569020196440013951912 +4756372578636947840355038528 +5647448517773937744162740838 +6686238193004392201202597352 (height 70) +7894147238305325350349872920 +9295251352289772187727329252 +10916577208857975219414387488 +12788407608848430883790544688 +14944612520298020488691084672 +17423007737631130160152847800 +20265742975534986235203786842 +23519721301486677943493929848 +27237051901920789404168888688 +31475538270909499207841886492 (height 80) +36299204007013709451418121380 +41778858503698518338457830432 +47992704921433432642323359608 +55026992935361409746132575088 +62976718861265404915127762062 +71946375874530859216057441160 +82050757151941778367149983272 +93415814884501004073824213268 +106179578231076248372025054888 +120493133407586729455583375632 (height 90) +136521669234705095698870234640 +154445591598700034393838411112 +174461710415130814393910088578 +196784502823670288688670584088 +221647456484421865215555733952 +249304496991752923240266671820 +280031503570936389699101953452 +314127917375817976286354988288 +351918446862353195080976223688 +393754874873229999431436186272 (height 100) + +real 80m24.600s +user 76m33.675s +sys 2m22.601s +-} + +countFleets :: IO () +countFleets = + Fold.mapM_ putStrLn . + Map.mapWithKey + (\fleet cnt -> + "|-\n| " ++ + intercalate " || " + (map ((\n -> if n==0 then " " else show n) . Fleet.lookup fleet) [2..5] + ++ [show cnt])) . + Map.filterWithKey (\fleet _cnt -> Fleet.subset fleet Fleet.german) . + countBoundedFleetsFromMap =<< + CountMap.readFile (tmpPath 10) + + +printMapSizes :: IO () +printMapSizes = + mapM_ (print . CountMap.size) $ + iterate (nextFrontierBounded n10 Fleet.german) $ + baseCase n10 + + + +genShip :: QC.Gen Fleet.ShipSize +genShip = QC.choose (1, maxShipSize) + +genFleet :: QC.Gen Fleet.T +genFleet = fmap Fleet.fromSizes $ flip QC.vectorOf genShip =<< QC.choose (0,4) + +propCountSymmetry :: QC.Property +propCountSymmetry = + QC.forAllShrink genFleet QC.shrink $ \fleet -> + let d = + {- + A single square is moved by any rotation or reflection. + Two squares can have one symmetry. + -} + case mod (sum $ map (uncurry (*)) $ Fleet.toList fleet) 4 of + 0 -> 1 + 2 -> 2 + _ -> + {- + If there is an odd sized ship without a partner + then there are no symmetries. + -} + if any odd $ map (uncurry (*)) $ Fleet.toList fleet + then 8 + else 4 + in mod (Counter.toInteger $ countBounded (n6,6) fleet) d == 0 + +propCountTransposed :: QC.Property +propCountTransposed = + QC.forAllShrink (QC.choose (0,4)) QC.shrink $ \width -> + QC.forAllShrink (QC.choose (0,8)) QC.shrink $ \height -> + QC.forAllShrink genFleet QC.shrink $ \fleet -> + Size.reifyInt width $ \w -> + Size.reifyInt height $ \h -> + countBounded (w,height) fleet == countBounded (h,width) fleet + +propCountBounded :: QC.Property +propCountBounded = + QC.forAllShrink (QC.choose (0,4)) QC.shrink $ \width -> + QC.forAllShrink (QC.choose (0,10)) QC.shrink $ \height -> + QC.forAllShrink genFleet QC.shrink $ \fleet -> + Size.reifyInt width $ \w -> + count (w,height) fleet == countBounded (w,height) fleet + +propCountTouchingTransposed :: QC.Property +propCountTouchingTransposed = + QC.forAllShrink (QC.choose (0,4)) QC.shrink $ \width -> + QC.forAllShrink (QC.choose (0,6)) QC.shrink $ \height -> + Size.reifyInt width $ \w -> + Size.reifyInt height $ \h -> + QC.forAllShrink genFleet QC.shrink $ \fleet -> + countTouching (w,height) fleet == countTouching (h,width) fleet + +propCountMoreTouching :: QC.Property +propCountMoreTouching = + QC.forAllShrink (QC.choose (0,6)) QC.shrink $ \width -> + QC.forAllShrink (QC.choose (0,10)) QC.shrink $ \height -> + QC.forAllShrink genFleet QC.shrink $ \fleet -> + Size.reifyInt width $ \w -> + countBounded (w,height) fleet <= countTouching (w,height) fleet + + +propCountExternal :: QC.Property +propCountExternal = + QC.forAllShrink (QC.choose (0,4)) QC.shrink $ \width -> + QC.forAllShrink (QC.choose (0,10)) QC.shrink $ \height -> + QC.forAllShrink genFleet QC.shrink $ \fleet -> + Size.reifyInt width $ \w -> QCM.monadicIO $ do + c <- QCM.run $ countExternalReturn (w,height) fleet + QCM.assert $ count (w,height) fleet == c + +propCountTouchingExternal :: QC.Property +propCountTouchingExternal = + QC.forAllShrink (QC.choose (0,4)) QC.shrink $ \width -> + QC.forAllShrink (QC.choose (0,10)) QC.shrink $ \height -> + QC.forAllShrink genFleet QC.shrink $ \fleet -> + Size.reifyInt width $ \w -> QCM.monadicIO $ do + c <- QCM.run $ countTouchingExternalReturn (w,height) fleet + QCM.assert $ countTouching (w,height) fleet == c diff --git a/src/Combinatorics/Battleship/Count/ShortenShip/Distribution.hs b/src/Combinatorics/Battleship/Count/ShortenShip/Distribution.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Count/ShortenShip/Distribution.hs @@ -0,0 +1,247 @@ +module Combinatorics.Battleship.Count.ShortenShip.Distribution where + +import qualified Combinatorics.Battleship.Count.ShortenShip as ShortenShip +import qualified Combinatorics.Battleship.Count.CountMap as CountMap +import qualified Combinatorics.Battleship.Count.Counter as Counter +import qualified Combinatorics.Battleship.Count.Frontier as Frontier +import qualified Combinatorics.Battleship.Fleet as Fleet +import qualified Combinatorics.Battleship.Size as Size +import Combinatorics.Battleship.Size (Nat, Zero, Succ, N10, Size(Size), size) +import Combinatorics.Battleship.Count.ShortenShip (countBoundedFromMap) + +import Foreign.Storable (Storable, sizeOf, alignment, poke, peek) +import Foreign.Ptr (Ptr, castPtr) + +import Control.Monad.HT (void) +import Control.Monad (when) +import Control.Applicative ((<$>)) +import Control.DeepSeq (NFData, rnf, ($!!)) + +import qualified Data.StorableVector as SV +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Tuple.HT (mapFst) +import Data.Word (Word64) + +import qualified Test.QuickCheck.Monadic as QCM +import qualified Test.QuickCheck as QC + + +{- | +We need to encode the height in the type +since the Storable instance requires that the size of the binary data +can be infered from the Distribution type. +-} +newtype Distr w h a = Distr {getDistr :: SV.Vector a} + +instance (Storable a) => NFData (Distr w h a) where + rnf = rnf . getDistr + +countFromDistr :: (Storable a) => Distr w h a -> a +countFromDistr = SV.head . getDistr + +rowsFromDistr :: (Storable a) => Size w -> Distr w h a -> [Row w a] +rowsFromDistr (Size width) = + map Row . SV.sliceVertical width . SV.tail . getDistr + +heightType :: Size h -> Distr w h a -> Distr w h a +heightType _ = id + + +newtype Size2 w h = Size2 Int + +size2FromSizes :: Size w -> Size h -> Size2 w h +size2FromSizes (Size width) (Size height) = Size2 (1 + width*height) + +size2 :: (Nat w, Nat h) => Size2 w h +size2 = size2FromSizes size size + + +instance (Nat w, Nat h, Storable a) => Storable (Distr w h a) where + sizeOf = sizeOfWithSize size2 + alignment (Distr xs) = alignment (SV.head xs) + poke ptr (Distr xs) = SV.poke (castPtr ptr) xs + peek = peekWithSize size2 + +-- not correct if padding is needed +sizeOfWithSize :: (Storable a) => Size2 w h -> Distr w h a -> Int +sizeOfWithSize (Size2 n) (Distr xs) = n * sizeOf (SV.head xs) + +peekWithSize :: + (Storable a) => Size2 w h -> Ptr (Distr w h a) -> IO (Distr w h a) +peekWithSize (Size2 n) ptr = fmap Distr $ SV.peek n (castPtr ptr) + +instance + (Nat w, Nat h, Counter.C a, Storable a) => Counter.C (Distr w h a) where + zero = constant size2 Counter.zero + one = constant size2 Counter.one + add (Distr x) (Distr y) = Distr $ SV.zipWith Counter.add x y + +constant :: (Storable a) => Size2 w h -> a -> Distr w h a +constant (Size2 n) = Distr . SV.replicate n + + +newtype Row w a = Row {getRow :: SV.Vector a} + +avg :: (Integral a) => a -> a -> a +avg x y = + case divMod (x+y) 2 of + (z,0) -> z + _ -> error "avg: odd sum" + +symmetric :: (Integral a, Storable a) => Row w a -> Row w a +symmetric (Row xs) = Row $ SV.zipWith avg xs (SV.reverse xs) + + +type Count = Word64 +type CountMap = CountMap.T Count + +{-# SPECIALISE + CountMap.mergeMany :: [CountDistrMap N10 Zero] -> CountDistrMap N10 Zero + #-} + +type CountDistr w h = Distr w h Count +type CountDistrMap w h = CountMap.T w (CountDistr w h) +type CountDistrPath w h = CountMap.Path w (CountDistr w h) + + +rowFromFrontier :: (Nat w) => Size w -> Count -> Frontier.T w -> Row w Count +rowFromFrontier width cnt = + Row . + Frontier.mapToVector width (\x -> if x == Frontier.Free then 0 else cnt) + +addRowToDistr :: Row w Count -> CountDistr w h -> CountDistr w (Succ h) +addRowToDistr (Row row) (Distr xs) = + Distr $ SV.concat [SV.take 1 xs, row, SV.tail xs] + +addFrontierToDistr :: + (Nat w) => Frontier.T w -> CountDistr w h -> CountDistr w (Succ h) +addFrontierToDistr frontier cntDistr = + addRowToDistr (rowFromFrontier size (countFromDistr cntDistr) frontier) cntDistr + + +baseCase :: (Nat w) => CountDistrMap w Zero +baseCase = CountMap.singleton (Frontier.empty, Fleet.empty) Counter.one + +nextFrontierBoundedExternal :: + (Nat w, Nat h) => + Size w -> Fleet.T -> CountDistrPath w (Succ h) -> CountDistrMap w h -> IO () +nextFrontierBoundedExternal width maxFleet dst = + CountMap.writeSorted dst . + map + (concatMap + (\((frontier,fleet), cntDistr) -> + map (\key -> + (mapFst + (ShortenShip.canonicalFrontier . Frontier.dilate width) + key, + addFrontierToDistr (fst key) cntDistr)) $ + ShortenShip.transitionFrontierBounded + width maxFleet frontier fleet)) . + ListHT.sliceVertical bucketSize . + CountMap.toAscList + +bucketSize :: Int +bucketSize = 2^(11::Int) + +tmpPath :: Size h -> CountDistrPath w h +tmpPath (Size height) = ShortenShip.tmpPath height + +reportCount :: (Nat w, Nat h) => Fleet.T -> CountDistrPath w h -> IO () +reportCount fleet path = do + putStrLn "" + cd <- countBoundedFromMap fleet <$> CountMap.readFile path + print $ countFromDistr cd + putStr $ unlines $ + map (unwords . map show . SV.unpack . getRow . symmetric) $ + rowsFromDistr size cd + +withReport :: + (Nat w, Nat h) => + Bool -> Fleet.T -> (CountDistrPath w h -> IO ()) -> IOCountDistrPath w h +withReport report fleet act = + IOCountDistrPath $ + case tmpPath size of + path -> do + act path + when report $ reportCount fleet path + return path + +newtype + IOCountDistrPath w h = + IOCountDistrPath {runIOCountDistrPath :: IO (CountDistrPath w h)} + +distributionBoundedExternal :: + (Nat w, Nat h) => Bool -> Fleet.T -> IO (CountDistrPath w h) +distributionBoundedExternal report fleet = + runIOCountDistrPath $ + Size.switch + (withReport report fleet $ \path -> + CountMap.writeFile path baseCase) + (withReport report fleet $ \path -> + nextFrontierBoundedExternal size fleet path + =<< CountMap.readFile + =<< distributionBoundedExternal report fleet) + + +countExternal :: IO () +countExternal = + void (distributionBoundedExternal True Fleet.german :: IO (CountDistrPath N10 N10)) + + + +distributionExternalList :: + (Nat w, Nat h) => Size w -> Size h -> Fleet.T -> IO (Count, [[Count]]) +distributionExternalList w h fleet = do + cdm <- + (return $!!) . countBoundedFromMap fleet =<< + CountMap.readFile =<< distributionBoundedExternal False fleet + return + (countFromDistr cdm, + map (SV.unpack . getRow . symmetric) $ + rowsFromDistr w $ heightType h cdm) + +propCountExternalTotal :: QC.Property +propCountExternalTotal = + QC.forAllShrink (QC.choose (0,6)) QC.shrink $ \width -> + QC.forAllShrink (QC.choose (0,10)) QC.shrink $ \height -> + QC.forAllShrink ShortenShip.genFleet QC.shrink $ \fleet -> + Size.reifyInt width $ \w -> + Size.reifyInt height $ \h -> QCM.monadicIO $ do + (c,cd) <- QCM.run $ distributionExternalList w h fleet + QCM.assert $ + Counter.toInteger c + * fromIntegral (sum $ map (uncurry (*)) $ Fleet.toList fleet) + == + (sum $ map (Counter.toInteger . Counter.sum) cd) + +propCountExternalSimple :: QC.Property +propCountExternalSimple = + QC.forAllShrink (QC.choose (0,6)) QC.shrink $ \width -> + QC.forAllShrink (QC.choose (0,10)) QC.shrink $ \height -> + QC.forAllShrink ShortenShip.genFleet QC.shrink $ \fleet -> + Size.reifyInt width $ \w -> + Size.reifyInt height $ \h -> QCM.monadicIO $ do + (c,_cd) <- QCM.run $ distributionExternalList w h fleet + ce <- QCM.run $ ShortenShip.countExternalReturn (w,height) fleet + QCM.assert $ Counter.toInteger ce == Counter.toInteger c + +propCountExternalSymmetric :: QC.Property +propCountExternalSymmetric = + QC.forAllShrink (QC.choose (0,6)) QC.shrink $ \sz -> + QC.forAllShrink ShortenShip.genFleet QC.shrink $ \fleet -> + Size.reifyInt sz $ \n -> QCM.monadicIO $ do + (_c,cd) <- QCM.run $ distributionExternalList n n fleet + QCM.assert $ cd == List.transpose cd + +propCountExternalTransposed :: QC.Property +propCountExternalTransposed = + QC.forAllShrink (QC.choose (0,6)) QC.shrink $ \width -> + QC.forAllShrink (QC.choose (0,6)) QC.shrink $ \height -> + QC.forAllShrink ShortenShip.genFleet QC.shrink $ \fleet -> + Size.reifyInt width $ \w -> + Size.reifyInt height $ \h -> QCM.monadicIO $ do + (c0,cd0) <- QCM.run $ distributionExternalList w h fleet + (c1,cd1) <- QCM.run $ distributionExternalList h w fleet + QCM.assert $ c0 == c1 + QCM.assert $ List.transpose cd0 == cd1 diff --git a/src/Combinatorics/Battleship/Count/SquareBySquare.hs b/src/Combinatorics/Battleship/Count/SquareBySquare.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Count/SquareBySquare.hs @@ -0,0 +1,71 @@ +{- | +This can be made working by managing the whole (broken) frontier. +It has a form like this one: + +> xxxx +> xxxxxxx + +However, if we need to maintain all these information +this approach will be less efficient than the one with a straight frontier +as used in ShortenShip.hs. +-} +module Combinatorics.Battleship.Count.SquareBySquare where + +import qualified Combinatorics.Battleship.Fleet as Fleet + + +data Orientation = Horizontal | Vertical + deriving (Eq, Ord, Show) + +type Square = Maybe (Orientation, Fleet.ShipSize) + + +{- +initLeftBottom and updateLeftBorder are special cases of updateInside +with Nothing arguments. +We could rename updateInside to simple 'update' +and handle all special cases with this universal function. +-} +initLeftBottom :: [(Square, Fleet.T)] +initLeftBottom = + [(Nothing, Fleet.empty), + (Just (Horizontal, 1), Fleet.empty), (Just (Vertical, 1), Fleet.empty)] + +updateLeftBorder :: Fleet.T -> Square -> [(Square, Fleet.T)] +updateLeftBorder fleet below = + case below of + Nothing -> + [(Nothing, fleet), + (Just (Horizontal, 1), fleet), (Just (Vertical, 1), fleet)] + Just (Vertical, k) -> + [(Nothing, Fleet.inc k fleet), (Just (Vertical, succ k), fleet)] + Just (Horizontal, _k) -> + [(Nothing, fleet)] + +updateInside :: Fleet.T -> Square -> Bool -> Square -> [(Square, Fleet.T)] +updateInside fleet left leftBelow below = + case (left, leftBelow, below) of + (Just _, _, Just _) -> [] + (Nothing, False, Nothing) -> + [(Nothing, fleet), + (Just (Horizontal, 1), fleet), (Just (Vertical, 1), fleet)] + (Just (Vertical, _), _, Nothing) -> [(Nothing, fleet)] + (_, True, _) -> [(Nothing, fleet)] + (Nothing, _, Just (Horizontal, _k)) -> [(Nothing, fleet)] + (Nothing, False, Just (Vertical, k)) -> + [(Nothing, Fleet.inc k fleet), + (Just (Vertical, succ k), fleet)] + (Just (Horizontal, k), False, Nothing) -> + [(Nothing, Fleet.inc k fleet), + (Just (Horizontal, succ k), fleet)] + +insertSquare :: Square -> Fleet.T -> Fleet.T +insertSquare = maybe id $ Fleet.inc . snd + +check :: Fleet.T -> (Square, Fleet.T) -> Bool +check maxFleet = + let cumMaxFleet = Fleet.cumulate maxFleet + in \(square, fleet) -> + Fleet.subset fleet maxFleet + && + Fleet.subset (Fleet.cumulate (insertSquare square fleet)) cumMaxFleet diff --git a/src/Combinatorics/Battleship/Enumeration.hs b/src/Combinatorics/Battleship/Enumeration.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Enumeration.hs @@ -0,0 +1,244 @@ +{- | +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 diff --git a/src/Combinatorics/Battleship/Fleet.hs b/src/Combinatorics/Battleship/Fleet.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Fleet.hs @@ -0,0 +1,255 @@ +{- +We could add checks for overflows +by checking whether the most significant bit of every part is zero. +-} +module Combinatorics.Battleship.Fleet ( + -- * basics + T, + ShipSize, + NumberOfShips, + + cumulate, + dec, inc, + empty, + fromList, toList, + fromSizes, toSizes, + lookup, + maxSize, + singleton, + subset, + + -- * configurations for some established versions + german, + english, + + -- * tests + propList, + propSizes, + propCumulate, + propSubset, + + propInc, + propDec, + propIncDec, + ) where + +import qualified Foreign.Storable.Newtype as Store +import Foreign.Storable (Storable, sizeOf, alignment, poke, peek, ) + +import Data.Foldable (foldMap, ) +import Data.Bool.HT (if', ) + +import Data.Monoid (Monoid, mempty, mappend, ) +import Data.Bits ((.&.), (.|.), xor, shiftL, shiftR, ) +import Data.Word (Word32, ) + +import Prelude hiding (lookup) + +import qualified Test.QuickCheck as QC + + +type ShipSize = Int +type NumberOfShips = Int + +{- | +Efficient representation of a (Map ShipSize NumberOfShips). + +This is known as SIMD within a register . +-} +newtype T = Cons {decons :: Word32} + deriving (Eq, Ord) -- for use as key in a Map + + +instance Show T where + showsPrec prec x = + showParen (prec>10) $ + showString "Fleet.fromList " . + shows (toList x) + +instance Monoid T where + mempty = Cons 0 + mappend (Cons x) (Cons y) = Cons (x+y) + +instance Storable T where + sizeOf = Store.sizeOf decons + alignment = Store.alignment decons + poke = Store.poke decons + peek = Store.peek Cons + + +debug :: Bool +debug = False + +{-# INLINE checkSize #-} +checkSize :: String -> ShipSize -> a -> a +checkSize name size = + if' (debug && (size<=0 || maxSize Int +bitPosFromSize size = + (size-1)*bitsPerNumber + +empty :: T +empty = mempty + +singleton :: ShipSize -> NumberOfShips -> T +singleton size n = + checkSize "Fleet.singleton" size + Cons $ shiftL (fromIntegral n) (bitPosFromSize size) + +fromList :: [(ShipSize, NumberOfShips)] -> T +fromList = foldMap (uncurry singleton) + +fromSizes :: [ShipSize] -> T +fromSizes = fromList . map (flip (,) 1) + + +lookup :: T -> ShipSize -> NumberOfShips +lookup (Cons bits) size = + checkSize "Fleet.lookup" size $ + fromIntegral $ + shiftR bits (bitPosFromSize size) + .&. + digitMask + +toList :: T -> [(ShipSize, NumberOfShips)] +toList fleet = + filter ((0/=) . snd) $ + map (\size -> (size, lookup fleet size)) [1..maxSize] + +toSizes :: T -> [ShipSize] +toSizes = concatMap (\(size,n) -> replicate n size) . toList + + +propList :: T -> Bool +propList fleet = fleet == fromList (toList fleet) + +propSizes :: T -> Bool +propSizes fleet = fleet == fromSizes (toSizes fleet) + + +{- | +@lookup (cumulate fleet) size@ +returns the number of all ships that are at least @size@ squares big. +-} +cumulate :: T -> T +cumulate = cumulateDiv + +cumulateCascade :: T -> T +cumulateCascade (Cons x) = + Cons $ foldl (\y n -> y + shiftR y n) x $ + takeWhile (< maxSize * bitsPerNumber) $ iterate (2*) bitsPerNumber + +{- | +The total number ships must be strictly smaller than 15. +-} +cumulateDiv :: T -> T +cumulateDiv (Cons x) = + Cons $ + case divMod x digitMask of + (q,r) -> shiftL q bitsPerNumber .|. r + +genBounded :: QC.Gen T +genBounded = do + n <- QC.choose (0, fromIntegral digitMask - 1) + fmap fromSizes $ QC.vectorOf n $ QC.choose (1, maxSize) + +propCumulate :: QC.Property +propCumulate = + QC.forAll genBounded $ + \x -> cumulateCascade x == cumulateDiv x + + +{-# INLINE subset #-} +subset :: T -> T -> Bool +subset = subsetParity + +subsetLookup :: T -> T -> Bool +subsetLookup x y = + all (\size -> lookup x size <= lookup y size) [1..maxSize] + +{- | +This implementation checks whether unwanted borrows occurred. +@x<=y@ is required for the largest ship size. +-} +subsetParity :: T -> T -> Bool +subsetParity = + let sizesPos = + div (shiftL 1 (maxSize*bitsPerNumber) - 1) digitMask + in \(Cons x) (Cons y) -> + x<=y && xor (xor x y) (y-x) .&. sizesPos == 0 + +propSubset :: T -> T -> Bool +propSubset x y = subsetLookup x y == subsetParity x y + + +inc :: ShipSize -> T -> T +inc size (Cons fleet) = + checkSize "Fleet.inc" size $ + Cons $ fleet + shiftL 1 (bitPosFromSize size) + +dec :: ShipSize -> T -> T +dec size (Cons fleet) = + checkSize "Fleet.inc" size $ + Cons $ fleet - shiftL 1 (bitPosFromSize size) + + +{- | +The main configuration given +in . +-} +german :: T +german = fromList [(5,1), (4,2), (3,3), (2,4)] + +{- | +The main configuration given +in . +-} +english :: T +english = fromList [(2,1), (3,2), (4,1), (5,1)] + + +genShipSize :: QC.Gen ShipSize +genShipSize = QC.choose (1, maxSize) + +propInc :: T -> QC.Property +propInc fleet = + QC.forAll genShipSize $ \size -> + QC.forAll genShipSize $ \pos -> + lookup fleet size < fromIntegral digitMask + QC.==> + lookup (inc size fleet) pos == lookup fleet pos + fromEnum (pos==size) + +propDec :: T -> QC.Property +propDec fleet = + QC.forAll genShipSize $ \size -> + QC.forAll genShipSize $ \pos -> + lookup fleet size > 0 + QC.==> + lookup (dec size fleet) pos == lookup fleet pos - fromEnum (pos==size) + +propIncDec :: T -> QC.Property +propIncDec fleet = + QC.forAll genShipSize $ \size -> + lookup fleet size < fromIntegral digitMask + QC.==> + dec size (inc size fleet) == fleet + + +instance QC.Arbitrary T where + arbitrary = fmap Cons $ QC.choose (minBound, maxBound) + shrink = map (fromSizes . filter (>0)) . QC.shrink . toSizes diff --git a/src/Combinatorics/Battleship/SetCover.hs b/src/Combinatorics/Battleship/SetCover.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/SetCover.hs @@ -0,0 +1,257 @@ +module Combinatorics.Battleship.SetCover where + +import qualified Combinatorics.Battleship.Fleet as Fleet +import Combinatorics.Battleship (Ship(Ship), ShipSize, Orientation(..), ) + +import qualified Math.SetCover.BitSet as BitSet +import qualified Math.SetCover.Exact as ESC +import qualified Data.Map as Map; import Data.Map (Map) +import qualified Data.Set as Set; import Data.Set (Set) + +import System.Random (RandomGen, randomR, mkStdGen) + +import Text.Printf (printf) + +import qualified Control.Monad.Trans.Class as MT +import qualified Control.Monad.Trans.State as MS +import qualified Control.Functor.HT as FuncHT +import Control.DeepSeq (force) +import Control.Monad (liftM, liftM2, when, mplus) + +import qualified Data.StorableVector as SV +import qualified Data.Foldable as Fold +import qualified Data.List as List +import Data.Foldable (foldMap, forM_) +import Data.Maybe.HT (toMaybe) +import Data.Maybe (mapMaybe, catMaybes) +import Data.Tuple.HT (mapFst) +import Data.Word (Word64) + + +shipShape :: Ship -> Map (Int, Int) Bool +shipShape (Ship size orient (x,y)) = + Map.fromAscList $ map (flip (,) True) $ + case orient of + Horizontal -> map (flip (,) y) [x .. x+size-1] + Vertical -> map ((,) x) [y .. y+size-1] + +shipReserve :: Ship -> Set (Int, Int) +shipReserve (Ship size orient (x,y)) = + let lx = max 0 (x-1) + ly = max 0 (y-1) + in Set.fromAscList $ + case orient of + Horizontal -> liftM2 (,) [lx .. x+size-1] [ly .. y] + Vertical -> liftM2 (,) [lx .. x] [ly .. y+size-1] + + +type AssignShip = ESC.Assign (ShipSize, Map (Int, Int) Bool) (Set (Int, Int)) + +assignsShip :: [ShipSize] -> (Int, Int) -> [AssignShip] +assignsShip sizes (width, height) = do + size <- sizes + mplus + (do + x <- [0 .. width-size] + y <- [0 .. height-1] + let horizShip = Ship size Horizontal (x,y) + [ESC.assign (size, shipShape horizShip) (shipReserve horizShip)]) + (do + x <- [0 .. width-1] + y <- [0 .. height-size] + let vertShip = Ship size Vertical (x,y) + [ESC.assign (size, shipShape vertShip) (shipReserve vertShip)]) + +boardCoords :: (Int, Int) -> [(Int, Int)] +boardCoords (width, height) = + liftM2 (,) (take width [0..]) (take height [0..]) + +assignsSquare :: + (Int, Int) -> + [ESC.Assign (Maybe ShipSize, Map (Int, Int) Bool) (Set (Int, Int))] +assignsSquare (width, height) = do + p <- boardCoords (width, height) + [ESC.assign (Nothing, Map.singleton p False) (Set.singleton p)] + +assigns :: + [ShipSize] -> (Int, Int) -> + [ESC.Assign (Maybe ShipSize, Map (Int, Int) Bool) (Set (Int, Int))] +assigns sizes boardSize = + map + (\asn -> asn{ESC.label = mapFst Just (ESC.label asn)}) + (assignsShip sizes boardSize) ++ + assignsSquare boardSize + + +formatBoard :: (Int, Int) -> Map (Int, Int) Bool -> String +formatBoard (width, height) set = + unlines $ + FuncHT.outerProduct + (\y x -> + case Map.lookup (x,y) set of + Nothing -> '_' + Just False -> '.' + Just True -> 'x') + [0 .. height-1] [0 .. width-1] + + +printState :: (Int, Int) -> ESC.State (ship, Map (Int, Int) Bool) set -> IO () +printState boardSize = + printBoard boardSize . foldMap (snd . ESC.label) . ESC.usedSubsets + +printBoard :: (Int, Int) -> Map (Int, Int) Bool -> IO () +printBoard boardSize = putStr . ('\n':) . formatBoard boardSize + + +standardBoardSize :: (Int, Int) +standardBoardSize = (10, 10) + +standardFleetList :: [(ShipSize, Fleet.NumberOfShips)] +standardFleetList = [(5,1), (4,2), (3,3), (2,4)] + +enumerateFirst :: IO () +enumerateFirst = do + let boardSize = standardBoardSize + mapM_ + (printState boardSize) + (ESC.step $ ESC.initState $ assigns (map fst standardFleetList) boardSize) + +enumerateMixed :: IO () +enumerateMixed = do + let boardSize = standardBoardSize + let fleetList = standardFleetList + let fleet = Fleet.fromList fleetList + let loop state = + let usedFleet = + Fleet.fromList $ map (flip (,) 1) $ + mapMaybe (fst . ESC.label) $ ESC.usedSubsets state + in when (Fleet.subset usedFleet fleet) $ + if usedFleet == fleet + then printState boardSize state + else mapM_ loop (ESC.step state) + loop $ ESC.initState $ assigns (map fst fleetList) boardSize + + +type AssignShipBitSet = + ESC.Assign (ShipSize, Map (Int, Int) Bool) (BitSet.Set Integer) + +enumerateGen :: + (Monad m) => + ([AssignShipBitSet] -> m AssignShipBitSet) -> + (Int, Int) -> [(ShipSize, Int)] -> m (Map (Int, Int) Bool) +enumerateGen sel boardSize fleetList = do + let layoutShip shipSize = do + state <- MS.get + place <- + MT.lift $ sel $ filter ((shipSize==) . fst . ESC.label) $ + ESC.availableSubsets state + MS.put $ ESC.updateState place state + liftM (foldMap (snd . ESC.label) . ESC.usedSubsets) $ + MS.execStateT + (mapM_ layoutShip $ concatMap (uncurry $ flip replicate) fleetList) $ + ESC.initState $ + ESC.bitVectorFromSetAssigns $ assignsShip (map fst fleetList) boardSize + + +enumerateShip :: IO () +enumerateShip = do + let boardSize = standardBoardSize + let fleetList = standardFleetList + mapM_ (printBoard boardSize) $ enumerateGen id boardSize fleetList + + +select :: (RandomGen g) => [a] -> MS.StateT g Maybe a +select xs = MS.StateT $ \g -> + toMaybe (not $ null xs) $ mapFst (xs!!) $ randomR (0, length xs - 1) g + +enumerateRandom :: IO () +enumerateRandom = do + let boardSize = standardBoardSize + let fleetList = standardFleetList + forM_ [0..] $ \seed -> + Fold.mapM_ (printBoard boardSize) $ + MS.evalStateT + (enumerateGen select boardSize fleetList) + (mkStdGen seed) + + +listsFromBoard :: (Num a) => (a -> b) -> (Int, Int) -> Map (Int, Int) a -> [[b]] +listsFromBoard f (width, height) set = + FuncHT.outerProduct + (\y x -> f $ Map.findWithDefault 0 (x,y) set) + (take height [0..]) (take width [0..]) + +formatDistr :: (Int, Int) -> Map (Int, Int) Float -> String +formatDistr boardSize set = + unlines $ map unwords $ listsFromBoard (printf "%.3f") boardSize set + +formatAbsDistr :: (Int, Int) -> Map (Int, Int) Word64 -> String +formatAbsDistr boardSize set = + unlines $ map unwords $ listsFromBoard (printf "%d") boardSize set + +sumMaps :: [Map (Int, Int) Int] -> Map (Int, Int) Int +sumMaps = List.foldl' ((force .) . Map.unionWith (+)) Map.empty + +sumMapsStorable :: + (Int, Int) -> [Map (Int, Int) Word64] -> Map (Int, Int) Word64 +sumMapsStorable boardSize = + Map.fromList . zip (boardCoords boardSize) . SV.unpack . + let zeroBoard = Map.fromList $ map (flip (,) 0) (boardCoords boardSize) + numSquares = uncurry (*) boardSize + checkLength x = + if SV.length x == numSquares + then x + else error "invalid keys in counter board" + in List.foldl' ((force .) . SV.zipWith (+)) (SV.replicate numSquares 0) . + map (checkLength . SV.pack . Map.elems . flip Map.union zeroBoard) + +estimateDistribution :: IO () +estimateDistribution = do + let boardSize = standardBoardSize + let fleetList = standardFleetList + let num = 100000 + putStr $ ('\n':) $ formatDistr boardSize $ + Map.map (\n -> fromIntegral n / fromIntegral num) $ + sumMapsStorable boardSize $ + map (Map.map (\b -> if b then 1 else 0)) $ + take num $ catMaybes $ + flip map [0..] $ \seed -> + MS.evalStateT + (enumerateGen select boardSize fleetList) + (mkStdGen seed) + +exactDistribution :: IO () +exactDistribution = do + let boardSize = standardBoardSize + let fleetList = [(2,1), (3,2)] + putStr $ ('\n':) $ formatAbsDistr boardSize $ + sumMapsStorable boardSize $ + map (Map.map (\b -> if b then 1 else 0)) $ + enumerateGen id boardSize fleetList + +{- +110984 157686 189232 183236 181578 181578 183236 189232 157686 110984 +157686 190520 213246 203776 201766 201766 203776 213246 190520 157686 +189232 213246 232008 221676 220274 220274 221676 232008 213246 189232 +183236 203776 221676 211572 210458 210458 211572 221676 203776 183236 +181578 201766 220274 210458 209428 209428 210458 220274 201766 181578 +181578 201766 220274 210458 209428 209428 210458 220274 201766 181578 +183236 203776 221676 211572 210458 210458 211572 221676 203776 183236 +189232 213246 232008 221676 220274 220274 221676 232008 213246 189232 +157686 190520 213246 203776 201766 201766 203776 213246 190520 157686 +110984 157686 189232 183236 181578 181578 183236 189232 157686 110984 + +real 0m37.341s +user 0m37.162s +sys 0m0.128s +-} + +tikzBrightnessField :: (Double,Double) -> [[Double]] -> String +tikzBrightnessField (lower,upper) xs = + unlines $ + zipWith + (\num row -> + printf "\\brightnessrow{%d}{%s}" num $ + List.intercalate "," $ map (printf "%02d") $ + map (\val -> round (100*(val-lower)/(upper-lower)) :: Int) row) + [0::Int ..] xs diff --git a/src/Combinatorics/Battleship/Size.hs b/src/Combinatorics/Battleship/Size.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Battleship/Size.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE Rank2Types #-} +module Combinatorics.Battleship.Size where + + +data Zero = Zero +data Succ n = Succ n + +type N0 = Zero +type N1 = Succ N0 ; type P1 w = Succ w +type N2 = Succ N1 ; type P2 w = Succ (P1 w) +type N3 = Succ N2 ; type P3 w = Succ (P2 w) +type N4 = Succ N3 ; type P4 w = Succ (P3 w) +type N5 = Succ N4 ; type P5 w = Succ (P4 w) +type N6 = Succ N5 ; type P6 w = Succ (P5 w) +type N7 = Succ N6 ; type P7 w = Succ (P6 w) +type N8 = Succ N7 ; type P8 w = Succ (P7 w) +type N9 = Succ N8 ; type P9 w = Succ (P8 w) +type N10 = Succ N9 ; type P10 w = Succ (P9 w) +type N11 = Succ N10 ; type P11 w = Succ (P10 w) +type N12 = Succ N11 ; type P12 w = Succ (P11 w) + +n0 :: Size N0; n0 = size +n1 :: Size N1; n1 = size +n2 :: Size N2; n2 = size +n3 :: Size N3; n3 = size +n4 :: Size N4; n4 = size +n5 :: Size N5; n5 = size +n6 :: Size N6; n6 = size +n7 :: Size N7; n7 = size +n8 :: Size N8; n8 = size +n9 :: Size N9; n9 = size +n10 :: Size N10; n10 = size + + +newtype Size n = Size {getSize :: Int} + +incSize :: Size n -> Size (Succ n) +incSize (Size n) = Size (n+1) + +class Nat n where switch :: f Zero -> (forall m. Nat m => f (Succ m)) -> f n +instance Nat Zero where switch f _ = f +instance Nat n => Nat (Succ n) where switch _ f = f + +size :: Nat n => Size n +size = switch (Size 0) (incSize size) + + +reifyInt :: Int -> (forall n. Nat n => Size n -> a) -> a +reifyInt n f = + if n==0 + then f n0 + else reifyInt (n-1) $ f . incSize diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,117 @@ +module Main where + +import qualified Combinatorics.Battleship.Count.ShortenShip.Distribution as + Distribution +import qualified Combinatorics.Battleship.Count.ShortenShip as ShortenShip +import qualified Combinatorics.Battleship.Count.CountMap as CountMap +import qualified Combinatorics.Battleship.Count.Counter as Counter +import qualified Combinatorics.Battleship.Count.Frontier as Frontier +import qualified Combinatorics.Battleship.Enumeration as Enumerate +import qualified Combinatorics.Battleship.SetCover as SetCover +import qualified Combinatorics.Battleship.Fleet as Fleet +import qualified Combinatorics.Battleship.Size as Size + + +import qualified Test.QuickCheck.Monadic as QCM +import qualified Test.QuickCheck as QC +import Test.QuickCheck (quickCheck) + + +factorial :: (Integral a) => a -> a +factorial n = product [1..n] + +multiplicity :: (Integral a) => Fleet.T -> a +multiplicity = product . map (factorial . fromIntegral . snd) . Fleet.toList + +propCountSetCover :: QC.Property +propCountSetCover = + QC.forAllShrink (QC.choose (0,4)) QC.shrink $ \width -> + QC.forAllShrink (QC.choose (0,10)) QC.shrink $ \height -> + QC.forAllShrink ShortenShip.genFleet QC.shrink $ \fleet -> + Size.reifyInt width $ \w -> + Counter.toInteger (ShortenShip.countBounded (w, height) fleet) + * multiplicity fleet + == + fromIntegral + (length $ SetCover.enumerateGen id (width,height) $ Fleet.toList fleet) + +propDistributionSetCover :: QC.Property +propDistributionSetCover = + QC.forAll (QC.choose (1,4)) $ \width -> + QC.forAll (QC.choose (1,10)) $ \height -> + QC.forAllShrink ShortenShip.genFleet QC.shrink $ \fleet -> + Size.reifyInt width $ \w -> + Size.reifyInt height $ \h -> QCM.monadicIO $ do + (_c,cd) <- QCM.run $ Distribution.distributionExternalList w h fleet + let boardSize = (width,height) + board = + SetCover.sumMapsStorable boardSize $ + map (fmap (\b -> if b then 1 else 0)) $ + SetCover.enumerateGen id boardSize $ Fleet.toList fleet + QCM.assert $ + map (map (multiplicity fleet *)) cd + == + SetCover.listsFromBoard id boardSize board + +propCountEnumerate :: QC.Property +propCountEnumerate = + QC.forAllShrink (QC.choose (0,4)) QC.shrink $ \width -> + QC.forAllShrink (QC.choose (0,10)) QC.shrink $ \height -> + QC.forAllShrink ShortenShip.genFleet QC.shrink $ \fleet -> + Size.reifyInt width $ \w -> + Counter.toInteger (ShortenShip.countBounded (w, height) fleet) + == + (fromIntegral $ length $ + Enumerate.configurations (width, height) $ + Enumerate.fleetFromSizes $ Fleet.toSizes fleet) + +quickCheckNum :: QC.Testable prop => Int -> prop -> IO () +quickCheckNum n = QC.quickCheckWith (QC.stdArgs {QC.maxSuccess = n}) + +main :: IO () +main = + mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $ + ("Counter.add", quickCheck Counter.propAdd) : + ("Frontier.dilate", quickCheckNum 1000 Frontier.propDilate) : + ("Frontier.reverse4", quickCheck Frontier.propReverse4) : + ("Frontier.reverse5", quickCheck Frontier.propReverse5) : + ("Frontier.reverse6", quickCheck Frontier.propReverse6) : + ("Frontier.reverse7", quickCheck Frontier.propReverse7) : + ("Frontier.reverse8", quickCheck Frontier.propReverse8) : + ("Frontier.reverse9", quickCheck Frontier.propReverse9) : + ("Frontier.reverse10", quickCheck Frontier.propReverse10) : + ("Fleet.list", quickCheck Fleet.propList) : + ("Fleet.sizes", quickCheck Fleet.propSizes) : + ("Fleet.cumulate", quickCheck Fleet.propCumulate) : + ("Fleet.subset", quickCheck Fleet.propSubset) : + ("Fleet.inc", quickCheck Fleet.propInc) : + ("Fleet.dec", quickCheck Fleet.propDec) : + ("Fleet.incDec", quickCheck Fleet.propIncDec) : + ("CountMap.merge", quickCheck CountMap.propMerge) : + ("ShortenShip.countSymmetry", + quickCheck ShortenShip.propCountSymmetry) : + ("ShortenShip.countTransposed", + quickCheck ShortenShip.propCountTransposed) : + ("ShortenShip.countTouchingTransposed", + quickCheck ShortenShip.propCountTouchingTransposed) : + ("ShortenShip.countMoreTouching", + quickCheck ShortenShip.propCountMoreTouching) : + ("ShortenShip.countBounded", + quickCheck ShortenShip.propCountBounded) : + ("ShortenShip.countExternal", + quickCheck ShortenShip.propCountExternal) : + ("ShortenShip.countTouchingExternal", + quickCheck ShortenShip.propCountTouchingExternal) : + ("countSetCover", quickCheck propCountSetCover) : + ("countEnumerate", quickCheck propCountEnumerate) : + ("distributionSetCover", + quickCheck propDistributionSetCover) : + ("Distribution.countExternalTotal", + quickCheck Distribution.propCountExternalTotal) : + ("Distribution.countExternalSimple", + quickCheck Distribution.propCountExternalSimple) : + ("Distribution.countExternalSymmetric", + quickCheck Distribution.propCountExternalSymmetric) : + ("Distribution.countExternalTransposed", + quickCheck Distribution.propCountExternalTransposed) : + []