Skip to content
Newer
Older
100644 449 lines (385 sloc) 14.2 KB
03a2370 initial
Tobias Leich authored
1 #!/usr/bin/perl
2
3 package Games::Solitaire;
4
5 use strict;
6 use warnings;
7 use Time::HiRes;
8
9 use SDL;
10 use SDL::Event;
11 use SDL::Events;
12 use SDL::Rect;
13 use SDL::Surface;
14 use SDL::Video;
15
16 use SDLx::SFont;
17 use SDLx::Surface;
18 use SDLx::Sprite;
19
20 use SDLx::LayerManager;
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
21 use SDLx::Layer;
22 use SDLx::FPS;
03a2370 initial
Tobias Leich authored
23
24 SDL::init(SDL_INIT_VIDEO);
01c25f6 merged with shlomif
Tobias Leich authored
25
225e2f1 proper names for card positions
Tobias Leich authored
26 my $WINDOW_WIDTH = 800;
01c25f6 merged with shlomif
Tobias Leich authored
27 my $WINDOW_HEIGHT = 600;
28
29 my $display = SDL::Video::set_video_mode(
30 $WINDOW_WIDTH, $WINDOW_HEIGHT, 32, SDL_HWSURFACE | SDL_HWACCEL
31 ); # SDL_DOUBLEBUF
32
03a2370 initial
Tobias Leich authored
33 my $layers = SDLx::LayerManager->new();
34 my $event = SDL::Event->new();
35 my $loop = 1;
36 my $last_click = Time::HiRes::time;
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
37 my $fps = SDLx::FPS->new(fps => 60);
03a2370 initial
Tobias Leich authored
38 my @selected_cards = ();
39 my $left_mouse_down = 0;
e09b49b all 'magic' numbers have names now
Tobias Leich authored
40 my @rewind_deck_1_position = ( 20, 20);
41 my @rewind_deck_1_hotspot = ( 40, 40);
42 my @rewind_deck_2_position = ( 130, 20);
43 my @rewind_deck_2_hotspot = ( 150, 40);
44 my @left_stack_position = ( 20, 200);
45 my @left_stack_hotspot = ( 40, 220);
46 my @left_target_position = ( 350, 20);
47 my @left_target_hotspot = ( 370, 40);
48 my @space_between_stacks = ( 110, 20);
49 my $hotspot_offset = 20;
50 my %KING_CARDS = (map { $_ => 1 } (12,25,38,51));
03a2370 initial
Tobias Leich authored
51
52 init_background();
53 init_cards();
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
54 my @rects = @{$layers->blit($display)};
55 SDL::Video::update_rects($display, @rects) if scalar @rects;
03a2370 initial
Tobias Leich authored
56 game();
57
01c25f6 merged with shlomif
Tobias Leich authored
58 sub _x
59 {
60 return shift->pos->x;
61 }
62
63 sub _y
64 {
65 return shift->pos->y;
66 }
67
68 sub _is_num {
69 return shift =~ m{\A\d+\z};
70 }
71
72 sub _handle_mouse_button_up
73 {
74 my ($handler) = @_;
75
76 $left_mouse_down = 0 if $event->button_button == SDL_BUTTON_LEFT;
77 $handler->{on_drop}->();
78
79 my $dropped = 1;
80 while($dropped) {
81 $dropped = 0;
82 for(-1..6) {
83 my $layer = $_ == -1
225e2f1 proper names for card positions
Tobias Leich authored
84 ? $layers->by_position( @rewind_deck_2_hotspot )
e09b49b all 'magic' numbers have names now
Tobias Leich authored
85 : $layers->by_position( $left_stack_hotspot[0] + $space_between_stacks[0] * $_, $left_stack_hotspot[1] );
01c25f6 merged with shlomif
Tobias Leich authored
86 my @stack = ($layer, @{$layer->ahead});
87 $layer = pop @stack if scalar @stack;
88
89 if(defined $layer
90 && $layer->data->{id} =~ m/\d+/
91 && $layer->data->{visible}
92 && !scalar @{$layer->ahead}) {
93 my $target = $layers->by_position(
e09b49b all 'magic' numbers have names now
Tobias Leich authored
94 $left_target_hotspot[0] + $space_between_stacks[0] * int($layer->data->{id} / 13), $left_target_hotspot[1]
01c25f6 merged with shlomif
Tobias Leich authored
95 );
96
97 if(can_drop($layer->data->{id}, $target->data->{id})) {
98
99 $layer->attach($event->button_x, $event->button_y);
100 $layer->foreground;
101
102 my $square = sub { my $n = shift; return $n*$n; };
103
104 my $calc_dx = sub {
105 return ( _x($target) - _x($layer) );
106 };
107 my $calc_dy = sub {
108 return ( _y($target) - _y($layer) );
109 };
110
111 my $calc_dist = sub {
112 return sqrt(
113 $square->($calc_dx->()) + $square->($calc_dy->())
114 );
115 };
116
117 my $dist = 999;
118 my $steps = $calc_dist->() / 40;
119
120 my $step_x = $calc_dx->() / $steps;
121 my $step_y = $calc_dy->() / $steps;
122
123 while($dist > 40) {
124
125 #$w += $layer->clip->w - $x;
126 #$h += $layer->clip->h - $y;
127 $layer->pos(
128 _x($layer) + $step_x, _y($layer) + $step_y
129 );
130 $layers->blit($display);
131 #SDL::Video::update_rect($display, $x, $y, $w, $h);
132 SDL::Video::update_rect($display, 0, 0, 0, 0);
133 $fps->delay;
134
135 $dist = $calc_dist->();
136 }
137 $layer->detach_xy(_x($target), _y($target));
138 show_card(pop @stack) if scalar @stack;
139 $dropped = 1;
140 }
141 }
142 }
143 }
144 }
145
03a2370 initial
Tobias Leich authored
146 sub event_loop
147 {
01c25f6 merged with shlomif
Tobias Leich authored
148 my $handler = shift;
149
03a2370 initial
Tobias Leich authored
150 SDL::Events::pump_events();
151 while(SDL::Events::poll_event($event))
152 {
4591337 @garu small organization/optimization on event loop
garu authored
153 my $type = $event->type;
154
155 if ($type == SDL_MOUSEBUTTONDOWN) {
156 $left_mouse_down = 1 if $event->button_button == SDL_BUTTON_LEFT;
157 my $time = Time::HiRes::time;
158 if ($time - $last_click >= 0.3) {
159 $handler->{on_click}->();
160 }
161 else {
162 $handler->{on_dblclick}->();
163 }
164 $last_click = $time;
165 }
166 elsif ($type == SDL_MOUSEMOTION) {
167 if ($left_mouse_down) {
168 $handler->{on_drag}->();
169 }
170 else {
171 $handler->{on_mousemove}->();
172 }
173 }
174 elsif ($type == SDL_MOUSEBUTTONUP) {
01c25f6 merged with shlomif
Tobias Leich authored
175 _handle_mouse_button_up($handler);
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
176 }
4591337 @garu small organization/optimization on event loop
garu authored
177 elsif ($type == SDL_KEYDOWN) {
755f15a added print screen function
Tobias Leich authored
178 if($event->key_sym == SDLK_PRINT) {
01c25f6 merged with shlomif
Tobias Leich authored
179
755f15a added print screen function
Tobias Leich authored
180 my $screen_shot_index = 1;
01c25f6 merged with shlomif
Tobias Leich authored
181
182 # TODO : perhaps do it using max.
183 foreach my $bmp_fn (<Shot*\.bmp>)
184 {
185 if (my ($new_index) = $bmp_fn =~ /Shot(\d+)\.bmp/)
186 {
187 if ($new_index >= $screen_shot_index)
188 {
189 $screen_shot_index = $new_index + 1;
190 }
191 }
192 }
193
755f15a added print screen function
Tobias Leich authored
194 SDL::Video::save_BMP($display, sprintf("Shot%04d.bmp", $screen_shot_index ));
195 }
196 elsif($event->key_sym == SDLK_ESCAPE) {
197 $handler->{on_quit}->();
198 }
4591337 @garu small organization/optimization on event loop
garu authored
199 $handler->{on_keydown}->();
200 }
201 elsif ($type == SDL_QUIT) {
202 $handler->{on_quit}->();
203 }
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
204 }
03a2370 initial
Tobias Leich authored
205 }
206
207 sub game
208 {
209 my @selected_cards = ();
210 my $x = 0;
211 my $y = 0;
01c25f6 merged with shlomif
Tobias Leich authored
212 my $handler =
03a2370 initial
Tobias Leich authored
213 {
214 on_quit => sub {
215 $loop = 0;
216 },
217 on_drag => sub {
218 },
219 on_drop => sub {
64d9b42 @garu adding absent subref, and moar comments!
garu authored
220 # @selected_cards contains whatever set
221 # of cards the player is moving around
03a2370 initial
Tobias Leich authored
222 if(scalar @selected_cards) {
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
223 my @selected_cards_ = ();
224 push(@selected_cards_, $_->foreground) for @selected_cards;
03a2370 initial
Tobias Leich authored
225
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
226 my @stack = scalar @selected_cards_
227 ? @{$selected_cards[0]->behind}
228 : ();
229 my $dropped = 0;
03a2370 initial
Tobias Leich authored
230 my @position_before = ();
231
232 if(scalar @stack) {
01c25f6 merged with shlomif
Tobias Leich authored
233 # to empty field
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
234 if($stack[0]->data->{id} =~ m/empty_stack/
235 && can_drop($selected_cards[0]->data->{id}, $stack[0]->data->{id})) {
236 @position_before = @{$layers->detach_xy($stack[0]->pos->x, $stack[0]->pos->y)};
03a2370 initial
Tobias Leich authored
237 $dropped = 1;
238 }
239
01c25f6 merged with shlomif
Tobias Leich authored
240 # to face-up card
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
241 elsif($stack[0]->data->{visible}
242 && can_drop($selected_cards[0]->data->{id}, $stack[0]->data->{id})) {
e09b49b all 'magic' numbers have names now
Tobias Leich authored
243 @position_before = @{$layers->detach_xy($stack[0]->pos->x, $stack[0]->pos->y + $space_between_stacks[1])};
03a2370 initial
Tobias Leich authored
244 $dropped = 1;
245 }
246
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
247 if($dropped && scalar @position_before) {
e09b49b all 'magic' numbers have names now
Tobias Leich authored
248 $position_before[0] += $hotspot_offset; # transparent border
249 $position_before[1] += $hotspot_offset;
03a2370 initial
Tobias Leich authored
250 show_card(@position_before);
251 }
252 }
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
253
03a2370 initial
Tobias Leich authored
254 $layers->detach_back unless $dropped;
255 }
256 @selected_cards = ();
257 },
258 on_click => sub {
259 unless(scalar @selected_cards) {
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
260 my $layer = $layers->by_position($event->button_x, $event->button_y);
03a2370 initial
Tobias Leich authored
261
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
262 if(defined $layer) {
263 if($layer->data->{id} =~ m/^\d+$/) {
264 if($layer->data->{visible}) {
265 @selected_cards = ($layer, @{$layer->ahead});
266 $layers->attach(@selected_cards, $event->button_x, $event->button_y);
267 }
268 elsif(!scalar @{$layer->ahead}) {
269 $layer->attach($event->button_x, $event->button_y);
270 $layer->foreground;
225e2f1 proper names for card positions
Tobias Leich authored
271 $layer->detach_xy(@rewind_deck_2_position);
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
272 show_card($layer);
273 }
274 }
275 elsif($layer->data->{id} =~ m/rewind_deck/) {
225e2f1 proper names for card positions
Tobias Leich authored
276 $layer = $layers->by_position(@rewind_deck_2_hotspot);
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
277 my @cards = ($layer, @{$layer->behind});
278 pop @cards;
8c5c711 fixed bug when trying to reset the stack at upper left
Tobias Leich authored
279 pop @cards;
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
280 foreach(@cards) {
225e2f1 proper names for card positions
Tobias Leich authored
281 $_->attach(@rewind_deck_2_hotspot);
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
282 $_->foreground;
225e2f1 proper names for card positions
Tobias Leich authored
283 $_->detach_xy(@rewind_deck_1_position);
284 hide_card(@rewind_deck_1_hotspot);
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
285 }
286 }
03a2370 initial
Tobias Leich authored
287 }
288 }
289 },
290 on_dblclick => sub {
291 $last_click = 0;
292 $layers->detach_back;
293
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
294 my $layer = $layers->by_position($event->button_x, $event->button_y);
295
296 if(defined $layer
297 && !scalar @{$layer->ahead}
298 && $layer->data->{id} =~ m/\d+/
299 && $layer->data->{visible}) {
01c25f6 merged with shlomif
Tobias Leich authored
300 my $target = $layers->by_position(
e09b49b all 'magic' numbers have names now
Tobias Leich authored
301 $left_target_hotspot[0] + 11 * int($layer->data->{id} / 13), $left_target_hotspot[1]
01c25f6 merged with shlomif
Tobias Leich authored
302 );
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
303
304 if(can_drop($layer->data->{id}, $target->data->{id})) {
305 $layer->attach($event->button_x, $event->button_y);
306 $layer->foreground;
01c25f6 merged with shlomif
Tobias Leich authored
307 $layer->detach_xy(_x($target), _y($target));
03a2370 initial
Tobias Leich authored
308 show_card($event->button_x, $event->button_y);
309 }
310 }
311 },
4591337 @garu small organization/optimization on event loop
garu authored
312 on_mousemove => sub {
313 },
64d9b42 @garu adding absent subref, and moar comments!
garu authored
314 on_keydown => sub {
315 },
03a2370 initial
Tobias Leich authored
316 };
317
318 while($loop) {
01c25f6 merged with shlomif
Tobias Leich authored
319 event_loop($handler);
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
320 @rects = @{$layers->blit($display)};
321 SDL::Video::update_rect($display, 0, 0, 0, 0);# if scalar @rects;
322 $fps->delay;
03a2370 initial
Tobias Leich authored
323 }
324 }
325
326 sub can_drop {
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
327 my $card = shift;
03a2370 initial
Tobias Leich authored
328 my $card_color = int($card / 13);
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
329 my $target = shift;
e09b49b all 'magic' numbers have names now
Tobias Leich authored
330 my $stack = $layers->by_position($left_target_hotspot[0] + $space_between_stacks[0] * $card_color, $left_target_hotspot[1]);
03a2370 initial
Tobias Leich authored
331
332 #my @stack = $layers->get_layers_behind_layer($stack);
333 #my @stack = $layers->get_layers_ahead_layer($stack);
334
e09b49b all 'magic' numbers have names now
Tobias Leich authored
335 # Kings can be put on empty fields.
01c25f6 merged with shlomif
Tobias Leich authored
336 if (exists($KING_CARDS{$card})) {
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
337 return 1 if $target =~ m/empty_stack/;
03a2370 initial
Tobias Leich authored
338 }
339
01c25f6 merged with shlomif
Tobias Leich authored
340 # Aces can be put on empty field (at upper right)
03a2370 initial
Tobias Leich authored
341 if('0,13,26,39' =~ m/\b\Q$card\E\b/ && $target =~ m/empty_target_\Q$card_color\E/) {
342 return 1;
343 }
344
01c25f6 merged with shlomif
Tobias Leich authored
345 my $are_nums = _is_num($card) && _is_num($target);
346
347 if ($are_nums
348 && $card == $target + 1
349 && $target == $stack->data->{id}
350 && $stack->data->{visible}
351 )
352 {
03a2370 initial
Tobias Leich authored
353 return 1;
354 }
355
01c25f6 merged with shlomif
Tobias Leich authored
356 if($are_nums
357 && '12,25,38,51' !~ m/\b\Q$card\E\b/
358 && ($card + 14 == $target || $card + 40 == $target
225e2f1 proper names for card positions
Tobias Leich authored
359 || $card - 12 == $target || $card - 38 == $target)
01c25f6 merged with shlomif
Tobias Leich authored
360 )
361 {
362 return 1;
363 }
03a2370 initial
Tobias Leich authored
364
365 return 0;
366 }
367
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
368 sub hide_card {
369 my $layer = (scalar @_ == 2) ? $layers->by_position(@_) : shift;
370
371 if($layer
372 && $layer->data->{id} =~ m/\d+/
373 && $layer->data->{visible}) {
374 $layer->surface(SDL::Image::load('data/card_back.png'));
375 $layer->data({id => $layer->data->{id}, visible => 0});
376 }
377 }
378
03a2370 initial
Tobias Leich authored
379 sub show_card {
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
380 my $layer = (scalar @_ == 2) ? $layers->by_position(@_) : shift;
03a2370 initial
Tobias Leich authored
381
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
382 if($layer
383 && $layer->data->{id} =~ m/\d+/
384 && !$layer->data->{visible}) {
385 $layer->surface(SDL::Image::load('data/card_' . $layer->data->{id} . '.png'));
386 $layer->data({id => $layer->data->{id}, visible => 1});
03a2370 initial
Tobias Leich authored
387 }
388 }
389
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
390 my @layers_;
03a2370 initial
Tobias Leich authored
391 sub init_background {
e09b49b all 'magic' numbers have names now
Tobias Leich authored
392 $layers->add(SDLx::Layer->new(SDL::Image::load('data/background.png'), {id => 'background'}));
393 $layers->add(SDLx::Layer->new(SDL::Image::load('data/empty_stack.png'), @rewind_deck_1_position, {id => 'rewind_deck'}));
394 $layers->add(SDLx::Layer->new(SDL::Image::load('data/empty_stack.png'), @rewind_deck_2_position, {id => 'empty_deck'}));
395
396 $layers->add(
397 SDLx::Layer->new(SDL::Image::load('data/empty_target_' . $_ . '.png'),
398 $left_target_position[0] + $space_between_stacks[0] * $_, $left_target_position[1],
399 {id => 'empty_target_' . $_})) for(0..3);
400
401 $layers->add(
402 SDLx::Layer->new(SDL::Image::load('data/empty_stack.png'),
403 $left_stack_position[0] + $space_between_stacks[0] * $_, $left_stack_position[1],
404 {id => 'empty_stack'})) for(0..6);
03a2370 initial
Tobias Leich authored
405 }
406
407 sub init_cards {
408 my $stack_index = 0;
409 my $stack_position = 0;
410 my @card_value = fisher_yates_shuffle([0..51]);
411 for(0..51)
412 {
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
413 my $image = 'data/card_back.png';
03a2370 initial
Tobias Leich authored
414 my $visible = 0;
225e2f1 proper names for card positions
Tobias Leich authored
415 my ($x, $y) = @rewind_deck_1_position;
03a2370 initial
Tobias Leich authored
416
417 if($_ < 28)
418 {
419 if($stack_position > $stack_index)
420 {
421 $stack_index++;
422 $stack_position = 0;
423 }
424 if($stack_position == $stack_index)
425 {
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
426 $image = 'data/card_' . $card_value[$_] . '.png';
03a2370 initial
Tobias Leich authored
427 $visible = 1;
428 }
e09b49b all 'magic' numbers have names now
Tobias Leich authored
429 $x = $left_stack_position[0] + $space_between_stacks[0] * $stack_index;
430 $y = $left_stack_position[1] + $space_between_stacks[1] * $stack_position;
03a2370 initial
Tobias Leich authored
431 $stack_position++;
432 }
79f2639 using new api of SDLx::LayerManager
Tobias Leich authored
433
434 $layers->add(SDLx::Layer->new(SDL::Image::load($image), $x, $y, {id => $card_value[$_], visible => $visible}));
03a2370 initial
Tobias Leich authored
435 }
436 }
437
438 sub fisher_yates_shuffle
439 {
440 my $array = shift;
441 my $i;
442 for ($i = @$array; --$i; ) {
443 my $j = int rand ($i+1);
444 next if $i == $j;
445 @$array[$i,$j] = @$array[$j,$i];
446 }
447 return @$array;
448 }
Something went wrong with that request. Please try again.