12 use Algorithm::Line::Bresenham qw(line);
16 use Data::Dump qw(dump);
23 my ( $w, $h ) = ( 800, 480 );
24 my $mouse_trashold = 10;
25 my $max_path_length = 200;
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 );
33 my ($package, $filename, $line) = caller;
34 warn '# ', dump( @_ ), " $filename +$line\n";
37 our $app = SDL::App->new(
41 # -flags=>SDL_DOUBLEBUF | SDL_HWSURFACE | SDL_HWACCEL,
42 -title => 'Trace mouse',
47 foreach my $path ( glob 'artwork/world1/*mask*.png' ) {
49 warn "mask $path ", -s $path, " bytes\n";
51 my $mask = SDL::Surface->new(
57 $mask->blit( $mask->rect, $app );
64 foreach ( 0 .. $mask->height / $mask_step ) {
67 foreach ( 0 .. $mask->width / $mask_step ) {
68 my $col = $mask->pixel( $x, $y );
73 $landing[$nr] = [ $x, $y ] unless defined $landing[$nr];
74 printf "%02x%02x%02x:%d ", $col->r, $col->g, $col->b, $nr;
81 warn "lading for $path ",dump(@landing);
83 push @landings, [ @landing ];
88 warn "# masks ",dump(@masks), " landings ", dump(@landings);
91 my ( $i, $x, $y ) = @_;
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";
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";
108 $landings[$i]->[$_]->[0],
109 $landings[$i]->[$_]->[1];
112 debug $x, $y, $i, $hex, 'ignored';
114 warn "mask $i points ",dump( @points );
119 our $event = SDL::Event->new;
123 my ( $last_x, $last_y ) = ( 0,0 );
126 sub reset_path { @path = () }
128 sub curve_catmull_rom {
130 if ( $#path < ( 4 * 2 - 1 ) ) { # less than 4 points
131 warn "path too short ", dump @path;
136 my $curve = Math::CatmullRom->new( @path );
137 my $points = $#path + 1 - 4; # remove start/end points
138 return $curve->curve( $points );
142 my $curve = Math::Bezier->new( @path );
143 return $curve->curve( $#path + 1 );
149 # add landing path points
150 push @path, lading_points( $path[-2], $path[-1] ) if $#path > 1;
154 my @curve = $curve_type ? curve_catmull_rom : curve_bezier;
155 debug 'curve' => @curve;
158 while ( $i <= $#curve - 4 ) {
164 sub { $app->pixel( @_, $path_color ) }
169 push @airplanes, Airplane->new( $app );
170 $airplanes[-1]->set_path( @curve );
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 );
182 warn "clear_screen all masks";
183 $_->blit( $_->rect, $app, $app->rect ) foreach @masks;
190 while ( $event->poll ) {
191 my $type = $event->type();
193 if ( $type == SDL_MOUSEBUTTONDOWN() ) {
194 debug 'mouse down', $event->button_x, $event->button_y;
196 } elsif ( $type == SDL_MOUSEBUTTONUP() ) {
197 debug 'mouse up', $event->button_x, $event->button_y;
200 } elsif ( $type == SDL_QUIT() ) {
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
208 } elsif ( $key eq 'backspace' || $key eq 'c' ) { # XXX clean screen
210 } elsif ( $key eq 'd' ) { # XXX toggle debug
212 warn "debug $debug\n";
213 } elsif ( $key eq 'm' ) { # XXX cycle masks
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;
220 warn "unknown key $key";
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 ) {
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 );
242 warn "unknown type $type\n";
249 $_->draw foreach @airplanes;