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.

Improve this question
$\endgroup$
2
  • 1
    $\begingroup$ two different ships are labeled 3; is that a typo? $\endgroup$
    – kglr
    Nov 20 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 at 16:30

6 Answers 6

Reset to default
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

Improve this answer
$\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"}
Improve this answer
$\endgroup$
1
  • 1
    $\begingroup$ Nice! [comment padding] $\endgroup$
    – lericr
    Nov 20 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"}
*)
Improve this answer
$\endgroup$
1
  • 3
    $\begingroup$ +1 - much to learn for me from your solution $\endgroup$
    – eldo
    Nov 20 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"}
 *)
Improve this answer
$\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"}

Improve this answer
$\endgroup$
1
  • 1
    $\begingroup$ Your preface to the answer had me down in tears XD $\endgroup$
    – bmf
    Nov 21 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"}
Improve this answer
$\endgroup$

Your Answer

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

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