1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
# Author: Chao-Kuei Hung
# For more info, including license, please see doc/index.html
package RBTree;
# Red-Black Tree
use strict;
use Carp;
use vars qw(@ISA);
@ISA = qw(BST);
use BST;
# sub new { my ($self) = shift; $self->SUPER::new(@_); }
sub insert {
my ($self, $sk_cont, %opts) = @_;
# $sk_cont is search key, should have the same structure as -content=>...
my ($nn, $r, $focus, $grand, $parent, $uncle);
$nn = $self->SUPER::insert($sk_cont, %opts);
$nn->configure(-status=>"discard");
$self->cget(-canvas)->set_mark(0);
$focus = $nn;
while (1) {
$parent = $focus->parent();
last if $parent->cget(-status) ne "discard";
die if $parent->level() <= 0; # impossibe, because root is always black
$grand = $parent->parent();
$uncle = $grand->child(1 - $parent->rank());
if (ref $uncle and $uncle->cget(-status) eq "discard") {
# then parent is not the root
$parent->configure(-status=>"done");
$uncle->configure(-status=>"done");
$grand->configure(-status=>"discard");
$self->cget(-canvas)->set_mark(0);
$focus = $grand;
} else {
if ($focus->rank() != $parent->rank()) {
if ($parent->rank() == 0) {
$parent->rotate_ccw();
} else {
$parent->rotate_cw();
}
$self->cget(-canvas)->set_mark(0);
($focus, $parent) = ($parent, $focus);
}
if ($parent->rank() == 0) {
$grand->rotate_cw();
} else {
$grand->rotate_ccw();
}
$parent->configure(-status=>"done");
$grand->configure(-status=>"discard");
$focus->configure(-status=>"discard");
$self->cget(-canvas)->set_mark(0);
last;
}
}
# make sure root is always black
$self->root()->configure(-status=>"done")
unless $self->root()->cget(-status) eq "done";
return $nn;
}
sub remove {
my ($self, $node) = @_;
print STDERR "remove() not implemented yet, ignored\n";
return undef;
}
$::Config->{RBTree} = {
-appearance => {
%{ ::deep_copy(Configurable::cget("BST", -appearance)) },
done => { -outline=>"Black",-fill=>"Gray",
-thick=>3, -stipple=>"" },
discard => { -outline=>"DarkRed", -fill=>"LightCoral",
-thick=>3, -stipple=>"gray25" },
focus => { -outline=>"DarkBlue", -fill=>"LightBlue",
-thick=>3, -stipple=>"gray25" },
},
};
if ($0 =~ /RBTree.pm$/) {
# being tested as a stand-alone program, so run test code.
require "utilalgo";
my ($mw, $ctrl, $can);
$mw = MainWindow->new(-title=>"main_test");
$can->{main} = gen_can($mw, undef, -elevation=>1, -maxlevel=>2);
$ctrl = gen_ctrl($mw, $can);
my ($tr) = RBTree->new(-canvas=>$can->{main}, %{ do "data/countries.gr" });
# $can->{main}->set_mark(1);
$ctrl->configure(-recorder=>0);
# If the canvas refuses to show any change, remember to verify that:
# - set_mark() was called at least once
# - -recorder is set to zero before entering MainLoop
# Failing to do either of the above will result in a mysterious bug
# that takes days to figure out !@#$%
Tk::MainLoop();
}
1;
|
