# Author:  Chao-Kuei Hung
# For more info, including license, please see doc/index.html

package RecCanvas;

use strict;
use Carp;
use Tk::Canvas;
use Tk::Derived;
use base qw(Tk::Derived Tk::Canvas);

# see perldoc Tk::mega and perldoc Tk::composite
Construct Tk::Widget 'RecCanvas';

# Should I use InitObject (c.f. Tk::mega) or Populate (c.f. Tk::Derived)?
# Both seem to work ok. According to Tk::composite, a "widget based"
# composite should define InitObject. RecCanvas is not a composite, is it?
sub InitObject {
    my ($self, $args) = @_;
    $self->{-name} = delete $args->{-name};
    carp "Each RecCanvase must have a unique -name. RecCanvas'es" .
	"without names cause asynchrony in multiple window scenarios"
	unless defined $self->{-name};
    $self->{-maxlevel} = (delete $args->{-maxlevel} or 3);
    $self->{-elevation} = (delete $args->{-elevation} or 0);
    $self->{"#bbox"} = [0, 0, 0, 0];
    $self->SUPER::InitObject($args);

    $self->forget();
    $self->ConfigSpecs(
	-recorder=>[qw(METHOD recorder Recorder 0)],
	-coordinator=>[qw(PASSIVE coordinator Coordinator), undef],
    );
}

sub cget {
    my ($self, $opt) = @_;
    return $self->{$opt} if exists $self->{$opt};
    return $self->SUPER::cget($opt);
}

sub forget {
    my ($self) = @_;
#    $self->delete("all");
    $self->time_seek(0)
	if (exists $self->{"#now"} and $self->{"#now"} > 0);
    my ($t) = [ map {0} 0..$self->{-maxlevel} ];
    $self->{"#history"} = [ {mark=>$t} ];
    $self->{"#now"} = 0;
}

sub get_mark_at {
    my ($self, $pos, $level) = @_;
    my ($h) = $self->{"#history"};
    return (defined $level) ? $h->[$pos]{mark}[$level] : @{ $h->[$pos]{mark} };
}

sub total_marks {
    my ($self, $level) = @_;
    my ($h) = $self->{"#history"};
    return $self->get_mark_at($#$h, $level);
}

sub get_mark {
    my ($self, $level) = @_;
    return $self->get_mark_at($self->{'#now'}, $level);
}

sub set_mark {
    my ($self, $level, $final) = @_;
    $level += $self->{-elevation};
    die "level ", $level-$self->{-elevation},
	" shifted $self->{-elevation} out of range (0..$self->{-maxlevel})"
	unless ($level >= 0 and $level <= $self->{-maxlevel});
    return unless $self->cget(-recorder);
    my ($now, $h) = ($self->{"#now"}, $self->{"#history"});
    @{ $h->[$now]{mark} } = $now>0 ? @{ $h->[$now-1]{mark} } :
	map {0} 0..$self->{-maxlevel};
    foreach my $i (0..$level) {
	++$h->[$now]{mark}[$i];
    }
    my ($ctrl) = $self->cget(-coordinator);
    $ctrl->mark_other_canvases($self, $level) # note: $level is absolute 
	if (ref $ctrl and not defined $final);
}

# state: 0<--->1<--->2<--->3<--->4<--->5<--->6<--->7<--->8
# mark:     0     1     2     3     4     5     6     7
#           0     0     1     1     2     2     3     3
#           0     0     0     0     1     1     1     1
#           0     0     0     0     0     0     0     0

sub no_op {
# no operation; dummy step; useful only in multiple-canvas scenarios
    my ($self) = @_;
    return unless $self->cget(-recorder);
    my ($h) = $self->{"#history"};
    my ($now) = $self->{"#now"};
    my ($mark) = $h->[$now]{mark};
    ++$now;
    @{ $h->[$now]{mark} } = @$mark;
    $self->{"#now"} = ++$h->[$now]{mark}[0];
}

sub record_one_step {
    my ($self, $id, $frw_func, $frw_args, $bkw_func, $bkw_args) = @_;

print "f($id): $frw_func(", join(",",@$frw_args), ")\n" unless ($#$frw_args % 2 == 1);
print "b($id): $bkw_func(", join(",",@$bkw_args), ")\n" unless ($#$bkw_args % 2 == 1);
    my ($h, $now) = ($self->{"#history"}, $self->{"#now"});
    @{ $h->[$now]{forward} }{"id", "method", "args"} =
	($id, $frw_func, $frw_args);
    my ($mark) = $h->[$now]{mark};
    ++$now;
    @{ $h->[$now]{backward} }{"id", "method", "args"} =
	($id, $bkw_func, $bkw_args);
    @{ $h->[$now]{mark} } = @$mark;
    $self->{"#now"} = ++$h->[$now]{mark}[0];
    my ($ctrl) = $self->cget(-coordinator);
    $ctrl->incr_other_canvases($self) if ref $ctrl;
}

sub itemconfigure {
    my ($self, $id, %opts) = @_;
    my ($method, $camouflage, $hidden, $k);
    $method = "SUPER::itemconfigure";
    $camouflage = $self->cget(-bg);
    foreach $k (keys %opts) {
print "<$k:$opts{$k}>\n" unless defined $k and defined $opts{$k};
	if ($opts{$k} eq "hidden" and $k ne "-state") {
	    $opts{$k} = $camouflage;
	    $hidden = 1;
	}
    }
    if ($self->cget(-recorder)) {
	my (%bkw) = %opts;
	map { $bkw{$_} = $self->itemcget($id, $_) } keys %bkw;
	$self->record_one_step($id, $method, [%opts], $method, [%bkw]);

# why? this one-step statement causes undef and "" to be lost,
# resulting in odd number of hash elements, etc.
# This happens only after I upgraded from perl 5.8.0 to perl 5.8.5
#	$self->record_one_step($id,
#	    $method, [%opts],
#	    $method, [map { $_=>$self->itemcget($id, $_) } keys %opts]
#	);

#	if ($hidden) {
#	    $self->lower($id, "all");
#	} else {
#	    $self->raise($id, "all");
#	}
    }
    return $self->$method($id, %opts);
}

sub coords {
    my ($self, $id, @coords) = @_;
    my ($method) = "SUPER::coords";

    if ($self->cget(-recorder)) {
	$self->record_one_step($id,
	    $method, \@coords,
	    $method, [$self->$method($id)]
	);
#	$self->raise($id, "all");
    }
    return $self->$method($id, @coords);
}

sub item_raise {
    my ($self, $id, @args) = @_;
    my ($method) = "SUPER::raise";
    if ($self->cget(-recorder)) {
	$self->record_one_step($id,
	    $method, \@args,
	    "SUPER::lower", \@args
	);
    }
    return $self->$method($id, @args);
}

sub item_lower {
    my ($self, $id, @args) = @_;
    my ($method) = "SUPER::lower";
    if ($self->cget(-recorder)) {
	$self->record_one_step($id,
	    $method, \@args,
	    "SUPER::raise", \@args
	);
    }
    return $self->$method($id, @args);
}

sub ceiling {
    my ($self, $level, $now) = @_;
    $now = $self->{"#now"} unless defined $now;
    my ($h) = $self->{"#history"};
    my ($maxpos) = $self->total_marks(0);
    return $maxpos if $now >= $maxpos or $level > $self->{-maxlevel};
    while ($now < $maxpos and $h->[$now-1]{mark}[$level] == $h->[$now]{mark}[$level] ) {
	++$now;
    }
    return $now;
}

sub floor {
    my ($self, $level, $now) = @_;
    $now = $self->{"#now"} unless defined $now;
    my ($h) = $self->{"#history"};
    return 0 if $now <= 0 or $level > $self->{-maxlevel};
    while ($now > 0 and $h->[$now-1]{mark}[$level] == $h->[$now]{mark}[$level] ) {
	--$now;
    }
    return $now;
}

sub find_forward_stop {
    my ($self, $level) = @_;
    return $self->ceiling($level, $self->{"#now"} + 1);
}

sub find_backward_stop {
    my ($self, $level) = @_;
    return $self->floor($level, $self->{"#now"} - 1);
}

sub relative_mark {
    my ($self, $mark) = @_;
    my ($level, $result);
    my ($h, $now) = ($self->{"#history"}, $mark->[0]);
    for ($level=0; $level<$#$mark; ++$level) {
	push @$result, $mark->[$level] -
	    $h->[ $self->floor($level+1, $now) ]{mark}[$level]
    }
    push @$result, $mark->[$#$mark];
    return @$result;
}

sub time_seek {
    my ($self, $target) = @_;
    my ($n) = $self->total_marks(0);
    die "target $target out of range (0..$n)"
	if ($target < 0 or $target > $n);
    my ($h) = ($self->{"#history"});
    while ($self->{"#now"} < $target) {
	my ($step) = $h->[$self->{"#now"}]{forward};
	no strict "refs";
	    # see perlobj(1) and search for the 2nd "WARNING"
	    my ($method) = $step->{method};
	    $self->$method($step->{id}, @{$step->{args}}) if $method;
	use strict "refs";
	++$self->{"#now"};
    }
    while ($self->{"#now"} > $target) {
	my ($step) = $h->[$self->{"#now"}]{backward};
	no strict "refs";
	    # see perlobj(1) and search for the 2nd "WARNING"
	    my ($method) = $step->{method};
	    $self->$method($step->{id}, @{$step->{args}}) if $method;
	use strict "refs";
	--$self->{"#now"};
    }
}

sub find_position {
    my ($self, $level, $target) = @_;
    die "level $level out of range (0..$self->{-maxlevel})"
	unless ($level >= 0 and $level <= $self->{-maxlevel});
    my ($n) = $self->total_marks(0);
    die "target $target at level $level out of range (0..$n)"
	unless ($target >= 0 and $target <= $n);
    my ($h) = ($self->{"#history"});
    my ($i);
    for ($i=0; $i<=$n and $h->[$i]{mark}[$level]<$target; ++$i) { }
    return $i;
}

sub bbox_update {
    my ($self) = @_;
# $self->{canvas}->idletasks();
    my (@t) = $self->bbox("all");
    $self->{"#bbox"}[2] = $t[2] if (defined $t[2] and $t[2] > $self->{"#bbox"}[2]);
    $self->{"#bbox"}[3] = $t[3] if (defined $t[3] and $t[3] > $self->{"#bbox"}[3]);
}

sub bbox_ever {
    my ($self) = @_;
    return @{$self->{"#bbox"}};
}

sub recorder {
    my ($self, $state) = @_;
    $self->{-recorder} = $state;

    $self->bbox_update();
    $self->configure(-scrollregion=> [ $self->bbox_ever() ]);
    # bug! This should really be done after
    # every ->create*() call and every ->coords() call
}

if ($0 =~ /RecCanvas.pm$/) {
# being tested as a stand-alone program, so run test code.

use Tk;
my ($main, $mb, $rc, $b);
$main = MainWindow->new();
$mb = $main->Frame();
$mb->pack(-side=>"top", -fill=>"both");
$rc = $main->Scrolled("RecCanvas", -scrollbars=>"osow",
    -elevation=>4, -maxlevel=>6, -width=>300, -height=>200);
$rc->pack(-expand=>"yes", -fill=>"both");
$b->[0] = $mb->Button(-text=>"|<-", -command=>
    sub { $rc->time_seek($rc->find_backward_stop(6)); });
$b->[1] = $mb->Button(-text=>"<<-", -command=>
    sub { $rc->time_seek($rc->find_backward_stop(5)); });
$b->[2] = $mb->Button(-text=>"<--", -command=>
    sub { $rc->time_seek($rc->find_backward_stop(4)); });
$b->[3] = $mb->Button(-text=>"-->", -command=>
    sub { $rc->time_seek($rc->find_forward_stop(4)); });
$b->[4] = $mb->Button(-text=>"->>", -command=>
    sub { $rc->time_seek($rc->find_forward_stop(5)); });
$b->[5] = $mb->Button(-text=>"->|", -command=>
    sub { $rc->time_seek($rc->find_forward_stop(6)); });
$b->[0]->pack(@{$b}[1..5], -side=>"left", -fill=>"both");

my ($i, $j, $block);
for ($i=0; $i<4; ++$i) {
    for ($j=0; $j<4; ++$j) {
	$block->[$i][$j] = $rc->createRectangle(
	    $j*40+20, $i*30+15, $j*40+40, $i*30+30);
	$rc->itemconfigure($block->[$i][$j], -outline=>"hidden");
    }
}
$rc->configure(-recorder=>1);
for ($i=0; $i<4; ++$i) {
    for ($j=0; $j<4; ++$j) {
	$rc->itemconfigure($block->[$i][$j], -outline=>"cyan");
	$rc->itemconfigure($block->[$i][$j], -outline=>"yellow");
	$rc->itemconfigure($block->[$i][$j], -outline=>"magenta");
	$rc->set_mark(0);
    }
    $rc->set_mark(1);
}
$rc->configure(-recorder=>0);
print "-maxlevel: ", $rc->cget(-maxlevel),
    "; -elevation: ", $rc->cget(-elevation), "\n";
MainLoop();

}

1;

__END__

=head1 NAME

Tk::RecCanvas - A Canvas widget with simple recording capability

=head1 SYNOPSIS

I<$reccanvas> = I<$parent>-E<gt>B<RecCanvas>(?I<options>?);

=head1 DESCRIPTION

An RecCanvas behaves much like a Canvas, but also has minimal
ability to record certain configuration changes of canvas items.
Specifically, B<itemconfigure> and B<coords> are recorded,
but item creation and destruction are I<not>.

=head1 ADVERTISED SUBWIDGETS

None.

=head1 OPTIONS

=head1 METHODS

=head1 AUTHOR

B<Chao-Kuei Hung> ckhung AT cyut DOT edu DOT tw

This code is distributed under the same terms as Perl.

=cut