[Perl版块]猜数字游戏专题

[523066680]

游戏说明 - [专区-算法与编码]猜数字游戏 - 专题

参考：

• [ChinaUnix][算法讨论]猜数字游戏 - Bulls and Cows

[523066680]

生成搜索树

Code: [show] | [select all]

=info

    生成最大反馈指标搜索树



    Code-by : 523066680

       Date : 2017-08

=cut



use List::Util qw/max sum/;



use JSON;

use Inline C;

use IO::Handle;

use Data::Dumper;

use File::Slurp;

use Time::HiRes qw/sleep/;

STDOUT->autoflush(1);

$Data::Dumper::Indent = 1;



#生成排列

our @orders;

permute( [0 .. 9] , [], 4, \@orders);



#生成树

print "Make tree\n";

my $tree;

$tree = { "0123" => {} };

maketree( $tree, \@orders, 0 );



#导出

print "Dump tree\n";

write_file("./Tree_avg.perl.txt", Dumper $tree);

write_file("./Tree_avg.json.txt", encode_json($tree) );



sub maketree

{

    our @orders;

    my $orders;

	my ($ref, $arr, $lv) = @_;

	my $AB = "00";

    my %keymap;

    my %hash;

    my $minkey;

    my $minval = 10000000;

    my $amount;



    if ($lv == 0) { $orders = ["0123"] }

    else          { $orders = \@orders }



    for my $e ( @$orders )

    {

        $amount = 0;

        %hash = ();



        for my $k ( @$arr )

        {

            bullcow( $k, $e, $AB );

            $hash{$AB}++;

            $hash{$k} = "$AB";

        }



        for my $k ( @$arr )

        {

            $amount += $hash{ $hash{$k} };

        }

        

        $keymap{$e} = $amount;



        if ($amount < $minval)

        {

        	$minval = $amount;

        	$minkey = $e;

        }

    }



    #print "$minval $minkey\n";



    #如果筛选集中有符合条件的项，优先选择

    for my $k ( @$arr )

    {

    	if ( $keymap{$k} == $minval ) { $minkey = $k; last; }

    }



    #建立反馈项和缩小集合组

    for my $k ( @$arr )

    {

        #删除 $minkey 以外的项（当前层）

        delete $ref->{$k} if ($k ne $minkey);



        #创建反馈项以及对应子集 / 反馈为 40 的项无需子集

        bullcow( $minkey, $k, $AB );    

        $ref->{$minkey}{$AB}{$k} = {} if ( $AB ne "40" );

    }

    

    for my $ab ( keys %{ $ref->{ $minkey } } )

    {

        printf " $lv -> $ab, %d\n", $#$arr;

        maketree( $ref->{$minkey}{$ab},  [ sort keys %{$ref->{$minkey}{$ab}} ], $lv+1 );

    }

}



sub permute

{

    my ( $a, $b, $n, $aref ) = @_;

    my $last = $#$a;



    if ( $#$b >= ($n-1) )

    {

        push @$aref, join("", @$b);

        return;

    }



    for my $idx ( 0 .. $last )

    {

        permute( [ @$a[0 .. $idx-1, $idx+1 .. $last] ], [ @$b, $a->[$idx] ], $n, $aref );

    }

}



__END__

__C__

void bullcow(char *stra, char *strb, char *AB)

{

    int idx;

    char a = '0';

    char b = '0';



    for ( idx = 0; idx < 4; idx++ )

    {

        if ( stra[idx] == strb[idx] )

            a++;

        else

            if ( strchr(stra, strb[idx]) != 0 )

            {

                b++;

            }

    }



    AB[0] = a;

    AB[1] = b;

}

[rubyish]

delete~~

[rubyish]

v2:
sample:

ANS = 0493
0123    20
0145    11
0426    20
0473    30
0483    30
0493    40
COUNT = 6
----------

ANS = 0495
0123    10
0456    21
0467    20
0485    30
0495    40
COUNT = 5
----------

ANS = 0496
0123    10
0456    30
0457    20
0486    30
0496    40
COUNT = 5
----------

#!/usr/bin/perl -w
# version 28, subversion 0 (v5.28.0)
# 2018-11-14
use 5.028;

my @all = map [ split // ], grep !/(.).*\1/, "0123" .. "9876";
my $tree = make( \@all );

TEST();

# ____________________SUB____________________
sub TEST {
    for my $ans (@all) {
        guess($ans);
    }
}

sub GUESS() { 0 }
sub AB()    { 1 }

sub guess {
    my $ans   = shift;
    my $count = 0;
    my $pos   = 0;
    $pos |= ( 1 << $_ ) for @$ans;
    my $next = $tree;
    say "ANS = ", join '', @$ans;

    while ($next) {
        my $guess = $next->[GUESS];
        my @guess = split //, $guess;
        my $A     = 0;
        my $B     = 0;

        for my $i ( 0 .. 3 ) {
            $guess[$i] == $ans->[$i] ? $A++
              : ( $pos & ( 1 << $guess[$i] ) ) ? $B++
              :                                  undef;
        }

        $next = $next->[AB]{ $A . $B };
        $count++;
        say $guess, "\t", $A . $B;
    }
    say "COUNT =\t$count";
    say "----------\n";

}

sub make {
    my $all  = shift;
    my $tree = [];
    M_( $tree, $all );
    return $tree;
}

sub M_ {
    my ( $tree, $all ) = @_;
    my $guess = $all->[0];

    $tree->[GUESS] = join '', @$guess;
    my $pos = 0;
    $pos |= ( 1 << $_ ) for @$guess;

    for my $i ( 1 .. $#$all ) {
        my $num = $all->[$i];
        my $A   = 0;
        my $B   = 0;

        for my $j ( 0 .. 3 ) {
            $guess->[$j] == $num->[$j] ? $A++
              : ( $pos & ( 1 << $num->[$j] ) ) ? $B++
              :                                  undef;
        }
        push @{ $tree->[AB]{ $A . $B } }, $num;
    }

    while ( my ( $ab, $maybe ) = each %{ $tree->[AB] } ) {
        $tree->[AB]{$ab} = [];
        M_( $tree->[AB]{$ab}, $maybe );
    }
}

__DATA__
$_

[rubyish]

v3:
real 0m0.640s


sample:

1  1
2  13
3  108
4  596
5  1668
6  1768
7  752
8  129
9  5
AVE = 5.56031746031746

real	0m0.640s
user	0m0.626s
sys	0m0.012s

time perl abc.pl

#!/usr/bin/perl -w
# version 28, subversion 0 (v5.28.0)
# 2018-11-14, 2018-11-17

use 5.028;
my @INDES = ( 0, 5, 9, 12, 13 );
my @all = map [ split // ], grep !/(.).*\1/, "0123" .. "9876";
my $tree = make( \@all );
TEST();

# ____________________SUB____________________
sub TEST {
    my @record;

    for my $ans (@all) {
        #say "ANS = ", @$ans;
        my $count = guess($ans);
        #say "COUNT =\t$count";
        #say "----------\n";
        $record[$count]++;
    }

    my $ave = 0;
    for my $i ( 1 .. $#record ) {
        say "$i  $record[$i]";
        $ave += $i * $record[$i];
    }
    say "AVE = ", $ave / @all;
}

sub GUESS() { 0 }
sub AB()    { 1 }

sub guess {
    my $ans   = shift;
    my $count = 0;
    my $pos =
      ( 1 << $ans->[0] ) | 
      ( 1 << $ans->[1] ) | 
      ( 1 << $ans->[2] ) |
      ( 1 << $ans->[3] );
    my $next = $tree;

    while ($next) {
        my $guess = $next->[GUESS];
        my $A     = 0;
        my $B     = 0;

        for my $i ( 0 .. 3 ) {
            $guess->[$i] == $ans->[$i] ? $A++
              : ( $pos & ( 1 << $guess->[$i] ) ) ? $B++
              :                                    undef;
        }

        $next = $next->[AB][ $INDES[$A] + $B ];
        $count++;
        #say @$guess, "\t", $A . $B;
    }

    return $count;

}

sub make {
    my $all  = shift;
    my $tree = [];
    M_( $tree, $all );
    return $tree;
}

sub M_ {
    my ( $tree, $all ) = @_;
    my $guess = $all->[0];

    $tree->[GUESS] = $guess;
    my $pos =
      ( 1 << $guess->[0] ) | 
      ( 1 << $guess->[1] ) | 
      ( 1 << $guess->[2] ) |
      ( 1 << $guess->[3] );

    for my $i ( 1 .. $#$all ) {
        my $num = $all->[$i];
        my $A   = 0;
        my $B   = 0;

        for my $j ( 0 .. 3 ) {
            $guess->[$j] == $num->[$j] ? $A++
              : ( $pos & ( 1 << $num->[$j] ) ) ? $B++
              :                                  undef;
        }
        push @{ $tree->[AB][ $INDES[$A] + $B ] }, $num;
    }
    for my $i ( 0 .. $#{ $tree->[AB] } ) {
        my $maybe = $tree->[AB][$i] // next;
        $tree->[AB][$i] = [];
        M_( $tree->[AB][$i], $maybe );
    }
}

__DATA__
$_