#!/usr/bin/perl -w
# Copyright 2008, 2009, 2010 Kevin Ryde
# This file is part of Chart.
#
# Chart is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 3, or (at your option) any later version.
#
# Chart is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
# details.
#
# You should have received a copy of the GNU General Public License along
# with Chart. If not, see <http://www.gnu.org/licenses/>.
use strict;
use warnings;
use Data::Dumper;
use constant DEBUG => 0;
sub make_perms {
my @items = @_;
if (@items == 0) { return (); }
if (@items == 1) { return [ $items[0] ]; }
my @perms;
foreach my $i (0 .. $#items) {
my $first = $items[$i];
my @rest = @items;
splice @rest, $i,1;
my @subperms = make_perms (@rest);
push @perms, map {[$first,@$_ ]} @subperms;
}
return @perms;
}
my $end = 7;
my @perms = make_perms (0 .. $end);
# print Dumper (\@perms);
sub move {
my ($wref, $item, $pos) = @_;
if (DEBUG) { print "move [",$item->[0],"] to $pos\n"; }
@$wref = grep {$_ != $item} @$wref;
splice @$wref, $pos,0, $item;
}
sub reorder_by_move_item {
my ($aref, $move) = @_;
my $offset = 0;
foreach my $newpos (0 .. $#$aref) {
my $oldpos = $aref->[$newpos];
if ($newpos != $oldpos + $offset) {
$move->($newpos, $oldpos);
$offset -= ($newpos <=> $oldpos+$offset);
}
}
}
sub reorder_array_prune_shuffles {
my ($aref) = @_;
my $offset = 0;
foreach my $newpos (0 .. $#$aref) {
my $oldpos = $aref->[$newpos];
if ($newpos == $oldpos + $offset) {
$aref->[$newpos] = undef;
} else {
$offset -= ($newpos <=> $oldpos+$offset);
}
}
}
sub make_reorder_move_test {
my $offset = 0;
return sub {
my ($newpos, $oldpos) = @_;
my $cmp = ($oldpos+$offset <=> $newpos);
$offset += $cmp;
return $cmp;
}
}
sub reorder {
my ($aref) = @_;
if (DEBUG) { print "\n"; }
my @widget = map {[$_+10]} 0 .. $#$aref;
my @children = ( @widget );
if (1) {
my $want_move = make_reorder_move_test();
foreach my $newpos (0 .. $#$aref) {
my $oldpos = $aref->[$newpos];
if ($want_move->($newpos,$oldpos)) {
my $item = $children[$oldpos];
move (\@widget, $item, $newpos);
}
}
} elsif (1) {
my @acopy = @$aref;
my $aref = \@acopy;
reorder_array_prune_shuffles ($aref);
foreach my $newpos (0 .. $#$aref) {
my $oldpos = $aref->[$newpos];
if (defined $oldpos) {
my $item = $children[$oldpos];
move (\@widget, $item, $newpos);
}
}
} elsif (0) {
reorder_by_move_item ($aref, sub { my ($newpos, $oldpos) = @_;
my $item = $children[$oldpos];
move (\@widget, $item, $newpos);
});
} else {
my $offset = 0;
foreach my $newpos (0 .. $#$aref) {
my $oldpos = $aref->[$newpos];
if ($newpos != $oldpos + $offset) {
my $item = $children[$oldpos];
move (\@widget, $item, $newpos);
$offset -= ($newpos <=> $oldpos+$offset);
}
if (DEBUG) { print " ",join(' ', map {$_->[0]} @widget),
" newpos $newpos offset $offset\n"; }
}
}
# print Dumper ($aref);
# print Dumper (\@widget);
if (DEBUG) {
print join(' ',@$aref), ' -> ', join(' ',map{$_->[0]}@widget), "\n";
}
foreach my $i (0 .. $#$aref) {
my $got = $widget[$i]->[0] - 10;
my $want = $aref->[$i];
if ($got != $want) {
print " wrong at $i (got $got, want $want)\n";
print Dumper($aref);
print Dumper(\@widget);
exit 0;
}
}
}
# [-1..-1]
foreach my $perm (@perms) {
reorder ($perm);
}
exit 0;
#------------------------------------------------------------------------------
# reorder helper
#
# make_reorder_test() returns a code ref procedure to test whether
# successive entries in a TreeModel style reorder array need to be applied.
#
# The procedure should be called $test->($newpos,$oldpos) on newpos values 0
# to N successively, with oldpos the position before any reordering. It
# returns true if a move should be applied. Eg.
#
# $test = make_reorder_test();
# foreach my $newpos (0 .. $#$reorder_array) {
# my $oldpos = $reorder_array->[$newpos];
# if ($test->($newpos,$oldpos)) {
# my $item = $original_items[$oldpos];
# move ($item, $newpos);
# }
# }
#
# The move is expected to be in the style of Gtk2::Menu::reorder_child(),
# shifting items at and beyond $newpos upwards.
#
# Basically $test keeps track of how much items at and beyond newpos have
# been moved up due to that shifting. If an item is in its correct position
# due to that shifting then there's no need for a move() call.
#
# This move call suppression is geared towards Gtk2::Menu::reorder_child()
# because as of Gtk 2.12 that function doesn't notice when a reorder request
# is asking for an unchanged position, it does some linear time linked-list
# searches anyway, and looping that over 0 to N ends up as O(N^2) time. A
# loop over 0 to N is not optimal, but it's simple, and in particular the
# supression test
sub make_reorder_test {
my $offset = 0;
return sub {
my ($newpos, $oldpos) = @_;
my $cmp = ($oldpos+$offset <=> $newpos);
$offset += $cmp;
return $cmp;
}
}
# When visible, shuffle around according to reorder array.
# For a big lot of moves maybe a re-setup would be better, though for a
# small shuffle in the list a $menu->reorder_child should be best.
#
my ($tearoff, @children) = _tearoff_and_children ($self);
if (@children < @$aref) {
carp __PACKAGE__.': oops, reorder array bigger than num children ('
. scalar(@$aref) . ',' . scalar(@children) . ')';
_recover_after_inconsistency ($self);
return;
}
my $test = make_reorder_test();
foreach my $newpos (0 .. $#$aref) {
my $oldpos = $aref->[$newpos];
if ($test->($newpos,$oldpos)) {
my $item = $children[$oldpos];
if ($item) {
$self->reorder_child ($item, $newpos + $tearoff);
} else {
carp __PACKAGE__.": oops, reorder array bad oldpos $oldpos";
_recover_after_inconsistency ($self);
return;
}
}
}