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::object->attach ( |
16 |
type => cf::TRANSPORT, |
17 |
on_apply => sub { |
18 |
my ($tr, $ob) = @_; |
19 |
|
20 |
return unless $ob->type == cf::PLAYER; |
21 |
|
22 |
if ($ob->contr->attached ("transport_player_steer")) { |
23 |
$ob->message ("You stop steering the " . $tr->name . ".", cf::NDI_ORANGE | cf::NDI_REPLY); |
24 |
$ob->contr->detach ("transport_player_steer"); |
25 |
} else { |
26 |
$ob->message ("You now steer the " . $tr->name . ".", cf::NDI_ORANGE | cf::NDI_REPLY); |
27 |
$ob->contr->attach ("transport_player_steer"); |
28 |
} |
29 |
|
30 |
cf::override; |
31 |
}, |
32 |
); |
33 |
|
34 |
cf::player::attachment transport_player_steer => |
35 |
on_move => sub { |
36 |
my ($pl, $dir) = @_; |
37 |
|
38 |
my $ob = $pl->ob; |
39 |
|
40 |
if (my $tr = find_transport $pl) { |
41 |
return cf::override 0 unless $ob->speed_left >= 0; |
42 |
$ob->speed_left ($ob->speed_left - 1); |
43 |
|
44 |
my @ontop; |
45 |
|
46 |
for (my $tr = $tr; $tr; $tr = $tr->more) { |
47 |
for (my $ob = $tr->above; $ob; $ob = $ob->above) { |
48 |
push @ontop, $ob; |
49 |
} |
50 |
} |
51 |
|
52 |
if ($tr->move ($dir, $ob)) { |
53 |
# do multiple loops in case some player/item blocks another |
54 |
# do not endlessly loop as the server is far too broken, e.g. |
55 |
# you can drop floors on top of non-floors etc. |
56 |
for (1..50) { |
57 |
@ontop or last; |
58 |
@ontop = map $_->move ($dir, $_) ? () : $_, @ontop; |
59 |
} |
60 |
} |
61 |
|
62 |
cf::override 1; |
63 |
} |
64 |
}, |
65 |
; |
66 |
|