| 1 |
root |
1.1 |
#!perl |
| 2 |
|
|
|
| 3 |
|
|
sub find_transport { |
| 4 |
|
|
my ($pl) = @_; |
| 5 |
|
|
|
| 6 |
|
|
my $ob = $pl->ob; |
| 7 |
|
|
|
| 8 |
|
|
(grep $_->type == cf::TRANSPORT, map $_->head, $ob->map->at ($ob->x, $ob->y))[0] |
| 9 |
|
|
or do { |
| 10 |
|
|
$pl->detach ("transport_player_steer"); |
| 11 |
|
|
() |
| 12 |
|
|
} |
| 13 |
|
|
} |
| 14 |
|
|
|
| 15 |
|
|
cf::attach_to_type cf::TRANSPORT, 0, |
| 16 |
|
|
on_apply => sub { |
| 17 |
|
|
my ($tr, $ob) = @_; |
| 18 |
|
|
|
| 19 |
|
|
return unless $ob->type == cf::PLAYER; |
| 20 |
|
|
|
| 21 |
|
|
if ($ob->contr->attached ("transport_player_steer")) { |
| 22 |
|
|
$ob->message ("You stop steering the " . $tr->name . "."); |
| 23 |
|
|
$ob->contr->detach ("transport_player_steer"); |
| 24 |
|
|
} else { |
| 25 |
|
|
$ob->message ("You now steer the " . $tr->name . "."); |
| 26 |
|
|
$ob->contr->attach ("transport_player_steer"); |
| 27 |
|
|
} |
| 28 |
|
|
|
| 29 |
|
|
cf::override; |
| 30 |
|
|
}, |
| 31 |
|
|
; |
| 32 |
|
|
|
| 33 |
|
|
cf::register_player_attachment transport_player_steer => |
| 34 |
|
|
on_move => sub { |
| 35 |
|
|
my ($pl, $dir) = @_; |
| 36 |
|
|
|
| 37 |
|
|
my $ob = $pl->ob; |
| 38 |
|
|
|
| 39 |
|
|
if (my $tr = find_transport $pl) { |
| 40 |
|
|
my @ontop; |
| 41 |
|
|
|
| 42 |
|
|
for (my $tr = $tr; $tr; $tr = $tr->more) { |
| 43 |
|
|
for (my $ob = $tr->above; $ob; $ob = $ob->above) { |
| 44 |
|
|
push @ontop, $ob; |
| 45 |
|
|
} |
| 46 |
|
|
} |
| 47 |
|
|
|
| 48 |
|
|
if ($tr->move ($dir, $ob)) { |
| 49 |
|
|
# do multiple loops in case some player/item blocks another |
| 50 |
root |
1.2 |
# do not endlessly loop as the server is far too broken, e.g. |
| 51 |
root |
1.3 |
# you can drop floor son top of non-floors etc. |
| 52 |
root |
1.2 |
for (1..50) { |
| 53 |
|
|
@ontop or last; |
| 54 |
root |
1.1 |
@ontop = map $_->move ($dir, $_) ? () : $_, @ontop; |
| 55 |
|
|
} |
| 56 |
|
|
} |
| 57 |
|
|
|
| 58 |
|
|
cf::override; |
| 59 |
|
|
} |
| 60 |
|
|
}, |
| 61 |
|
|
; |
| 62 |
|
|
|
