12
$\begingroup$

Toy data

board =
  {{1, 1, 0, 4, 0, 0, 9, 9, 9, 9},
   {0, 0, 0, 4, 0, 0, 0, 0, 0, 0},
   {5, 0, 0, 4, 0, 7, 7, 7, 0, 8},
   {5, 0, 0, 0, 0, 0, 0, 0, 0, 8},
   {5, 0, 0, 0, 0, 0, 0, 0, 0, 0},
   {5, 0, 0, 0, 4, 0, 0, 0, 0, 6},
   {0, 0, 0, 0, 4, 0, 0, 0, 0, 6},
   {3, 3, 0, 0, 0, 0, 0, 0, 0, 6},
   {0, 0, 0, 0, 0, 0, 0, 0, 0, 0},
   {0, 0, 0, 0, 0, 3, 3, 3, 3, 3}};

Visualization

ArrayPlot[board,
 ColorFunction -> "AtlanticColors",
 Frame -> True,
 FrameTicks -> {{All, None}, {None, Transpose[{Range @ 10, CharacterRange["A", "J"]}]}},
 Mesh -> True]

enter image description here

Battleship

is a guessing game for two players. It is played on paper grids on which each player's fleet of warships are marked. Players shoot at the other player's ships, and the objective of the game is to destroy the opposing player's fleet.

Here we don't want to guess and destroy, but find the ship locations in an elegant mathematical way. In my own coding experiments I got caught up in something that was far too complicated.

Expected result

The sorted result should look like:

result =
   {"A1:B1", "A3:A6", "A8:B8", "D1:D3", "E6:E7", "F10:J10", "F3:H3", "G1:J1", "J3:J4", "J6:J8"};

Addendum

There is always some water between the ships, their lengths can range from 2 to 5 square units, and diagonal placements are not allowed.

$\endgroup$
2
  • 1
    $\begingroup$ two different ships are labeled 3; is that a typo? $\endgroup$
    – kglr
    Nov 20, 2023 at 16:25
  • 2
    $\begingroup$ No, I did that on purpose. Ship identifiers can repeat. Let's say they don't identify the individual ship, but the flag under which it sails. $\endgroup$
    – eldo
    Nov 20, 2023 at 16:30

6 Answers 6

11
$\begingroup$

NearestNeigborGraph + ConnectedComponents

nng = NearestNeighborGraph[Position[board, _Integer?Positive], 
  DistanceFunction -> ManhattanDistance];

ConnectedComponents[nng] // Column

enter image description here

toExcelIndices =  StringRiffle[
  MapAt[ToUpperCase[Alphabet[]][[#]] &, Reverse /@ #, {All, 1}], ":", ""] &

Sort @ Map[toExcelIndices] @ ConnectedComponents[nng][[All, {1, -1}]]
  {"A1:B1", "A3:A6", "A8:B8", "D1:D3", "E6:E7",   
   "F10:J10", "F3:H3",   "G1:J1", "J3:J4", "J6:J8"}

Visualization:

ap = ArrayPlot[board, 
   ColorFunction -> "AtlanticColors", 
   Frame -> True, 
   FrameTicks -> {{All, None}, 
     {None, Transpose[{Range@10, CharacterRange["A", "J"]}]}},
   Mesh -> True
   Epilog ->  MapIndexed[Text[Style[#, 16, White], #2 - 1/2] &, 
      Transpose @ Reverse @ board, {2}]];

nng = Graph[nng,
   PerformanceGoal -> "Quality", 
   EdgeStyle -> 
    Directive[CapForm["Round"], AbsoluteThickness[25], Red], 
   VertexCoordinates -> 
     MapApply[-1/2 + {#2, 1 + 10 - #} &] @ GraphEmbedding[nng]];

Show[ap, 
  HighlightGraph[nng, PathGraph /@ ConnectedComponents[nng]]]

enter image description here

$\endgroup$
8
$\begingroup$

SparseArray + FindClusters

shipCoords = FindClusters[
   SparseArray[Transpose @ board]["NonzeroPositions"], 
   DistanceFunction -> ManhattanDistance];


shipCoords // Column

enter image description here

toExcelIndexing = StringRiffle[
   MapAt[ToUpperCase[Alphabet[]][[#]] &, #, {All, 1}], ":", ""] &;

Map[toExcelIndexing] @ shipCoords[[All, {1, -1}]]
 
{"A1:B1", "A3:A6", "A8:B8", "D1:D3", "E6:E7", "F3:H3",   
 "F10:J10", "G1:J1", "J3:J4", "J6:J8"}
$\endgroup$
1
  • 1
    $\begingroup$ Nice! [comment padding] $\endgroup$
    – lericr
    Nov 20, 2023 at 19:20
7
$\begingroup$

One attempt:

board = {
  {1, 1, 0, 4, 0, 0, 9, 9, 9, 9}, {0, 0, 0, 4, 0, 0, 0, 0, 0, 0}
, {5, 0, 0, 4, 0, 7, 7, 7, 0, 8}, {5, 0, 0, 0, 0, 0, 0, 0, 0, 8}
, {5, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {5, 0, 0, 0, 4, 0, 0, 0, 0, 6}
, {0, 0, 0, 0, 4, 0, 0, 0, 0, 6}, {3, 3, 0, 0, 0, 0, 0, 0, 0, 6}
, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 3, 3, 3, 3, 3}};

{xMax, yMax} = Dimensions@board;
cm = Association@Map[Round
     , ComponentMeasurements[
        MorphologicalComponents[Binarize@Image@board], "BoundingBox"], {-1}];
char = AssociationThread[Range@xMax,Take[ToUpperCase@Alphabet[], xMax]];
coordinates[from : {x0_, y0_}, to : {x1_, y1_}] := 
  StringJoin[Riffle[Sort[
     Map[ToString
     , {{char[x0 + 1], yMax - y0 }, {char[x1], yMax + 1 - y1}}, {2}]], ":"]];
coordinates @@@ cm // Values // Sort
(* Output *)
(*
    {"A1:B1", "A3:A6", "A8:B8", "D1:D3", "E6:E7", "F10:J10", "F3:H3", "G1:J1", "J3:J4", "J6:J8"}
*)
$\endgroup$
1
  • 3
    $\begingroup$ +1 - much to learn for me from your solution $\endgroup$
    – eldo
    Nov 20, 2023 at 17:29
7
$\begingroup$

Here is a step-by-step procedure:

uniquifiedBoard = MorphologicalComponents[board];
shipIdentifiers = Rest@Union[Flatten[uniquifiedBoard]];
positions = Position[uniquifiedBoard, #] & /@ shipIdentifiers;

(* helpers *)
CreateDescription[pos : {{x_, _} ...}] := {{x, pos[[1, -1]]}, {x, pos[[-1, -1]]}};
CreateDescription[pos : {{_, y_} ...}] := {{pos[[1, 1]], y}, {pos[[-1, 1]], y}};
ExcelifyCoords[{x_, y_}] := Alphabet[][[y]] <> ToString[x];
ExcelifyRange[{a_List, ___List, b_List}] := ExcelifyCoords[a] <> ":" <> ExcelifyCoords[b];

(* result *)
ExcelifyRange /@ positions

(* 
  {"a1:b1", "a3:a6", "a8:b8", "d1:d3", "e6:e7", "f10:j10", "f3:h3", "g1:j1", "j3:j4", "j6:j8"}
 *)
$\endgroup$
4
$\begingroup$

This should, at least and at last, convince me to start learning about graphs.

Clear["Global`*"];
board = {{1, 1, 0, 4, 0, 0, 9, 9, 9, 9}, {0, 0, 0, 4, 0, 0, 0, 0, 0, 
    0}, {5, 0, 0, 4, 0, 7, 7, 7, 0, 8}, {5, 0, 0, 0, 0, 0, 0, 0, 0, 
    8}, {5, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {5, 0, 0, 0, 4, 0, 0, 0, 0, 
    6}, {0, 0, 0, 0, 4, 0, 0, 0, 0, 6}, {3, 3, 0, 0, 0, 0, 0, 0, 0, 
    6}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 3, 3, 3, 3, 
    3}};

across = (Transpose[{ToUpperCase@Alphabet[][[1 ;; Length@#]], #}] & /@
         board /. {a_, 0} :> Nothing // 
      Map[GatherBy[#, Last] &]) /. {{a_, b_}} :> Nothing // 
   MapIndexed[
     ToString@First@First@#1 <> ToString@First@#2 <> ":" <> 
       ToString@First@Last@#1 <> ToString@First@#2 &, #, {2}] & // 
  Flatten[#, 1] &

{"A1:B1", "G1:J1", "F3:H3", "A8:B8", "F10:J10"}

down = (Transpose[{ToUpperCase@
            Alphabet[][[1 ;; Length@#]], #}] & /@ (Transpose@
          board) /. {a_, 0} :> Nothing // Map[GatherBy[#, Last] &]) //
    Map[Replace[#, {{a_, b_}} :> Nothing, {1}] &] //
   MapIndexed[
     ToUpperCase@FromLetterNumber@First@#2 <> 
       ToString@LetterNumber@First@First@#1 <> ":" <> 
       ToUpperCase@FromLetterNumber@First@#2 <> 
       ToString@LetterNumber@First@Last@#1 &, #, {2}] & // 
  Flatten[#, 1] &

{"A3:A6", "D1:D3", "E6:E7", "J3:J4", "J6:J8"}

$\endgroup$
1
  • 1
    $\begingroup$ Your preface to the answer had me down in tears XD $\endgroup$
    – bmf
    Nov 21, 2023 at 5:04
4
$\begingroup$

MapIndexed + SplitBy

ClearAll[indexBoard, bowStern, findShips]

ucA = ToUpperCase@Alphabet[];

indexBoard[direction_ : "Across"] := Module[
   {d$ = direction /. {"Across" -> Reverse, _ -> Identity}}, 
   MapIndexed[If[# == 0, Nothing, 
      {#, StringRiffle[{ucA[[#]], #2} & @@ d$[#2], ""]}] &, #, {2}]] &

bowStern = Map[
     Splice @
     Cases[{{_, f_}, ___, {_, l_}} :> StringRiffle[{f, l}, ":"]] @
     SplitBy[#, First] &];

findShips = Sort @ Map[Splice @* bowStern] @
   {indexBoard[] @ #, indexBoard["Down"] @ Transpose @ #} &;


findShips @ board
  {"A1:B1", "A3:A6", "A8:B8", "D1:D3", "E6:E7", "F10:J10",   
   "F3:H3", "G1:J1", "J3:J4", "J6:J8"}
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.