Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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