1package FC_Solve::DeltaStater;
2
3use strict;
4use warnings;
5
6use Games::Solitaire::Verify::Card        ();
7use Games::Solitaire::Verify::Column      ();
8use Games::Solitaire::Verify::State       ();
9use Games::Solitaire::Verify::VariantsMap ();
10
11use FC_Solve::DeltaStater::BitWriter;
12use FC_Solve::DeltaStater::BitReader;
13
14use parent 'Games::Solitaire::Verify::Base';
15
16my $two_fc_variant =
17    Games::Solitaire::Verify::VariantsMap->new->get_variant_by_id('freecell');
18
19$two_fc_variant->num_freecells(2);
20
21sub _get_two_fc_variant
22{
23    return $two_fc_variant;
24}
25
26my $bakers_dozen_variant =
27    Games::Solitaire::Verify::VariantsMap->new->get_variant_by_id(
28    'bakers_dozen');
29
30__PACKAGE__->mk_acc_ref(
31    [
32        qw(
33            _derived_state _init_state _columns_initial_lens _orig_args _variant
34            )
35    ]
36);
37
38sub _get_column_orig_num_cards
39{
40    my ( $self, $col ) = @_;
41
42    my $num_cards = $col->len();
43
44CALC_NUM_CARDS:
45    while ( $num_cards >= 2 )
46    {
47        my $child_card  = $col->pos( $num_cards - 1 );
48        my $parent_card = $col->pos( $num_cards - 2 );
49        if (
50            !(
51                   ( $child_card->rank() + 1 == $parent_card->rank() )
52                && ( $child_card->color() ne $parent_card->color() )
53            )
54            )
55        {
56            last CALC_NUM_CARDS;
57        }
58    }
59    continue
60    {
61        $num_cards--;
62    }
63
64    if ( $num_cards == 1 )
65    {
66        $num_cards = 0;
67    }
68
69    return $num_cards;
70}
71
72sub _is_bakers_dozen
73{
74    my ($self) = @_;
75
76    return ( $self->_variant() eq "bakers_dozen" );
77}
78
79sub _calc_state_obj_generic
80{
81    my ( $self, $args ) = @_;
82    return $self->_is_bakers_dozen()
83        ? Games::Solitaire::Verify::State->new(
84        {
85            variant => $self->_variant(),
86            %{$args},
87        }
88        )
89        : Games::Solitaire::Verify::State->new(
90        {
91            variant        => 'custom',
92            variant_params => $two_fc_variant,
93            %{$args},
94        },
95        );
96}
97
98sub _calc_state_obj_from_string
99{
100    my ( $self, $args ) = @_;
101
102    return $self->_calc_state_obj_generic(
103        { string => $args->{str}, %$args, } );
104}
105
106sub _calc_new_empty_state_obj
107{
108    my ($self) = @_;
109
110    return $self->_calc_state_obj_generic( { %{ $self->_orig_args() }, } );
111}
112
113sub _init
114{
115    my ( $self, $args ) = @_;
116
117    $self->_orig_args($args);
118
119    $self->_variant( $args->{variant} || "two_fc_freecell" );
120
121    $self->_init_state(
122        $self->_calc_state_obj_from_string(
123            { str => $args->{init_state_str}, %$args, }
124        )
125    );
126
127    my $init_state = $self->_init_state;
128
129    my @columns_initial_bit_lens;
130
131    foreach my $col_idx ( 0 .. $init_state->num_columns() - 1 )
132    {
133        my $num_cards =
134            $self->_get_column_orig_num_cards(
135            $init_state->get_column($col_idx) );
136
137        my $bitmask  = 1;
138        my $num_bits = 0;
139
140        while ( $bitmask <= $num_cards )
141        {
142            ++$num_bits;
143            $bitmask <<= 1;
144        }
145
146        push @columns_initial_bit_lens, $num_bits;
147    }
148
149    $self->_columns_initial_lens( \@columns_initial_bit_lens );
150
151    return;
152}
153
154sub set_derived
155{
156    my ( $self, $args ) = @_;
157
158    $self->_derived_state(
159        $self->_calc_state_obj_from_string(
160            { str => $args->{state_str}, %$args, }
161        )
162    );
163
164    return;
165}
166
167my @suits = (qw(H C D S));
168
169# NOTE : Not used because it can be calculated from the freecells and the
170# columns.
171sub get_foundations_bits
172{
173    my ($self) = @_;
174
175    return [
176        map { [ 4 => $self->_derived_state->get_foundation_value( $_, 0 ) ] }
177            @suits ];
178}
179
180sub _get_suit_bit
181{
182    my ( $self, $card ) = @_;
183
184    my $suit = $card->suit();
185
186    return ( ( $suit eq 'H' || $suit eq 'C' ) ? 0 : 1 );
187}
188
189my %suit_to_idx = do
190{
191    my $s = Games::Solitaire::Verify::Card->get_suits_seq();
192    ( map { $s->[$_] => $_ } ( 0 .. $#$s ) );
193};
194
195sub _suit_get_suit_idx
196{
197    my ( $self, $suit ) = @_;
198
199    return $suit_to_idx{$suit};
200}
201
202sub _get_suit_idx
203{
204    my ( $self, $card ) = @_;
205
206    return $self->_suit_get_suit_idx( $card->suit );
207}
208
209sub _get_card_bitmask
210{
211    my ( $self, $card ) = @_;
212
213    return ( $self->_get_suit_idx($card) | ( $card->rank() << 2 ) );
214}
215
216sub _calc_card
217{
218    my ( $self, $rank, $suit_idx ) = @_;
219
220    return Games::Solitaire::Verify::Card->new(
221        {
222            string => (
223                Games::Solitaire::Verify::Card->rank_to_string($rank)
224                    . $suits[$suit_idx]
225            )
226        }
227    );
228}
229
230my $COL_TYPE_EMPTY             = 0;
231my $COL_TYPE_ENTIRELY_NON_ORIG = 1;
232my $COL_TYPE_HAS_ORIG          = 2;
233
234sub _get_column_encoding_composite
235{
236    my ( $self, $col_idx ) = @_;
237
238    my $derived = $self->_derived_state();
239
240    my $col = $derived->get_column($col_idx);
241
242    my $num_orig_cards = $self->_get_column_orig_num_cards($col);
243
244    my $col_len           = $col->len();
245    my $num_derived_cards = $col_len - $num_orig_cards;
246
247    my $num_cards_in_seq = $num_derived_cards;
248    my @init_card;
249    if ( ( $num_orig_cards == 0 ) && $num_derived_cards )
250    {
251        @init_card = ( [ 6 => $self->_get_card_bitmask( $col->pos(0) ) ] );
252        $num_cards_in_seq--;
253    }
254
255    return {
256        type => (
257              ( $col_len == 0 ) ? $COL_TYPE_EMPTY
258            : $num_orig_cards   ? $COL_TYPE_HAS_ORIG
259            :                     $COL_TYPE_ENTIRELY_NON_ORIG
260        ),
261        enc => [
262            [ $self->_columns_initial_lens->[$col_idx] => $num_orig_cards ],
263            [ 4                                        => $num_derived_cards ],
264            @init_card,
265            (
266                map { [ 1 => $self->_get_suit_bit( $col->pos($_) ) ] }
267                    ( $col_len - $num_cards_in_seq .. $col_len - 1 )
268            ),
269        ],
270    };
271}
272
273sub get_column_encoding
274{
275    my ( $self, $col_idx ) = @_;
276
277    return $self->_get_column_encoding_composite($col_idx)->{enc};
278}
279
280sub get_freecells_encoding
281{
282    my ($self) = @_;
283
284    my $derived = $self->_derived_state();
285
286    return [
287        map {
288            my $card = $derived->get_freecell($_);
289            [ 6 => ( defined($card) ? $self->_get_card_bitmask($card) : 0 ) ]
290        } ( 0 .. $derived->num_freecells() - 1 )
291    ];
292}
293
294sub _composite_get_cols_and_indexes
295{
296    my ($self) = @_;
297
298    my @cols_indexes = ( 0 .. $self->_derived_state->num_columns - 1 );
299    my @cols =
300        ( map { $self->_get_column_encoding_composite($_) } @cols_indexes );
301
302    {
303        my $non_orig_idx = 0;
304        my $empty_idx    = $#cols;
305
306        # Move the empty columns to the front, but only within the
307        # entirely_non_orig
308        # That's because the orig columns should be preserved in their own
309        # place.
310    MOVE_EMPTIES_LOOP:
311        while (1)
312        {
313        NON_ORIG_IDX_LOOP:
314            while ( $non_orig_idx < @cols )
315            {
316                if ( $cols[$non_orig_idx]->{type} eq
317                    $COL_TYPE_ENTIRELY_NON_ORIG )
318                {
319                    last NON_ORIG_IDX_LOOP;
320                }
321            }
322            continue
323            {
324                ++$non_orig_idx;
325            }
326
327            if ( $non_orig_idx == @cols )
328            {
329                last MOVE_EMPTIES_LOOP;
330            }
331
332        EMPTY_IDX_LOOP:
333            while ( $empty_idx >= 0 )
334            {
335                if ( $cols[$empty_idx]->{type} eq $COL_TYPE_EMPTY )
336                {
337                    last EMPTY_IDX_LOOP;
338                }
339            }
340            continue
341            {
342                --$empty_idx;
343            }
344
345            if ( ( $empty_idx < 0 ) || ( $empty_idx < $non_orig_idx ) )
346            {
347                last MOVE_EMPTIES_LOOP;
348            }
349
350            @cols_indexes[ $non_orig_idx, $empty_idx ] =
351                @cols_indexes[ $empty_idx, $non_orig_idx ];
352            ++$non_orig_idx;
353            --$empty_idx;
354        }
355    }
356
357    {
358        my @new_non_orig_cols_indexes =
359            ( grep { $cols[$_]->{type} eq $COL_TYPE_ENTIRELY_NON_ORIG }
360                @cols_indexes );
361
362        my $get_sort_val = sub {
363            my ($i) = @_;
364            return $self->_get_card_bitmask(
365                $self->_derived_state()->get_column($i)->pos(0) );
366        };
367        my @sorted = ( sort { $get_sort_val->($a) <=> $get_sort_val->($b) }
368                @new_non_orig_cols_indexes );
369
370        foreach my $idx_idx ( 0 .. $#cols_indexes )
371        {
372            if ( $cols[ $cols_indexes[$idx_idx] ]->{type} eq
373                $COL_TYPE_ENTIRELY_NON_ORIG )
374            {
375                $cols_indexes[$idx_idx] = shift(@sorted);
376            }
377        }
378    }
379
380    return { cols => \@cols, cols_indexes => \@cols_indexes };
381}
382
383sub encode_composite
384{
385    my ($self) = @_;
386
387    my $cols_struct = $self->_composite_get_cols_and_indexes;
388
389    my $cols         = $cols_struct->{cols};
390    my $cols_indexes = $cols_struct->{cols_indexes};
391
392    my $bit_writer = FC_Solve::DeltaStater::BitWriter->new;
393    foreach my $bit_spec (
394        @{ $self->get_freecells_encoding() },
395        ( map { @{ $_->{enc} } } @{$cols}[ @{$cols_indexes} ] ),
396        )
397    {
398        $bit_writer->write( $bit_spec->[0] => $bit_spec->[1] );
399    }
400
401    return $bit_writer->get_bits();
402}
403
404sub encode
405{
406    my ($self) = @_;
407
408    my $bit_writer = FC_Solve::DeltaStater::BitWriter->new;
409
410    foreach my $bit_spec (
411        @{ $self->get_freecells_encoding() },
412        (
413            map { @{ $self->get_column_encoding($_) } }
414                ( 0 .. $self->_derived_state->num_columns - 1 )
415        ),
416        )
417    {
418        $bit_writer->write( $bit_spec->[0] => $bit_spec->[1] );
419    }
420
421    return $bit_writer->get_bits();
422}
423
424sub decode
425{
426    my ( $self, $bits ) = @_;
427
428    my $bit_reader = FC_Solve::DeltaStater::BitReader->new( { bits => $bits } );
429
430    my %foundations = ( map { $_ => 14 } @suits );
431
432    my $process_card = sub {
433        my $card = shift;
434
435        if ( $card->rank() < $foundations{ $card->suit() } )
436        {
437            $foundations{ $card->suit() } = $card->rank();
438        }
439
440        return $card;
441    };
442
443    my $process_card_bits = sub {
444        my $card_bits = shift;
445
446        my $card = $self->_calc_card(
447            ( $card_bits >> 2 ),
448            ( $card_bits & ( ( 1 << 2 ) - 1 ) ),
449        );
450
451        return $process_card->($card);
452    };
453
454    my $num_freecells = $self->_init_state->num_freecells();
455
456    # Read the Freecells.
457    my $freecells =
458        Games::Solitaire::Verify::Freecells->new( { count => $num_freecells } );
459
460    foreach my $freecell_idx ( 0 .. $num_freecells - 1 )
461    {
462        my $card_bits = $bit_reader->read(6);
463
464        if ( $card_bits != 0 )
465        {
466            $freecells->assign( $freecell_idx,
467                $process_card_bits->($card_bits) );
468        }
469    }
470
471    my @columns;
472
473    foreach my $col_idx ( 0 .. $self->_init_state->num_columns - 1 )
474    {
475        my $col = Games::Solitaire::Verify::Column->new( { cards => [] } );
476
477        my $num_orig_cards =
478            $bit_reader->read( $self->_columns_initial_lens->[$col_idx] );
479
480        my $orig_col = $self->_init_state->get_column($col_idx);
481        foreach my $i ( 0 .. $num_orig_cards - 1 )
482        {
483            $col->push( $process_card->( $orig_col->pos($i)->clone() ), );
484        }
485
486        my $num_derived_cards = $bit_reader->read(4);
487        my $num_cards_in_seq  = $num_derived_cards;
488
489        if ( ( $num_orig_cards == 0 ) && $num_derived_cards )
490        {
491            my $card_bits = $bit_reader->read(6);
492            $col->push( $process_card_bits->($card_bits) );
493            $num_cards_in_seq--;
494        }
495
496        if ($num_cards_in_seq)
497        {
498            my $last_card = $col->pos(-1);
499            for my $i ( 0 .. $num_cards_in_seq - 1 )
500            {
501                my $suit_bit = $bit_reader->read(1);
502
503                my $new_card = $self->_calc_card(
504                    ( $last_card->rank() - 1 ),
505                    (
506                        ( $suit_bit << 1 ) |
507                            ( $last_card->color eq "red" ? 1 : 0 )
508                    ),
509                );
510
511                $col->push( $process_card->( $last_card = $new_card ) );
512            }
513        }
514
515        push @columns, $col;
516    }
517
518    my $foundations_obj = Games::Solitaire::Verify::Foundations->new(
519        {
520            num_decks => 1,
521        },
522    );
523
524    foreach my $found ( keys(%foundations) )
525    {
526        $foundations_obj->assign( $found, 0, $foundations{$found} - 1 );
527    }
528
529    my $state = $self->_calc_new_empty_state_obj();
530    foreach my $col (@columns)
531    {
532        $state->add_column($col);
533    }
534    $state->set_freecells($freecells);
535    $state->set_foundations($foundations_obj);
536
537    return $state;
538}
539
5401;
541
542__END__
543
544=head1 COPYRIGHT AND LICENSE
545
546This file is part of Freecell Solver. It is subject to the license terms in
547the COPYING.txt file found in the top-level directory of this distribution
548and at http://fc-solve.shlomifish.org/docs/distro/COPYING.html . No part of
549Freecell Solver, including this file, may be copied, modified, propagated,
550or distributed except according to the terms contained in the COPYING file.
551
552Copyright (c) 2009 Shlomi Fish
553
554=cut
555