523066680

回复 1# 老刘1号

问题1，只有首个元素可以移动，他可以移动到任意位置吗
若按C数组操作，如果你可以移动到中间位置，那不是还等于其他元素也可以移动了
问题2，想看stackoverflow原帖，也许是leetcode上面的题目？

523066680

int a[5] = {a,b,c,d,e} 把数组变成 {b,c,a,d,e}
b和c 不是从 1,2的位置变成了 0,1的位置吗。（这种允许的话，感觉跟打牌手法的插入排序差不多。）

除非说这是一个定制的数据结构，每个数之间有足够的间隙，开头的数字可以插入任意数字中间而其他数字不需要移动。
比如 a,,,,b,,,,c,,,,d,,,,e,,,,

回复 5# 老刘1号
    不纠结数据结构，纠结的是描述。觉得你现在的描述就比较合理了，其他数字被动移动。

523066680

有缺陷/未完成，大概方向，unshift 取出首个数字，和剩下的各个元素做减法，找出相差距离最近的数字（分为L和R）的对应坐标，插入。可能做足判断会好一些，待完善。

my @arr = qw/5 1 9 3 2 4 6/;
my ($first, $L,$R,$r_id, $l_id, $dt);
my $max = 100000;

for (1..5)
{
    $first = shift @arr;
    $L = -$max;
    $R = $max;
    $r_id = 0;
    $l_id = 0;
    for $i ( 0 .. $#arr ) {
        $dt = $arr[$i] - $first;
        if ( $dt > 0 && $dt <= $R) { $r_id = $i, $R = $dt; }
        if ( $dt < 0 && $dt >= $L) { $l_id = $i, $L = $dt; }
    }

    if ( $R == $max ) {
        push @arr, $first;
    } else {
        splice( @arr, $r_id, 0, $first );
    }
    #printf "%d - %d: %d, %d: %d\n", $first, $l_id, $L, $r_id, $R;
    print join(",", @arr), "\n";
}

#print join("", @arr);
复制代码

1,9,3,2,4,5,6
9,3,1,2,4,5,6
3,1,2,4,5,6,9
1,2,3,4,5,6,9

特地找一副扑克牌玩了一下，为啥人玩起来就这么自然…… 转成代码总是有纰漏，
纠正了某些情况下不能完全处理的问题，也未经过严格验证，暂时这样。

my @arr = qw/7 3 4 1 10 9 8 11 24/;
my ($first, $L,$R,$r_id, $l_id, $dt);
my $max = 100000;
my $ok = 0;

while (1)
{
    $first = shift @arr;
    $L = -$max;
    $R = $max;
    $r_id = 0;
    $l_id = 0;
    for $i ( 0 .. $#arr ) {
        $dt = $arr[$i] - $first;
        if ( $dt > 0 && $dt <= $R) { $r_id = $i, $R = $dt; }
        if ( $dt < 0 && $dt >= $L) { $l_id = $i, $L = $dt; }
    }

    if ( $L != -$max )
    {
        # 如果有相对较小的数字，优先移至最邻近者
        splice( @arr, $l_id+1, 0, $first );
    } else {
        if ( $R == $max ) {
            # 如果未找到更大的数字，直接堆到最后
            push @arr, $first;
        } else {
            # 判断数组中是否还有 左边大于右边的情况
            $ok = 1;
            for my $i ( 0 .. $#arr-1 ) {
                if ( $arr[$i] > $arr[$i+1] ) {
                    splice( @arr, $i+1, 0, $first );
                    $ok = 0;
                    last;
                }
            }
            last if $ok;
        }
    }
    #printf "%d -- [%d]: %d, [%d]: %d\n", $first, $l_id, $L, $r_id, $R;
    print join(",", @arr), "\n";
}
复制代码

3,4,7,1,10,9,8,11,24
4,7,1,3,10,9,8,11,24
7,1,3,4,10,9,8,11,24
1,3,4,7,10,9,8,11,24
3,4,7,10,1,9,8,11,24
4,7,10,1,3,9,8,11,24
7,10,1,3,4,9,8,11,24
10,1,3,4,7,9,8,11,24
1,3,4,7,9,10,8,11,24
3,4,7,9,10,1,8,11,24
4,7,9,10,1,3,8,11,24
7,9,10,1,3,4,8,11,24
9,10,1,3,4,7,8,11,24
10,1,3,4,7,8,9,11,24
1,3,4,7,8,9,10,11,24
复制代码

2,3,5,1,4
3,5,1,2,4
5,1,2,3,4
1,2,3,4,5
复制代码

523066680

回复 8# 老刘1号

    已更新

523066680

试试粗暴一点，递归求不同解、最优解。（逻辑不够完整，怕卡太久，限制了层数 lv <= 5），

my @arr = qw/8 9 1 2 5/;
my @order = ();
our @ways;
solver(0, \@order, @arr);

my $first;
for my $w ( @ways )
{
    printf "Solution: %s\n", join(",", @$w);
    my @brr = @arr;
    for my $mov ( @$w )
    {
        $first = shift @brr;
        splice( @brr, $mov, 0, $first );
        printf "%s\n", join(",", @brr);
    }
    printf "\n";
}

sub solver
{
    my ($lv, $order) = (shift, shift);
    my @arr = @_;
    my @brr;
    my $first;
    my $res;
    return if $lv == 5;
    if (check(\@arr) == -1) {
        #printf "[%d] %s %s\n", $lv, join(",", @arr), join(",", @brr);
        for my $i ( 1 .. $#arr ) {
            @brr = @arr[1..$#arr];
            splice(@brr, $i, 0, $arr[0] );
            $order[$lv] = $i;
            $res = solver( $lv+1, $order, @brr );
            #if ( $res == 1 ) {last;}
        }
        return 1 if $res == 1;
    } else {
        #printf "%s\n", join(",", @arr);
        push @ways, [@{$order}[0..$lv-1] ];
        return 1;
    }
}

sub check
{
    my $ar = shift;
    grep { return -1 if ( $ar->[$_] > $ar->[$_+1] ) } ( 0 .. $#$ar-1);
    return 1;
}
复制代码

Solution: 1,1,4,4
9,8,1,2,5
8,9,1,2,5
9,1,2,5,8
1,2,5,8,9

Solution: 1,4,3
9,8,1,2,5
8,1,2,5,9
1,2,5,8,9

Solution: 2,4,1,3
9,1,8,2,5
1,8,2,5,9
8,1,2,5,9
1,2,5,8,9

Solution: 4,1,1,4
9,1,2,5,8
1,9,2,5,8
9,1,2,5,8
1,2,5,8,9

Solution: 4,4
9,1,2,5,8
1,2,5,8,9

[Finished in 0.1s]
复制代码

粗暴中发现那个数组的处理过程可以更短，6次解决：

Move Steps: 5,5,5,2,6,5
3,4,7,1,10,9,8,11,24 <- Original
4,7,1,10,9,3,8,11,24
7,1,10,9,3,4,8,11,24
1,10,9,3,4,7,8,11,24
10,9,1,3,4,7,8,11,24
9,1,3,4,7,8,10,11,24
1,3,4,7,8,9,10,11,24
复制代码

523066680

回复 1# 老刘1号

    Tiger就是那个初中一年级，做MIT英文原版数学试卷、精通C++、Python、JAVA，熟练 PyTorch、 Tensorflow、会写CNN DNN RNN KNN，的神奇少年吗。
看到那个群里这么多大神，吓得我退群点了个外卖。

523066680

回复 14# 老刘1号

你用批处理，在解决问题的时候还要为批处理伤脑筋，很不容易～
要是换成其他脚本，各种骚操作、语法糖用了再说，舒服。

但仔细想想确实很蛋疼的感觉，不想写

523066680

回复 16# 老刘1号

移动两个元素的同时还要保持其他元素的原有顺序，感觉好蛋疼

犯了一个数组坐标偏移计算错误，花了很多时间去矫正（就是临时数组消减后下标减小了，失算）

my @idx = qw/0 1 2 3 4/;
my ($a, $b) = (3,4);
my $apos = $a;
my $bpos = $b;
my $exchange = 0;
printf "%d %d, %s\n", $apos, $bpos, join(",", @idx);

# 首位数插入idx[$b]的前方
$first = shift @idx;
splice( @idx, $b-1, 0, $first );
$apos-=1;
printf "%d %d, %s\n", $apos, $bpos, join(",", @idx);

while (1)
{
    $first = shift @idx;
    if ( $first == $a ) {
        splice( @idx, $bpos, 0, $first );
        $apos = $bpos;
        $bpos -= 1;
        $exchange = 1;
    } else {
        if ( $bpos ne $a ) {
            if ($exchange) {
                splice( @idx, $apos-1, 0, $first );
                $bpos -= 1;
            } else {
                splice( @idx, $bpos-1, 0, $first );
                $apos -= 1;
            }
        } else {
            last;
        }
    }
    printf "%d %d, %s\n", $apos, $bpos, join(",", @idx);
}
复制代码

前面两个数是位置变化

3 4, 0,1,2,3,4
2 4, 1,2,3,0,4
1 4, 2,3,0,1,4
0 4, 3,0,1,2,4
4 3, 0,1,2,4,3
复制代码

523066680

回复 20# search_Sudoku

惊醒梦中人，我竟然没意识到到这个过程同样可以构建一个逐步扩大的有序列表, why didn't I think of that!
这样完全可以获得[步数]在[元素个数]以内的解，无论效率还是实现，应该都是最佳方案。

本来我在想那个递归跑出来的最短步骤解，但是想想就像通常情况下的的排序，某些解同样有更快的步骤，这些步骤的缩减有时只能是针对性的，即使实现了，也会改变效率的“天枰”。

523066680

回复 24# 老刘1号

我先用递归跑出来一些结果，然后去强行找规律、强行解释一波，发现没什么大的漏洞就拿来用了。

有明确的调换方法，假设要调换列标3和7

012345678  -  将7和3位置调换，可以预见的是3和7调换后，012在7的前面（成为7的前缀）；456同理；
012345601278  - 将排头的012依次插入7的前方。
0003456012738 - 0127已经达成，现在开头的是数字3，将它放在数字7后面
0000456012745638 - 然后将前缀456插入数字3的前面。


有了这个规则，就可以来一波语法糖

my @index = qw/0 1 2 3 4 5 6 7 8/;
my ($a, $b) = (3,7);
my ($apos, $bpos) = ($a, $b);
my $show = sub {printf "[%d,%d] %s\n", $apos, $bpos, join(",", @index)};

$show->();
# $a 的前缀转移到 $b 前面
grep { splice( @index, $bpos-1, 0, shift @index ); $apos--; $show->() } (1..$a);

# $a 移到 $b 后面
splice( @index, $bpos, 0, shift @index );
$apos = $bpos, $bpos--;
$show->();

# $b 的前缀转移到 $a 前面
grep { splice( @index, $apos-1, 0, shift @index ); $bpos--; $show->() } ($a+1..$b-1);
exit;
复制代码

[3,7] 0,1,2,3,4,5,6,7,8
[2,7] 1,2,3,4,5,6,0,7,8
[1,7] 2,3,4,5,6,0,1,7,8
[0,7] 3,4,5,6,0,1,2,7,8
[7,6] 4,5,6,0,1,2,7,3,8
[7,5] 5,6,0,1,2,7,4,3,8
[7,4] 6,0,1,2,7,4,5,3,8
[7,3] 0,1,2,7,4,5,6,3,8
复制代码

.
回复 26# search_Sudoku

     针对 3,4,7,1,10,9,8,11,24（24暂时用K替代） 昨晚拿着扑克牌手动排了几次，处理方式和你的描述接近但有差异，
差不多7次。晚点儿再实践实践
    又想了想，递归也可以优化优化（暴力解虽然费时，但是省心 ）。

523066680

回复 22# search_Sudoku

      按这个方式实现了（二分搜索没做进去），很利落

=info
    Ref:
    http://www.bathome.net/redirect.php?goto=findpost&ptid=51910&pid=217048
=cut

my @arr = qw/25 23 4 9 8 2 1 12 15/;
my $offset;
my $first;
printf "%s <- Original\n", join(",", @arr);

# 查找末尾有序数组的起点
$offset = $#arr+1 - seqsizes( \@arr );

while ( $offset > 0 || $arr[0] > $arr[1] )
{
    $first = shift @arr;
    insert( \@arr, $offset, $first );
    $offset--;
    printf "%s\n", join(",", @arr);
}

sub insert
{
    my ($arr, $begin, $ele) = @_;
    for my $i ( $begin .. $#$arr ) {
        if ($arr->[$i] > $ele ) { splice( @$arr, $i, 0, $ele ); return; }
    }
    splice( @$arr, $#$arr+1, 0, $ele );
}

sub seqsizes
{
    my ($r, $size) = (shift, 1);
    for my $i (1..$#$r) {
        $r->[-$i] > $r->[-$i-1] ? $size++ : last;
    }
    return $size;
}
复制代码

3,4,7,1,10,9,8,11,24 <- Original
4,7,1,10,9,3,8,11,24
7,1,10,9,3,4,8,11,24
1,10,9,3,4,7,8,11,24
10,9,1,3,4,7,8,11,24
9,1,3,4,7,8,10,11,24
1,3,4,7,8,9,10,11,24
复制代码

25,23,4,9,8,2,1,12,15 <- Original
23,4,9,8,2,1,12,15,25
4,9,8,2,1,12,15,23,25
9,8,2,1,4,12,15,23,25
8,2,1,4,9,12,15,23,25
2,1,4,8,9,12,15,23,25
1,2,4,8,9,12,15,23,25
复制代码