| 1 |
root |
1.1 |
#! perl |
| 2 |
|
|
|
| 3 |
|
|
use Scalar::Util; |
| 4 |
|
|
|
| 5 |
|
|
# minesweeper extension. dumb. |
| 6 |
|
|
|
| 7 |
root |
1.3 |
sub result { |
| 8 |
|
|
my ($ob, $status) = @_; |
| 9 |
|
|
|
| 10 |
|
|
if (my $teleport = $ob->{options}{"teleport_$status"}) { |
| 11 |
|
|
my ($x, $y) = split /,/, $teleport; |
| 12 |
|
|
|
| 13 |
|
|
(cf::player::find $ob->{player})->ob->transfer ($x, $y); |
| 14 |
|
|
} |
| 15 |
|
|
} |
| 16 |
|
|
|
| 17 |
root |
1.2 |
sub apply { |
| 18 |
|
|
my ($who) = @_; |
| 19 |
|
|
|
| 20 |
|
|
my $meta = $who->{meta} |
| 21 |
|
|
or return; |
| 22 |
|
|
|
| 23 |
|
|
my $map = $meta->{map}; |
| 24 |
|
|
|
| 25 |
|
|
my ($x, $y) = ($who->x - $meta->x, $who->y - $meta->y); |
| 26 |
|
|
|
| 27 |
|
|
$who->{visible} = 1; |
| 28 |
|
|
|
| 29 |
|
|
if ($who->{bomb}) { |
| 30 |
root |
1.3 |
result $meta, "failure"; |
| 31 |
root |
1.2 |
} else { |
| 32 |
|
|
$meta->{todo}--; |
| 33 |
|
|
# if zero, finished |
| 34 |
|
|
|
| 35 |
|
|
my @neigh; |
| 36 |
|
|
|
| 37 |
|
|
for my $y ($y - 1 .. $y + 1) { |
| 38 |
|
|
next if $y < 0 || $y > $#{$map->[0]}; |
| 39 |
|
|
for my $x ($x - 1 .. $x + 1) { |
| 40 |
|
|
next if $x < 0 || $x > $#$map; |
| 41 |
|
|
push @neigh, $map->[$x][$y]; |
| 42 |
|
|
} |
| 43 |
|
|
} |
| 44 |
|
|
|
| 45 |
|
|
my $bombs = grep $_->{bomb}, @neigh; |
| 46 |
|
|
|
| 47 |
|
|
my $ob = $map->[$x][$y] = cf::object::new "minesweeper-$bombs"; |
| 48 |
|
|
|
| 49 |
|
|
$ob->insert_ob_in_map_at ($who->map, undef, cf::INS_ABOVE_FLOOR_ONLY, |
| 50 |
|
|
$who->x, $who->y); |
| 51 |
|
|
|
| 52 |
|
|
push @{ $meta->{queue} }, grep !$_->{visible}, @neigh |
| 53 |
|
|
unless $bombs; |
| 54 |
|
|
|
| 55 |
|
|
$who->remove; |
| 56 |
|
|
$who->free; |
| 57 |
|
|
} |
| 58 |
root |
1.6 |
|
| 59 |
|
|
1 |
| 60 |
root |
1.2 |
} |
| 61 |
|
|
|
| 62 |
root |
1.1 |
sub on_time { |
| 63 |
root |
1.7 |
my ($event, $who) = @_; |
| 64 |
root |
1.1 |
|
| 65 |
root |
1.2 |
if (my $queue = $who->{queue}) { |
| 66 |
root |
1.3 |
my $count = 4; |
| 67 |
|
|
|
| 68 |
root |
1.2 |
while (@$queue) { |
| 69 |
|
|
my $i = int rand @$queue; |
| 70 |
|
|
my $ob = splice @$queue, $i, 1, (); |
| 71 |
|
|
|
| 72 |
|
|
next if $ob->{visible}; |
| 73 |
|
|
|
| 74 |
|
|
apply $ob |
| 75 |
|
|
or next; |
| 76 |
|
|
|
| 77 |
root |
1.3 |
result $who, "success" |
| 78 |
|
|
unless $who->{todo}; |
| 79 |
|
|
|
| 80 |
|
|
$count-- |
| 81 |
|
|
or last; |
| 82 |
root |
1.2 |
} |
| 83 |
|
|
} else { |
| 84 |
|
|
# generate minesweeper field |
| 85 |
root |
1.7 |
my %arg = split /(?:\s+|=)/, $event->options; |
| 86 |
root |
1.1 |
|
| 87 |
root |
1.3 |
$who->{options} = \%arg; |
| 88 |
root |
1.2 |
$who->{queue} = []; |
| 89 |
root |
1.1 |
|
| 90 |
|
|
my $map = $who->{map} = []; |
| 91 |
|
|
|
| 92 |
root |
1.2 |
for my $x (0 .. $arg{width} - 1) { |
| 93 |
|
|
for my $y (0 .. $arg{height} - 1) { |
| 94 |
root |
1.1 |
my $ob = $map->[$x][$y] = cf::object::new "minesweeper-unknown"; |
| 95 |
root |
1.2 |
$ob->set_name ("apply to try your luck or intelligence"); |
| 96 |
root |
1.1 |
Scalar::Util::weaken ($ob->{meta} = $who); |
| 97 |
|
|
|
| 98 |
|
|
my $ev = cf::object::new "event_apply"; |
| 99 |
|
|
$ev->set_title ("perl"); |
| 100 |
|
|
$ev->set_slaying ("minesweeper"); |
| 101 |
|
|
$ev->insert_in_ob ($ob); |
| 102 |
|
|
|
| 103 |
root |
1.2 |
$ob->insert_ob_in_map_at ($who->map, undef, cf::INS_ABOVE_FLOOR_ONLY, |
| 104 |
|
|
$who->x + $x, $who->y + $y); |
| 105 |
root |
1.1 |
} |
| 106 |
|
|
} |
| 107 |
|
|
|
| 108 |
root |
1.2 |
# #tiles that need to be uncovered |
| 109 |
|
|
$who->{todo} = $arg{width} * $arg{height} - $arg{bombs}; |
| 110 |
|
|
|
| 111 |
|
|
for (1 .. $arg{bombs}) { |
| 112 |
|
|
my $x = int rand $arg{width}; |
| 113 |
|
|
my $y = int rand $arg{height}; |
| 114 |
|
|
|
| 115 |
|
|
redo if $map->[$x][$y]{bomb}; |
| 116 |
root |
1.1 |
|
| 117 |
root |
1.2 |
$map->[$x][$y]{bomb} = 1; |
| 118 |
|
|
} |
| 119 |
|
|
} |
| 120 |
root |
1.1 |
} |
| 121 |
|
|
|
| 122 |
|
|
sub on_apply { |
| 123 |
root |
1.7 |
my ($event, $ob, $who) = @_; |
| 124 |
root |
1.1 |
|
| 125 |
root |
1.7 |
$ob->{meta}{player} = $who->name; |
| 126 |
|
|
push @{$ob->{meta}{queue}}, $ob; |
| 127 |
root |
1.5 |
|
| 128 |
|
|
1 |
| 129 |
root |
1.1 |
} |
| 130 |
|
|
|
| 131 |
|
|
|
