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