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