Skip to content

HTTPS clone URL

Subversion checkout URL

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