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