in reply to Re^4: Battleship solitaire puzzle generator
in thread Battleship solitaire puzzle generator
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;
|
|---|