trace-path.pl

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5
   6 use SDL::App;
   7 use SDL::Rect;
   8 use SDL::Color;
   9 use SDL::Constants;
  10 use SDL::Event;
  11 use Math::CatmullRom;
  12 use Algorithm::Line::Bresenham qw(line);
  13
  14 use Carp qw(cluck);
  15 use Data::Dump qw(dump);
  16
  17 use Airplane;
  18 our @airplanes;
  19
  20 our $debug = 0;
  21
  22 my ( $w, $h ) = ( 800, 480 );
  23 my $mouse_trashold = 10;
  24 my $max_path_length = 200;
  25
  26 our $mouse_color = SDL::Color->new( 0x00, 0x00, 0x80 );
  27 our $path_color  = SDL::Color->new( 0xff, 0xff, 0x80 );
  28 our $black       = SDL::Color->new( 0x00, 0x00, 0x00 );
  29
  30 sub debug {
  31         return unless $debug;
  32         my ($package, $filename, $line) = caller;
  33         warn '# ', dump( @_ ), " $filename +$line\n";
  34 }
  35
  36 our $app = SDL::App->new(
  37         -width  => $w,
  38         -height => $h,
  39         -depth  => 16,
  40 #       -flags=>SDL_DOUBLEBUF | SDL_HWSURFACE | SDL_HWACCEL,
  41         -title  => 'Trace mouse',
  42 );
  43
  44 our @masks;
  45 our @landings;
  46 foreach my $path ( glob 'artwork/world1/*mask*.png' ) {
  47
  48         warn "mask $path ", -s $path, " bytes\n";
  49
  50         my $mask = SDL::Surface->new(
  51                 -name => $path,
  52                 -depth => 24,
  53         );
  54         push @masks, $mask;
  55
  56         $mask->blit( $mask->rect, $app );
  57         $app->sync;
  58
  59         my @landing;
  60         my $mask_step = 10;
  61
  62         my $y = 0;
  63         foreach ( 0 .. $mask->height / $mask_step ) {
  64                 printf "%3d: ", $_;
  65                 my $x = 0;
  66                 foreach ( 0 .. $mask->width / $mask_step ) {
  67                         my $col = $mask->pixel( $x, $y );
  68                         my $nr = 0;
  69                         $nr += 4 if $col->r;
  70                         $nr += 2 if $col->g;
  71                         $nr += 1 if $col->b;
  72                         $landing[$nr] = [ $x, $y ] unless defined $landing[$nr];
  73                         printf "%02x%02x%02x:%d ", $col->r, $col->g, $col->b, $nr;
  74                         $x += $mask_step;
  75                 }
  76                 print "\n";
  77                 $y += $mask_step;
  78         }
  79
  80         warn "lading for $path ",dump(@landing);
  81
  82         push @landings, [ @landing ];
  83 }
  84
  85 my $current_mask = 0;
  86
  87 warn "# masks ",dump(@masks), " landings ", dump(@landings);
  88
  89 sub mask_hex {
  90         my ( $i, $x, $y ) = @_;
  91
  92         my $col = $masks[$i]->pixel( $x, $y );
  93         my $hex = sprintf '%02x%02x%02x', $col->r, $col->g, $col->b;
  94         warn "mask $x $y $hex\n";
  95         return $hex;
  96 }
  97
  98 sub lading_points {
  99         my ( $x, $y ) = @_;
 100         my @points;
 101         foreach my $i ( 0 .. $#masks ) {
 102                 my $hex = mask_hex( $i, $x, $y );
 103                 if ( $hex eq '000000' ) {
 104                         warn "lading point $x $y from mask $i hex $hex\n";
 105                         foreach ( 1 .. 6 ) {
 106                                 push @points,
 107                                         $landings[$i]->[$_]->[0],
 108                                         $landings[$i]->[$_]->[1];
 109                         }
 110                 } else {
 111                         debug $x, $y, $i, $hex, 'ignored';
 112                 }
 113                 warn "mask $i points ",dump( @points );
 114         }
 115         return @points;
 116 }
 117
 118 our $event = SDL::Event->new;
 119
 120 our $mouse_down = 0;
 121
 122 my ( $last_x, $last_y ) = ( 0,0 );
 123
 124 our @path;
 125 sub reset_path { @path = () }
 126
 127 sub curve_catmull_rom {
 128
 129         if ( $#path < ( 4 * 2 - 1 ) ) { # less than 4 points
 130                 warn "path too short ", dump @path;
 131                 reset_path;
 132                 return;
 133         }
 134
 135         my $curve = Math::CatmullRom->new( @path );
 136         my $points = $#path + 1 - 4; # remove start/end points
 137         my @curve = $curve->curve( $points );
 138         debug 'curve' => @curve;
 139
 140         my $i = 0;
 141         while ( $i <= $#curve - 4 ) {
 142                 line(
 143                         int($curve[$i++]),
 144                         int($curve[$i++]),
 145                         int($curve[$i++]),
 146                         int($curve[$i++]),
 147                         sub { $app->pixel( @_, $path_color ) }
 148                 );
 149         }
 150         push @airplanes, Airplane->new( $app );
 151         $airplanes[-1]->set_path( @path );
 152         $app->sync;
 153         reset_path;
 154 }
 155
 156 sub curve {
 157         # add landing path points
 158         push @path, lading_points( $path[-2], $path[-1] ) if $#path > 1;
 159
 160         if ( 1 ) {
 161                 curve_catmull_rom;
 162         } else {
 163
 164         }
 165
 166 }
 167
 168 sub clear_screen {
 169         my ( $mask ) = @_;
 170         reset_path;
 171         $app->fill( $app->rect, $black );
 172         if ( defined $mask ) {
 173                 warn "clear_screen $mask";
 174                 $masks[$current_mask]->blit( $masks[$current_mask]->rect, $app, $app->rect );
 175         } else {
 176                 warn "clear_screen all masks";
 177                 $_->blit( $_->rect, $app, $app->rect ) foreach @masks;
 178         }
 179         $app->sync;
 180 }
 181
 182 sub handle_events {
 183
 184         while ( $event->poll ) {
 185                 my $type = $event->type();
 186
 187                 if ( $type == SDL_MOUSEBUTTONDOWN() ) {
 188                         debug 'mouse down', $event->button_x, $event->button_y;
 189                         $mouse_down = 1;
 190                 } elsif ( $type == SDL_MOUSEBUTTONUP() ) {
 191                         debug 'mouse up', $event->button_x, $event->button_y;
 192                         $mouse_down = 0;
 193                         curve;
 194                 } elsif ( $type == SDL_QUIT() ) {
 195                         exit;
 196                 } elsif ( $type == SDL_KEYDOWN() ) {
 197                         my $key = $event->key_name;
 198                         warn 'key down', $key, $/;
 199                         exit if $key =~ m/^[xq]$/;
 200                         if ( $key eq 's' ) { # XXX draw curve
 201                                 curve;
 202                         } elsif ( $key eq 'backspace' || $key eq 'c' ) { # XXX clean screen
 203                                 clear_screen;
 204                         } elsif ( $key eq 'd' ) { # XXX toggle debug
 205                                 $debug = ! $debug;
 206                                 warn "debug $debug\n";
 207                         } elsif ( $key eq 'm' ) { # XXX cycle masks
 208                                 $current_mask++;
 209                                 $current_mask = 0 if $current_mask > $#masks;
 210                                 clear_screen $current_mask;
 211                         } else {
 212                                 warn "unknown key $key";
 213                         }
 214                 } elsif ( $type == SDL_KEYUP() ) {
 215                         debug 'key up', $event->key_name;
 216                 } elsif ( $type == SDL_MOUSEMOTION() ) {
 217                         my ( $x, $y ) = ( $event->motion_x, $event->motion_y );
 218                         #debug 'mouse', $mouse_down, $x, $y;
 219                         my $d = sqrt( ( $x - $last_x ) ** 2 + ( $y - $last_y ) ** 2 );
 220                         if ( $mouse_down && $d > $mouse_trashold ) {
 221                                 if ( $#path < $max_path_length ) {
 222                                         push @path, $x, $y;
 223                                         my $rect = SDL::Rect->new( -x => $event->motion_x - 1, -y => $event->motion_y -1 , -w => 3, -h => 3 );
 224                                         $app->fill( $rect, $mouse_color );
 225                                         $app->update( $rect );
 226                                         $last_x = $x;
 227                                 $last_y = $y;
 228                                 } else {
 229                                         $mouse_down = 0;
 230                                         curve;
 231                                 }
 232                         }
 233                 } else {
 234                         warn "unknown type $type\n";
 235                 }
 236         }
 237 };
 238
 239 while(1) {
 240         handle_events;
 241         $_->draw foreach @airplanes;
 242         $app->delay(50);
 243         $app->sync;
 244 }
 245
 246 1;