20
$\begingroup$

I am asking a question based on this question from the sister site MSE.

In an effort to make this a self-contained question, I include the fiorst documented posing of the problem by Robert Abilock in American Monthly The Rifle-Problem (R. Abilock; 1967),

$n$ riflemen are distributed at random points on a plane. At a signal, each one shoots at and kills his nearest neighbor. What is the expected number of riflemen who are left alive?

eg: For $n=20,$ a random distribution might look something like this:

enter image description here

I would like to write an algorithm to find the upper bound for the number of survivors. As stated in the question, clerarly $n=1$ is a special case and the upper bound $=1.$ For $n=2\rightarrow 8,$ the upper bound is obviously $n-2,$ though random point placements are not efficient for find possible arrangements for these:

Clear[aB, reP]

constA[nn_] := With[{aa = Partition[RandomReal[{0, 1}, 2 nn], 2]},
With[{cc = ({aa[[#]], First@Nearest[DeleteCases[aa, aa[[#]]], aa[[#]]]} & /@ 
Range@nn)}, With[{dd = Table[Position[aa, cc[[p, 2]]][[1, 1]], {p, nn}]}, 
With[{ee = Complement[Range@nn, dd]}, {aa, Length@ee}]]]]

constB[nn_, rr_] := With[{aa = constA[nn] & /@ Range@rr}, 
aa[[#]] & /@ Flatten@Position[aa[[All, 2]], Max@aa[[All, 2]]]]

whileF[nn_] := (reP = 1; While[Max@(aB = constB[nn, reP++])[[All, 2]] 
!= nn - Floor[nn/3]]; {Flatten[aB, 1]~Join~{{reP}}})

whileF[n] for $n\geq 8$ is just not viable - variants on a strategy are prefereable.

eg: an upperbound example for $n=8,$ where all but $\#\ 3$ and $4$ don't survive:

enter image description here

For $n\geq 9,$ the upper bound is not quite so obvious (though I believe for $n=9$ is $6$, and for $n=10,$ the upper bound of survivors is $7:$

enter image description here

(image taken from here).

I ask the question on this site, as it seems that the problem lends itself to graph networks and travelling salesman type algorithms.

I only ask for hints on where to begin, as requesting a code from scratch seems a little to much to ask. Any pointers would be most welcome.

Since the travelling salesman problem is an $NP$ problem, I would be happy for suggestions that deal with small $n$ only.

$\endgroup$
20
  • $\begingroup$ I don't think this is the standard usage of "lim sup". For any n there must be a supremum, but I fail to see where a limit would be involved. $\endgroup$ Oct 11, 2015 at 16:30
  • $\begingroup$ @DanielLichtblau you are quite right, my mistake - will alter - sorry for confusion! $\endgroup$
    – martin
    Oct 11, 2015 at 18:20
  • 1
    $\begingroup$ Please make the question self-contained (as per the StackExchange policy). $\endgroup$
    – C. E.
    Oct 11, 2015 at 19:18
  • 1
    $\begingroup$ The graph can be constructed with NearestNeighborGraph[points, DirectedEdges -> True]. $\endgroup$
    – Szabolcs
    Oct 13, 2015 at 12:51
  • 1
    $\begingroup$ Aren't the optimal arrangements like this? !Mathematica graphics $\endgroup$ Oct 14, 2015 at 17:46

2 Answers 2

10
+50
$\begingroup$

Edit on the general solution:

As we can see, from 2 to 9 the survival rate is increasing monotonously, and there seems to be no way to add a new point into the above solution of 9 without increasing death, so my general conjecture is: for any $n$ points ($n$ been fixed), the solution reaching max survival number is to divide $n$ points to clusters of size 2 to 9 and far from each other, with priorties on those with higher survival rates.

The code is as following:

Clear[survivalPredict]
survivalPredict[numOfPoints_Integer] /; numOfPoints >= 2 :=
    Module[{factorSet = {}, survivalNum = {7, 6, 5, 4, 3, 2, 1, 0}},
        Fold[
            Function[{remain, clusterSize},
                AppendTo[factorSet, Quotient[remain, clusterSize]];
                Mod[remain, clusterSize]
                ],
            numOfPoints,
            Reverse@Range[2, 9]
            ];
        factorSet.survivalNum
        ]

(Note if there is 1 single point left, e.g. for survivalPredict[10], it won't increse or decrease the survival number.)

Compare it to OP's guess on Math.StackExchange:

Module[{numOfPoints, numOfSurvivals, opsGuess},
    {numOfPoints, numOfSurvivals, 
            opsGuess} = {#, survivalPredict[#], 
                        If[# <= 8, # - 2, # - Floor[#/3]]} & /@ Range[2, 44];
    opsGuess = 
        MapThread[
            If[#2 == 1, 
                    Item[#1, Background -> Hue[0, 0.13, 1]], #1] &, {opsGuess, 
                Unitize[opsGuess - numOfSurvivals]}];
    Grid[Prepend[{numOfPoints, numOfSurvivals, opsGuess}, 
                StringSplit[
                    "# of men,# of survivals: my guess,# of survivals: OP's guess", 
                    ","]]]
    ]

general solutions

An example solution for 44 points:

Mathematica graphics

The original answer

This is not a complete answer, the main idea is to show that at the situation of 9 men, the number of survivals can reach 7 instead of 6 (as guessed by OP).

The code is as following, use mouse to drag the nodes, Alt + click to create/delete a node, solid nodes are the deads while holo ones are survivals. Basically you want to place new node both outside any red circles and inside the Voronoi region of an already-dead node.

Needs["ComputationalGeometry`"]

Clear[survivalFunc]
survivalFunc[posLst_] /; 
        MatchQ[posLst, {{_Real, _Real} ..}] :=
    Module[{nearestFunc, deads},
        nearestFunc = Nearest[posLst];
        deads = nearestFunc[#, 2][[2]] & /@ posLst;
        Complement[posLst, deads]
        ]

Clear[virtualize]
virtualize[posLst_] /; 
        MatchQ[posLst, {{_Real, _Real} ..}] :=
    Module[{nearestFunc},
        nearestFunc = Nearest[posLst];
        Show[{
                Disk[#, Norm[# - nearestFunc[#, 2][[2]]]] & /@ posLst // 
                    Graphics[
                            Join[{EdgeForm[Opacity[.4, Hue[0, 0.29, 1]]], 
                                    Opacity[.1, Hue[0, 0.21, 1]]}, #]] &,
                 Graphics[{Hue[0.1, 0.28, 0.89], 
                        Cases[DiagramPlot[posLst], _Line, ∞]}],

                NearestNeighborGraph[posLst],

                Graphics[{
                        AbsolutePointSize[10], Hue[0.6, 0.51, 0.73],
                        Point[posLst],
                        AbsolutePointSize[6], White,
                        Point[survivalFunc[posLst]]
                        }]
                }, Frame -> True, PlotRange -> 2 {{-1, 1}, {-1, 1}}, 
            ImageSize -> Scaled[1]]
        ]

DynamicModule[{pts = N@{{-.3, 0}, {.3, 0}}}, 
    LocatorPane[Dynamic[pts], 
                Dynamic[virtualize@pts], 
                Appearance -> None, LocatorAutoCreate -> True]
        ]

solution of 9

And of course this solution of 9 can be "stacked" to get a solution of 18:

solution of 18

And the similar strategy can give 9 survivals out of 12 (instead of OP's guess on math.SE which is $12-\lfloor 12/3 \rfloor = 8$):

Mathematica graphics

$\endgroup$
4
  • $\begingroup$ looks good to me :) Upper bound improved! :D - Do you think this (ie strings of 9 in these arraqngements) is optimal? I am guessing not, and there may well be a more complex underlying structure to the upper bounds problem. Please feel free to correct me if I am being slow, and have missed something obvious in your answer about his already! $\endgroup$
    – martin
    Oct 18, 2015 at 16:54
  • 1
    $\begingroup$ @martin Regarding the more complex structure, I suspect the some as you. But right now this cluster solution is the best I can shape. (And I also have a small bit of belief that this might be the optimized one as I failed to see any other strategies.) $\endgroup$
    – Silvia
    Oct 19, 2015 at 1:40
  • $\begingroup$ @martin Thanks for the acceptance and the bounty! I thought about the problem today. I think another way to rephrase it is think it like a crystal/lattice with imperfection. A solution might be found by trying all kinds of perturbations around the shape of a perfect triangle mesh. $\endgroup$
    – Silvia
    Oct 19, 2015 at 17:52
  • $\begingroup$ It was a difficult decision, but what swayed it for me was that it answered the question of the upper bound directly. I think you are right, it is not a straightforward problem, and I will conditue to explore via your code & possible lattice structures. If you decide to play any further with it, please update answer to include any developments! Thanks once again :) $\endgroup$
    – martin
    Oct 19, 2015 at 18:04
15
$\begingroup$

(Notebook: https://github.com/arnoudbuzing/rifleproblem)

OK, this is not a full blown solution (I can delete it when there is a real answer), but perhaps a useful tool to help others get a feel for the problem:

RifleProblem[n_Integer] := DynamicModule[{rifle, shot, nearest},
  rifle = RandomReal[1, {n, 2}];
  Deploy[
   Graphics[{
     Dynamic[
      Arrow[shot = 
        Table[{Part[rifle, j], 
          First[Nearest[
            Table[Part[rifle, i], {i, Delete[Range[n], j]}], 
            Part[rifle, j]]]}, {j, n}]]],
     {Opacity[0.5], 
      Table[With[{i = i}, 
        Dynamic[If[Not@MemberQ[shot[[All, 2]], Part[rifle, i]], 
          Disk[Part[rifle, i], 
           EuclideanDistance[Part[rifle, i], 
            Part[shot, i, 2]]], {}]]], {i, n}]},
     Table[
      With[{i = i}, 
       Locator[Dynamic[Part[rifle, i]], 
        Dynamic[If[MemberQ[shot[[All, 2]], Part[rifle, i]], 
          Style["\[FreakedSmiley]", 36, Background -> Red], 
          Style["\[HappySmiley]", 36, Background -> Green]]]]], {i, n}]
     }, PlotRange -> {{0, 1}, {0, 1}}, 
    PlotLabel -> 
     Dynamic[Style[
       Framed["Survivors = " <> 
         ToString[n - Length[DeleteDuplicates[shot[[All, 2]]]]]], 16, 
       Orange, Background -> Black]]
    ]]]

For example, this lets you drag the locators in the graphic and experiment with how to optimize for the number of survivors:

enter image description here

$\endgroup$
4
  • $\begingroup$ @Arnould thanks -- certainly makes playing around with solutions a little easier :) $\endgroup$
    – martin
    Oct 13, 2015 at 14:02
  • $\begingroup$ Thanks... I'm going to play with this a bit to build my intuition. I think you're right about the upper bound for the n=10 case being 7. $\endgroup$ Oct 13, 2015 at 14:04
  • $\begingroup$ once you have placed the locators, is it possible to export the coordinates? $\endgroup$
    – martin
    Oct 14, 2015 at 13:08
  • $\begingroup$ nicely done! This is inspired!! :D $\endgroup$
    – martin
    Oct 16, 2015 at 23:32

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.