packages feed

battleship-combinatorics (empty) → 0.0

raw patch · 21 files changed

+3888/−0 lines, 21 filesdep +QuickCheckdep +basedep +battleship-combinatoricssetup-changed

Dependencies added: QuickCheck, base, battleship-combinatorics, combinatorial, containers, deepseq, directory, filepath, non-empty, pooled-io, prelude-compat, random, set-cover, storable-record, storablevector, temporary, transformers, utility-ht

Files

+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ battleship-combinatorics.cabal view
@@ -0,0 +1,89 @@+Name:             battleship-combinatorics+Version:          0.0+License:          BSD3+License-File:     LICENSE+Author:           Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:       Henning Thielemann <haskell@henning-thielemann.de>+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.+  .+  <https://en.wikipedia.org/wiki/Battleship_(game)>+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
+ main/Main.hs view
@@ -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 ()
+ src/Combinatorics/Battleship.hs view
@@ -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))
+ src/Combinatorics/Battleship/Allocation.hs view
@@ -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
+ src/Combinatorics/Battleship/Count/CountMap.hs view
@@ -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
+ src/Combinatorics/Battleship/Count/Counter.hs view
@@ -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)
+ src/Combinatorics/Battleship/Count/Cumulative.hs view
@@ -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<size-1 then 1 else 0)++formatBoard :: Board -> 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
+ src/Combinatorics/Battleship/Count/DiagonalFrontier.hs view
@@ -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 ((<width) . fst) xys++{-+clipBottomFrontier :: Int -> 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 ((<width) . snd) xys+   in  lower +++       if null upper+         then []+         else [(width, snd $ head upper)]+-}++cornersForShip :: (Int, Int) -> 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.+-}
+ src/Combinatorics/Battleship/Count/Estimate.hs view
@@ -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
+ src/Combinatorics/Battleship/Count/Frontier.hs view
@@ -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<k && k<=maxShipSize+      _ -> 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-1) [k+1]) $+   filter (not . isFree frontier) $ take size [0..]++propDilate :: QC.Property+propDilate =+   QC.forAll (QC.choose (0,10)) $ \n ->+   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
+ src/Combinatorics/Battleship/Count/InclusionExclusion.hs view
@@ -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)
+ src/Combinatorics/Battleship/Count/ShortenShip.hs view
@@ -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)]++{- | <http://math.stackexchange.com/questions/58769/how-many-ways-can-we-place-these-ships-on-this-board>+-}+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
+ src/Combinatorics/Battleship/Count/ShortenShip/Distribution.hs view
@@ -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
+ src/Combinatorics/Battleship/Count/SquareBySquare.hs view
@@ -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
+ src/Combinatorics/Battleship/Enumeration.hs view
@@ -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+++{- |+<http://math.stackexchange.com/questions/58769/how-many-ways-can-we-place-these-ships-on-this-board>+-}+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
+ src/Combinatorics/Battleship/Fleet.hs view
@@ -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 <https://en.wikipedia.org/wiki/SWAR>.+-}+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<size)) $+      error $ name ++ ": ship size " ++ show size ++ " out of range"++{-+The number of bits must be large enough+in order to also hold a cumulative fleet.+-}+bitsPerNumber :: Int+bitsPerNumber = 4++digitMask :: Word32+digitMask = shiftL 1 bitsPerNumber - 1++maxSize :: Int+maxSize = 8++bitPosFromSize :: Int -> 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 <https://de.wikipedia.org/wiki/Schiffe_versenken>.+-}+german :: T+german = fromList [(5,1), (4,2), (3,3), (2,4)]++{- |+The main configuration given+in <https://en.wikipedia.org/wiki/Battleship_(game)>.+-}+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
+ src/Combinatorics/Battleship/SetCover.hs view
@@ -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
+ src/Combinatorics/Battleship/Size.hs view
@@ -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
+ test/Test.hs view
@@ -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) :+   []