in reply to Re: Battleship solitaire puzzle generator
in thread Battleship solitaire puzzle generator

The rules of the game, as they were taught to me, disallowed immediately adjacent ships.

Another problem with placement is that you transpose unconditionally in the loop. E.g. the puzzle will always have size-three ships at right angles.

  • Comment on Re^2: Battleship solitaire puzzle generator

Replies are listed 'Best First'.
Re^3: Battleship solitaire puzzle generator
by Anonymous Monk on Aug 30, 2016 at 15:40 UTC

    Thanks. In my haste to get regexing I didn't read the rules very closely.

    Easily fixed, though: 

    #!/usr/bin/perl

# http://perlmonks.org/?node_id=1170733

use strict;
use warnings;

my $sea = ((' ' x 10) . "\n") x 10;

sub transpose
  {
  local $_ = $sea;
  tr/<>^v/^v<>/;
  $sea = '';
  $sea .= "\n" while s/^(.)/ $sea .= $1; '' /gem;
  }

for my $ship ( 4,3,3,2,2,2,1,1,1,1 )
  {
  my @places;
  push @places, $-[0] while $sea =~ /(?= {$ship})/g;
  substr $sea, $places[rand @places], $ship,
    ('O', '<>', '<#>', '<##>' )[$ship - 1];
  for (0, 9, 11, 0, 9, 11)
    {
    $sea =~ s/(?<=[<>^v#O].{$_}) | (?=.{$_}[<>^v#O])/~/gs;
    transpose;
    }
  rand > 0.5 and transpose;
  }
tr/ /~/ for $sea;

print $sea;
my @chars = $sea =~ /./g;

use Tk; # for http://perlmonks.org/?node_id=1170638

my $mw = MainWindow->new( -title => "Battleship" );
for my $y (0..9)
  {
  for my $x (0..9)
    {
    my ($char, $b) = shift @chars;
    $b = $mw->Button( -font => 'courier 24', -text => ' ',
      -command => sub {$b->configure(-text => $char) },
      )->grid(-row => $y, -column => $x);
    }
  }

MainLoop;

    [download]
[reply]
[d/l]
      Thanks for the code. The Tk code should be a good starting point for anyone who wants to build a GUI version. It looks like your code creates a solution (with all 10 ships completely placed in the grid), but it does not create a puzzle grid (with only ship segments shown, along with row and column counts of the hidden ships as clues).
[reply]

        Try this one. Converted over to Canvas to draw ship parts. And of course it's in SeaGreen :)

        Hey, still below 100 lines :) 

        #!/usr/bin/perl

# http://perlmonks.org/?node_id=1170733

use strict;
use warnings;

my $total = 0;
my $sea = ((' ' x 10) . "\n") x 10;

sub transpose
  {
  local $_ = $sea;
  tr/<>^v/^v<>/;
  $sea = '';
  $sea .= "\n" while s/^(.)/ $sea .= $1; '' /gem;
  }

for my $ship ( 4,3,3,2,2,2,1,1,1,1 )
  {
  $total += $ship;
  my @places;
  push @places, $-[0] while $sea =~ /(?= {$ship})/g;
  substr $sea, $places[rand @places], $ship,
    ('O', '<>', '<#>', '<##>' )[$ship - 1];
  $sea =~ s/(?<=[<>^v#O].{$_}) | (?=.{$_}[<>^v#O])/~/gs for 0, 9..11;
  rand > 0.5 and transpose;
  }
tr/ /~/ for $sea;

print $sea;
my @chars = $sea =~ /./g;

use Tk; # for http://perlmonks.org/?node_id=1170638

my $hits = my $misses = 0;
my $font = 'courier 20';
my $canvassize = 40;
my $message = 'Click Square to Play';
my $msg;

my $mw = MainWindow->new( -title => "Battleship" );
my $grid = $mw->Frame()->pack;
my (@cols, @rows);
for my $y (0..9)
  {
  for my $x (0..9)
    {
    my ($char, $c) = shift @chars;
    $cols[$x] += $char =~ /[<>^v#O]/;
    $rows[$y] += $char =~ /[<>^v#O]/;
    $c = $grid->Canvas( -bg => 'SeaGreen3',
      -width => $canvassize, -height => $canvassize,
      -highlightthickness => 1, -highlightbackground => 'black',
      )->grid(-row => $y, -column => $x);
    $c->Tk::bind('<ButtonRelease-1>' => sub {

      if( $char eq '~') {$c->configure(-bg => 'SeaGreen4'); }
      if( $char =~ /[<>^v#O]/ ) {
        $c->createOval(1, 1, $canvassize, $canvassize, -fill => 'black
+') }
      if($char eq '#') {$c->createRectangle(0, 0,
        $canvassize, $canvassize, -fill => 'black') }
      elsif($char eq '<') {$c->createRectangle($canvassize / 2, 0,
        $canvassize, $canvassize, -fill => 'black') }
      elsif($char eq '>') {$c->createRectangle(0, 0,
        $canvassize / 2, $canvassize, -fill => 'black') }
      elsif($char eq 'v') {$c->createRectangle(0, 0,
        $canvassize, $canvassize / 2, -fill => 'black') }
      elsif($char eq '^') {$c->createRectangle(0, $canvassize / 2,
        $canvassize, $canvassize, -fill => 'black') }

      ($char =~ /[<>^v#O]/ ? $hits : $misses) += 1;
      $hits == $total and $message = "You Win !",
        $msg->configure(-fg => 'green3', -font => 'courierbold 24');
      $c->Tk::bind('<ButtonRelease-1>'=> sub {});
      });
    }
  }
for my $i (0..9)
  {
  $grid->Label(-text => $cols[$i], -font =>$font,
    )->grid(-row => 11, -column => $i, -sticky => 'nsew');
  $grid->Label(-text => $rows[$i], -font =>$font,
    )->grid(-row => $i, -column => 11, -sticky => 'nsew');
  }
$grid->Label(-text => ' ',
    )->grid(-row => 11, -column => 11, -sticky => 'nsew');
my $frame = $mw->Frame->pack;
$frame->Label(-text => 'Hits: ', -font => $font)->pack(-side => 'left'
+);
$frame->Label(-textvariable => \$hits, -font => $font)->pack(-side => 
+'left');
$frame->Label(-text => " of $total   Misses: ", -font => $font,
  )->pack(-side => 'left');
$frame->Label(-textvariable => \$misses, -font => $font)->pack(-side =
+> 'left');
$msg = $mw->Label(-textvariable => \$message, -font => $font)->pack;

MainLoop;

        [download]
[reply]
[d/l]

        I'm not really interested in playing the game, I was just interested in generating the starting grid as a programming puzzle.

        Then I just wanted to see how hard it would be to display the grid in Tk (not too hard).

        Hey, at least the buttons work...

[reply]

        Better ? ( It took less work than I thought to add some features :) 

        #!/usr/bin/perl

# http://perlmonks.org/?node_id=1170733

use strict;
use warnings;

my $total = 0;
my $sea = ((' ' x 10) . "\n") x 10;

sub transpose
  {
  local $_ = $sea;
  tr/<>^v/^v<>/;
  $sea = '';
  $sea .= "\n" while s/^(.)/ $sea .= $1; '' /gem;
  }

for my $ship ( 4,3,3,2,2,2,1,1,1,1 )
  {
  $total += $ship;
  my @places;
  push @places, $-[0] while $sea =~ /(?= {$ship})/g;
  substr $sea, $places[rand @places], $ship,
    ('O', '<>', '<#>', '<##>' )[$ship - 1];
  $sea =~ s/(?<=[<>^v#O].{$_}) | (?=.{$_}[<>^v#O])/~/gs for 0, 9..11;
  rand > 0.5 and transpose;
  }
tr/ /~/ for $sea;

print $sea;
my @chars = $sea =~ /./g;

use Tk; # for http://perlmonks.org/?node_id=1170638

my $hits = my $misses = 0;
my $font = 'courier 20';
my $message = 'Click Square to Play';
my $msg;

my $mw = MainWindow->new( -title => "Battleship" );
my $grid = $mw->Frame->pack;
my (@cols, @rows);
for my $y (0..9)
  {
  for my $x (0..9)
    {
    my ($char, $b) = shift @chars;
    $cols[$x] += $char =~ /[<>^v#O]/;
    $rows[$y] += $char =~ /[<>^v#O]/;
    $b = $grid->Button( -font =>$font, -text => ' ',
      -command => sub {
        $b->configure(-text => $char);
        ($char =~ /[<>^v#O]/ ? $hits : $misses) += 1;
        $hits == $total and $message = "You Win !",
          $msg->configure(-fg => 'green', -font => 'courierbold 24');
        $b->configure(-command => sub {});
        },
      )->grid(-row => $y, -column => $x);
    }
  }
for my $i (0..9)
  {
  $grid->Label(-text => $cols[$i], -font =>$font,
    )->grid(-row => 11, -column => $i);
  $grid->Label(-text => $rows[$i], -font =>$font,
    )->grid(-row => $i, -column => 11);
  }
my $frame = $mw->Frame->pack;
$frame->Label(-text => 'Hits: ', -font => $font)->pack(-side => 'left'
+);
$frame->Label(-textvariable => \$hits, -font => $font)->pack(-side => 
+'left');
$frame->Label(-text => " of $total   Misses: ", -font => $font,
  )->pack(-side => 'left');
$frame->Label(-textvariable => \$misses, -font => $font)->pack(-side =
+> 'left');
$msg = $mw->Label(-textvariable => \$message, -font => $font)->pack;

MainLoop;

        [download]
[reply]
[d/l]

In Section Cool Uses for Perl