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

[523066680]

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

参考：

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

[523066680]

生成搜索树

Code: [全选] [展开/折叠] [Download] (avg.pl)

1. =info
2.     生成最大反馈指标搜索树
3.  
4.     Code-by : 523066680
5.        Date : 2017-08
6. =cut
7.  
8. use List::Util qw/max sum/;
9.  
10. use JSON;
11. use Inline C;
12. use IO::Handle;
13. use Data::Dumper;
14. use File::Slurp;
15. use Time::HiRes qw/sleep/;
16. STDOUT->autoflush(1);
17. $Data::Dumper::Indent = 1;
18.  
19. #生成排列
20. our @orders;
21. permute( [0 .. 9] , [], 4, \@orders);
22.  
23. #生成树
24. print "Make tree\n";
25. my $tree;
26. $tree = { "0123" => {} };
27. maketree( $tree, \@orders, 0 );
28.  
29. #导出
30. print "Dump tree\n";
31. write_file("./Tree_avg.perl.txt", Dumper $tree);
32. write_file("./Tree_avg.json.txt", encode_json($tree) );
33.  
34. sub maketree
35. {
36.     our @orders;
37.     my $orders;
38.     my ($ref, $arr, $lv) = @_;
39.     my $AB = "00";
40.     my %keymap;
41.     my %hash;
42.     my $minkey;
43.     my $minval = 10000000;
44.     my $amount;
45.  
46.     if ($lv == 0) { $orders = ["0123"] }
47.     else          { $orders = \@orders }
48.  
49.     for my $e ( @$orders )
50.     {
51.         $amount = 0;
52.         %hash = ();
53.  
54.         for my $k ( @$arr )
55.         {
56.             bullcow( $k, $e, $AB );
57.             $hash{$AB}++;
58.             $hash{$k} = "$AB";
59.         }
60.  
61.         for my $k ( @$arr )
62.         {
63.             $amount += $hash{ $hash{$k} };
64.         }
65.        
66.         $keymap{$e} = $amount;
67.  
68.         if ($amount < $minval)
69.         {
70.             $minval = $amount;
71.             $minkey = $e;
72.         }
73.     }
74.  
75.     #print "$minval $minkey\n";
76.  
77.     #如果筛选集中有符合条件的项，优先选择
78.     for my $k ( @$arr )
79.     {
80.         if ( $keymap{$k} == $minval ) { $minkey = $k; last; }
81.     }
82.  
83.     #建立反馈项和缩小集合组
84.     for my $k ( @$arr )
85.     {
86.         #删除 $minkey 以外的项（当前层）
87.         delete $ref->{$k} if ($k ne $minkey);
88.  
89.         #创建反馈项以及对应子集 / 反馈为 40 的项无需子集
90.         bullcow( $minkey, $k, $AB );    
91.         $ref->{$minkey}{$AB}{$k} = {} if ( $AB ne "40" );
92.     }
93.    
94.     for my $ab ( keys %{ $ref->{ $minkey } } )
95.     {
96.         printf " $lv -> $ab, %d\n", $#$arr;
97.         maketree( $ref->{$minkey}{$ab},  [ sort keys %{$ref->{$minkey}{$ab}} ], $lv+1 );
98.     }
99. }
100.  
101. sub permute
102. {
103.     my ( $a, $b, $n, $aref ) = @_;
104.     my $last = $#$a;
105.  
106.     if ( $#$b >= ($n-1) )
107.     {
108.         push @$aref, join("", @$b);
109.         return;
110.     }
111.  
112.     for my $idx ( 0 .. $last )
113.     {
114.         permute( [ @$a[0 .. $idx-1, $idx+1 .. $last] ], [ @$b, $a->[$idx] ], $n, $aref );
115.     }
116. }
117.  
118. __END__
119. __C__
120. void bullcow(char *stra, char *strb, char *AB)
121. {
122.     int idx;
123.     char a = '0';
124.     char b = '0';
125.  
126.     for ( idx = 0; idx < 4; idx++ )
127.     {
128.         if ( stra[idx] == strb[idx] )
129.             a++;
130.         else
131.             if ( strchr(stra, strb[idx]) != 0 )
132.             {
133.                 b++;
134.             }
135.     }
136.  
137.     AB[0] = a;
138.     AB[1] = b;
139. }

[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__
$_