#!perl

sub find_transport {
   my ($pl) = @_;

   my $ob = $pl->ob;

   (grep $_->type == cf::TRANSPORT, map $_->head, $ob->map->at ($ob->x, $ob->y))[0]
      or do {
         $pl->detach ("transport_player_steer");
         ()
      }
}

cf::object->attach (
   type     => cf::TRANSPORT,
   on_apply => sub {
      my ($tr, $ob) = @_;

      return unless $ob->type == cf::PLAYER;

      if ($ob->contr->attached ("transport_player_steer")) {
         $ob->message ("You stop steering the " . $tr->name . ".", cf::NDI_ORANGE | cf::NDI_REPLY);
         $ob->contr->detach ("transport_player_steer");
      } else {
         $ob->message ("You now steer the " . $tr->name . ".", cf::NDI_ORANGE | cf::NDI_REPLY);
         $ob->contr->attach ("transport_player_steer");
      }

      cf::override;
   },
);

cf::player::attachment transport_player_steer =>
   on_move => sub {
      my ($pl, $dir) = @_;

      my $ob = $pl->ob;

      if (my $tr = find_transport $pl) {
         return cf::override 0 unless $ob->speed_left >= 0;
         $ob->speed_left ($ob->speed_left - 1);

         my @ontop;

         for (my $tr = $tr; $tr; $tr = $tr->more) {
           for (my $ob = $tr->above; $ob; $ob = $ob->above) {
             push @ontop, $ob;
           }
         }

         if ($tr->move ($dir, $ob)) {
            # do multiple loops in case some player/item blocks another
            # do not endlessly loop as the server is far too broken, e.g.
            # you can drop floors on top of non-floors etc.
            for (1..50) {
               @ontop or last;
               @ontop = map $_->move ($dir, $_) ? () : $_, @ontop;
            }
         }

         cf::override 1;
      }
   },
;