Merge branch 'master' of git.rot13.org:/git/perl-airport-landing-game
[perl-landing-airplanes.git] / 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;