1#!/usr/bin/env perl 2 3use strict; 4use warnings; 5 6use Getopt::Long qw/ GetOptions /; 7use Template (); 8use FindBin (); 9use lib "$FindBin::Bin/../t/lib"; 10use FC_Solve::MoveFuncs (); 11 12my $declared_move_funcs = FC_Solve::MoveFuncs::declared_move_funcs(); 13my $aliases = FC_Solve::MoveFuncs::aliases(); 14 15my %presets = ( 16 'bakers_game' => [qw(i freecell sbb suit)], 17 'bakers_dozen' => [ 18 qw(s 13 f 0 d 1 sbb rank sm limited esf none to 0123456789 am 0123456789) 19 ], 20 'beleaguered_castle' => [qw(i freecell sbb rank f 0)], 21 'cruel' => [qw(i bakers_dozen s 12 sbb suit)], 22 'der_katzenschwanz' => [qw(i die_schlange sm unlimited)], 23 'die_schlange' => [qw(i freecell f 8 s 9 d 2 esf none)], 24 'eight_off' => [qw(i kings_only_bakers_game f 8)], 25 'fan' => [qw(i freecell s 18 sbb suit sm limited esf kings_only f 0)], 26 'forecell' => [qw(i freecell esf kings_only)], 27 'freecell' => [ 28 qw(s 8 f 4 d 1 sbb ac sm limited esf any_card to [01][23456789] am 0123456789ABCDEj) 29 ], 30 'good_measure' => [qw(i bakers_dozen s 10)], 31 'kings_only_bakers_game' => [qw(i bakers_game esf kings_only)], 32 'relaxed_freecell' => [qw(i freecell sm unlimited)], 33 'relaxed_seahaven_towers' => [qw(i seahaven_towers sm unlimited)], 34 'seahaven_towers' => [qw(i bakers_game esf kings_only s 10)], 35 'simple_simon' => [qw(i bakers_game s 10 f 0 to abcdefgh am abcdefghi)], 36 37 # 'yukon' => [ qw(i freecell s 7 f 0 to ABCDEFG) ], 38); 39 40my @strings; 41 42sub compile_preset 43{ 44 my ( $preset_name, $compiled ) = @_; 45 my $preset = $presets{$preset_name}; 46 my @params = @{$preset}; 47 eval { 48 CMD: 49 while ( my $cmd = shift(@params) ) 50 { 51 my $arg = shift(@params); 52 53 if ( $cmd =~ /^(?:i|inherits?)$/ ) 54 { 55 if ( !exists( $presets{$arg} ) ) 56 { 57 die "Unknown inheritor!\n"; 58 } 59 compile_preset( $arg, $compiled ); 60 next CMD; 61 } 62 for my $params ( 63 [ qr/s|stacks?/, qr/[0-9]+/, 'stacks' ], 64 [ qr/f|freecells?/, qr/[0-9]+/, 'freecells' ], 65 [ qr/d|decks?/, qr/[12]/, 'decks' ], 66 [ qr/sbb|seqs_build_by/, qr/ac|suit|rank/m, 'seqs_build_by' ], 67 [ 68 qr/(?:sm|(?:seq|sequence)_move)/, 69 qr/limited|unlimited/, 70 'sequence_move', 71 sub { return shift =~ /un/ ? 1 : 0; } 72 ], 73 [ 74 qr/(?:esf|empty_stacks_fill(?:ed(?:_by)?)?)/, 75 qr/(?:any_card|kings_only|none)/, 76 'empty_stacks_fill' 77 ], 78 [ 79 qr/(?:to|moves_order)/, qr/[0-9a-hA-G\[\(\)\]]+/, 80 'moves_order' 81 ], 82 [ 83 qr/(?:am|allowed_moves)/, 84 qr/[0-9a-jA-G]+/, 85 'allowed_moves', 86 sub { 87 my $total = 0; 88 foreach my $char ( split //, shift ) 89 { 90 $total |= 91 ( 1 << $declared_move_funcs->{ $aliases->{$char} 92 } ); 93 } 94 return sprintf( "0x%XLL", $total ); 95 } 96 ], 97 ) 98 { 99 my ( $CMD_RE, $ARG_RE, $NAME, $cb ) = @$params; 100 $cb //= sub { return shift; }; 101 if ( $cmd =~ /\A(?:$CMD_RE)\z/ ) 102 { 103 if ( $arg !~ /\A(?:$ARG_RE)\z/ ) 104 { 105 die "Argument to $NAME is invalid!\n"; 106 } 107 $compiled->{$NAME} = $cb->($arg); 108 next CMD; 109 } 110 } 111 die "Unknown Command $cmd\n"; 112 } 113 }; 114 if ($@) 115 { 116 die "Preset Name: $preset_name\n$@"; 117 } 118 return; 119} 120 121my $c_template = Template->new(); 122 123my $C_TEMPLATE_INPUT = <<"EOF"; 124 { 125 [% allowed_moves %], 126 [% preset %], 127 MAKE_GAME_PARAMS( 128 [% fc %], 129 [% s %], 130 [% d %], 131 132 [% sbb %], 133 [% sm %], 134 [% esf %] 135 ), 136 137 [% moves_order %] 138 } 139EOF 140 141sub preset_to_string 142{ 143 my ( $preset_name, $pc ) = @_; 144 145 my @lines; 146 eval { 147 push @lines, ( "FCS_PRESET_" . uc($preset_name) ); 148 149 if ( !exists( $pc->{'freecells'} ) ) 150 { 151 die "Freecells were not defined!\n"; 152 } 153 push @lines, $pc->{'freecells'}; 154 155 if ( !exists( $pc->{'stacks'} ) ) 156 { 157 die "Stacks were not defined!\n"; 158 } 159 push @lines, $pc->{'stacks'}; 160 161 if ( !exists( $pc->{'decks'} ) ) 162 { 163 die "Decks Number was not defined!\n"; 164 } 165 push @lines, $pc->{'decks'}; 166 167 if ( !exists( $pc->{'seqs_build_by'} ) ) 168 { 169 die "Seqs Build by was not defined!\n"; 170 } 171 my $arg = $pc->{'seqs_build_by'}; 172 push @lines, 173 ( 174 "FCS_SEQ_BUILT_BY_" 175 . ( 176 ( $arg eq "ac" ) ? "ALTERNATE_COLOR" 177 : ( $arg eq "suit" ) ? "SUIT" 178 : "RANK" 179 ) 180 ); 181 182 if ( !exists( $pc->{'sequence_move'} ) ) 183 { 184 die "Sequence move was not defined!\n"; 185 } 186 push @lines, $pc->{'sequence_move'}; 187 188 if ( !exists( $pc->{'empty_stacks_fill'} ) ) 189 { 190 die "Empty Stacks Fill is undefined!\n"; 191 } 192 my $esf = $pc->{'empty_stacks_fill'}; 193 push @lines, 194 "FCS_ES_FILLED_BY_" 195 . ( 196 ( $esf eq "none" ) ? "NONE" 197 : ( $esf eq "any_card" ) ? "ANY_CARD" 198 : "KINGS_ONLY" 199 ); 200 201 if ( !exists( $pc->{'moves_order'} ) ) 202 { 203 die "Tests order is undefined!\n"; 204 } 205 push @lines, "\"" . $pc->{'moves_order'} . "\""; 206 207 if ( !exists( $pc->{'allowed_moves'} ) ) 208 { 209 die "Allowed moves is undefined!\n"; 210 } 211 push @lines, $pc->{'allowed_moves'}; 212 }; 213 214 if ($@) 215 { 216 die "Preset name: $preset_name\n$@\n"; 217 } 218 219 my %vars; 220 @vars{qw(preset fc s d sbb sm esf moves_order allowed_moves)} = @lines; 221 222 my $ret; 223 $c_template->process( \$C_TEMPLATE_INPUT, \%vars, \$ret ); 224 $ret =~ s{\s+\z}{}ms; 225 return $ret; 226} 227 228sub preset_to_docbook_string 229{ 230 my ( $preset_name, $pc ) = @_; 231 my @lines; 232 233 push @lines, 234 join( " ", ( map { ucfirst($_) } split( /_/, $preset_name ) ) ); 235 236 push @lines, ( $pc->{'stacks'}, $pc->{'freecells'}, $pc->{'decks'} ); 237 238 my $sbb = $pc->{'seqs_build_by'}; 239 push @lines, 240 ( 241 ( $sbb eq "ac" ) ? "Alternate Colour" 242 : ( $sbb eq "suit" ) ? "Suit" 243 : "Rank" 244 ); 245 246 my $arg = $pc->{'empty_stacks_fill'}; 247 push @lines, 248 ( 249 ( $arg eq "none" ) ? "None" 250 : ( $arg eq "any_card" ) ? "Any Card" 251 : "Kings Only" 252 ); 253 254 push @lines, ( $pc->{'sequence_move'} ? "Limited" : "Unlimited" ); 255 256 return join( "", map { " <entry>$_</entry>\n" } @lines ); 257} 258 259sub preset_to_perl_module 260{ 261 my ( $preset_name, $pc ) = @_; 262 263 my %sbb_map = ( 264 'ac' => "alt_color", 265 'suit' => "suit", 266 'rank' => "rank", 267 ); 268 269 my $sbb = $sbb_map{ $pc->{'seqs_build_by'} } 270 or die "Hoola"; 271 272 my %esf_map = ( 273 'kings_only' => "kings", 274 'none' => "none", 275 'any_card' => "any", 276 ); 277 my $esf = $esf_map{ $pc->{'empty_stacks_fill'} } 278 or die "BlahBlajjor"; 279 280 my $seq_move = $pc->{sequence_move} ? "unlimited" : "limited"; 281 282 my $simple_simon = ""; 283 284 if ( $preset_name eq "simple_simon" ) 285 { 286 $simple_simon = <<'EOF'; 287 'rules' => "simple_simon", 288EOF 289 290 chomp($simple_simon); 291 } 292 293 my $ret_val = <<"EOF"; 294 "$preset_name" => 295 Games::Solitaire::Verify::VariantParams->new( 296 { 297 'num_decks' => $pc->{decks}, 298 'num_columns' => $pc->{stacks}, 299 'num_freecells' => $pc->{freecells}, 300 'sequence_move' => "$seq_move", 301 'seq_build_by' => "$sbb", 302 'empty_stacks_filled_by' => "$esf", 303$simple_simon 304 } 305 ), 306EOF 307 308 $ret_val =~ s{\n\s*\n}{\n}gms; 309 310 return $ret_val; 311} 312 313sub preset_to_pod 314{ 315 my ($preset_name) = @_; 316 return "=item * $preset_name\n\n"; 317} 318 319my $mode = "c"; 320my $output_fn; 321 322GetOptions( 323 'mode=s' => \$mode, 324 'output=s' => \$output_fn, 325) or die "Failed to get options - $!"; 326 327my %mode_callbacks = ( 328 "c" => \&preset_to_string, 329 "docbook" => \&preset_to_docbook_string, 330 "perl-mod" => \&preset_to_perl_module, 331 "pod" => \&preset_to_pod, 332); 333 334if ( not exists $mode_callbacks{$mode} ) 335{ 336 die "Unknown mode '$mode'!"; 337} 338 339my $out_fh; 340if ( !defined $output_fn ) 341{ 342 $out_fh = *STDOUT; 343} 344else 345{ 346 open $out_fh, '>', $output_fn 347 or die "Cannot open '$output_fn' for writing."; 348} 349 350PRESETS_LOOP: 351foreach my $preset_name ( sort { $a cmp $b } keys(%presets) ) 352{ 353 if ( $preset_name eq "simple_simon" and $mode eq "docbook" ) 354 { 355 next PRESETS_LOOP; 356 } 357 358 my $preset_compiled = {}; 359 compile_preset( $preset_name, $preset_compiled ); 360 push @strings, $mode_callbacks{$mode}->( $preset_name, $preset_compiled ); 361} 362 363if ( $mode eq "docbook" ) 364{ 365 print join( "", map { "<row>\n$_</row>\n" } @strings ); 366} 367elsif ( $mode eq "c" ) 368{ 369 print {$out_fh} <<"EOF"; 370// This file was auto-generated by gen_presets.pl. DO NOT EDIT BY HAND 371 372static const fcs_preset fcs_presets[@{[0+@strings]}] = 373{ 374@{[join( ",\n", @strings )]} 375}; 376EOF 377} 378elsif ( $mode eq "perl-mod" ) 379{ 380 print "my %variants_map =\n"; 381 print "(\n"; 382 print join( "", @strings ); 383 print ");\n"; 384} 385elsif ( $mode eq "pod" ) 386{ 387 print "=head1 PARAMETERS\n\n"; 388 print "=head2 Variants IDs\n\n"; 389 print "This is a list of the available variant IDs.\n\n"; 390 print "=over 4\n\n"; 391 print join( "", @strings ); 392 print "=back\n\n"; 393} 394 395close($out_fh); 396 397__END__ 398 399=head1 COPYRIGHT AND LICENSE 400 401This file is part of Freecell Solver. It is subject to the license terms in 402the COPYING.txt file found in the top-level directory of this distribution 403and at http://fc-solve.shlomifish.org/docs/distro/COPYING.html . No part of 404Freecell Solver, including this file, may be copied, modified, propagated, 405or distributed except according to the terms contained in the COPYING file. 406 407Copyright (c) 2000 Shlomi Fish 408 409=cut 410