📄 cpagree.pas
字号:
{*******************************************************************
* *
* COMPONENT for MS DOS and Windows source code. *
* *
* (c) 1992, Roderic D. M. Page *
* *
* Language: Turbo Pascal (Pascal with object-oriented extensions) *
* Compiler: Turbo Pascal 6.0 (MS DOS) *
* Turbo Pascal for Windows 1.0 (WINDOWS) *
* *
* Notes: Program interface is currently Windows specific. *
* *
*******************************************************************}
{$I cpdir.inc}
{*
Greatest common agreement subtrees
Kubicka, Kubicka, and McMorris (preproposal), sent by
McMorris Oct 9, 1991.
To do
=====
Check for memory allocation in error when allocating AG in
AgreeTree.
History
=======
17 Oct 1991 Started.
21 Oct 1991 Stack overflow errors occurred. Made AGREELIST
a dynamic variable.
1 Nov 1991 Code cleaned up, realized that rooted trees need
to be treated differently. All references to
PROFILEOBJ removed so code can be called
from within CPPROF.PAS
22 Apr 1992 Major debugging session. Original code failed to
find the 27 leaf subtree for Kubicka et al'.s
AGREE50.NEX example. The reason was my hopeless
mucking up of recursion! The variables keeping track
of the largest subtree had the wrong scope and
would be overwritten, leading the program to miss
the correct subtree.
Minor modifications: GetSubTree improved by updating
weights, etc, as subtree is built, rather than
subsequently calling TREEOBJ routines.
*}
unit cpagree;
interface
uses
{$IFDEF DEBUG_AGREE1}
{$IFDEF WINDOWS} WinCrt, {$ENDIF}
{$ENDIF}
Strings,
cpvars,
cpset,
cptree,
{$IFDEF NEWBUFFER}
cpwntbuf,
{$ELSE}
cptbuf,
{$ENDIF}
cpactive,
cpwcdial; { Counter dialog box }
{$IFDEF DEBUG_AGREE1}
var
outfile: text;
{$ENDIF}
procedure CommonUnRootedSubtree (var B: TREE_BUFFEROBJ;
var A: ACTIVEOBJ;
T1ID, T2ID, UnPrunedLeaves:integer;
var SubTree: CLUSTEROBJ);
procedure CommonRootedSubtree(var T1, T2:TREEOBJ;
UnPrunedLeaves:integer;
var SubTree:CLUSTEROBJ);
function InCommonRootedSubtree(var T1, T2:TREEOBJ;
UnPrunedLeaves:integer):integer;
function InCommonUnrootedSubtree (var B: TREE_BUFFEROBJ;
var A: ACTIVEOBJ;
T1ID, T2ID, UnPrunedLeaves:integer):integer;
procedure CreateSubTree (var SubTree:TREEOBJ;
var SubTreeLeaves:CLUSTEROBJ;
OriginalLeaves: integer);
implementation
type
{ Contains the information for recovering the subtree }
AGREEREC = record
prev,
order,
color,
total : integer;
leaves : CLUSTEROBJ;
end;
AGREELIST = array[1..MAXLEAVES] of AGREEREC;
AG_PTR = ^AGREELIST;
var
{ Variables that are global within this unit so that they
remain constant during successive calls to the recursive
procedure AgreeTree. (This is like a "static" variable in C.)
}
TotalLeaves : integer; {Total number of leaves in original problem }
{$IFDEF DEBUG_AGREE1}
Level : integer;
{$ENDIF}
{-----------------------------T1Sequence-----------------------------------}
{ Traverse T1 in the direction of more leaves. Label the
descendants of each internal node encountered with a
unique branch label. Return the last leaf in the tree.
This effectively traces out the "main path" of the tree
(....)
E.g., Kubicka et al. T1
1
a
.
1
.
/ .
2 .
/ .
/ .
/ .
/ /.
/ 3 /.
/ / 4 .
/ / / .
/ / / /.
/ / / 5 .\
/ / / / .\ 6
/ / / / .\ 7 \
/ / / / .\ 8 \ \
/ / / / /. 9 \ \ \
/\ / / / 10 . \ \ \ \
/\ \ / / / / . \ \ \ \
/\ \ \ / /\ / /\ 11. \ \ \ \
/ /\ \ \ / /\ \ / /\ \ / /. \ \ \ \
d e f c b g h i j k r s t u w z p n m l
1 1 1 1 1 1
2 2 2 2 2 3 4 4 4 5 0 0 0 1 2 3 9 8 7 6
z is the last leaf in the tree.
}
function T1Sequence (var T:TREEOBJ):integer;
var
q, left, right: NODE_PTR;
branchlabel : integer;
procedure LabelSubTree (p: NODE_PTR);
begin
if (p <> NIL) then begin
if (p^.IsLeaf) then
p^.SetIndex (branchlabel);
LabelSubTree (p^.child);
if (p <> left) and (p <> right) then
LabelSubTree (p^.sib);
end;
end;
begin
BranchLabel := 0;
q := T.Root;
while not q^.IsLeaf do begin
Inc (BranchLabel);
left := q^.child;
right := q^.child^.sib;
if (left^.GetWeight <= right^.GetWeight) then begin
LabelSubTree (left);
q := right;
end
else begin
LabelSubTree (right);
q := left;
end;
end;
q^.SetIndex (Succ (BranchLabel));
T1Sequence := q^.NodeNamePtr;
end;
{-----------------------------LabelT2--------------------------------------}
{ Label T2 with T1's leaf colors }
procedure LabelT2 (var T1, T2:TREEOBJ);
var
i, j: integer;
k:integer;
begin
j := 0;
i := 0;
while (j < T2.TreeLeaves) do begin
repeat
inc (i);
until (T2.NL[i] <> NIL);
T2.NL[i]^.SetIndex (T1.NL[i]^.NodeIndex);
Inc (j);
end;
end;
{-----------------------------T2Sequence-----------------------------------}
{ Label T2 with T1's leaf colors, and mark the path a-z on T2.
T2:
1
a
.
.
.
/ .
/ .
/ .
/ .
/ .
/ .
/ .
/ .
/ .
/ /.
/ / /.
/\ / / .\
/ \ / / . \
/ \ / / . \
/\ \ / / . \
/ \ \ / / . /\
/\ \ \ / / .\ / \
/\ \ \ /\ / / /. \ / /\
/\ \ \ /\ / /\ / / /\ . \ /\ / /\
b d f c h i g m n l e j w z k p t u r s
1 1 1 1 1 1
2 2 2 2 4 4 3 7 8 6 2 4 2 3 5 9 0 1 0 0
}
procedure T2Sequence (var T1, T2: TREEOBJ; z:integer);
begin
LabelT2 (T1, T2);
T2.MarkPath (T2.IthLabel (z));
end;
{-----------------------------MarkASubTree---------------------------------}
{ For each leaf in T not in desired subset,
mark it and its first nonmarked ancestor by
setting the tm_DELETE flag.
This is logically equivalent to pruning the
tree of all leaves except those in the subset.
This proc is modified from the similar one in
CPNNI.PAS }
procedure MarkASubTree (var T:TREEOBJ; var SubSet:CLUSTER);
var
i, j: integer;
q : NODE_PTR;
begin
T.SetNodeFlags (tn_DELETE, False);
{ Remember that the leaves of a tree need not be
labeled 1..n because of pruning. }
j := 0;
i := 0;
while (j < T.TreeLeaves) do begin
repeat
Inc (i);
until (T.NL[i] <> NIL);
if not (T.NL[i]^.NodeNamePtr in SubSet) then begin
T.NL[i]^.SetFlag (tn_DELETE, True);
q := T.NL[i]^.NodeAncestor;
while q^.IsFlag (tn_DELETE) do
q := q^.NodeAncestor;
q^.SetFlag (tn_Delete, True);
end;
Inc (j);
end;
end;
{-----------------------------GetSubTree-----------------------------------}
{ Return in SubT a subtree of T made up of
just those nodes not flagged tm_DELETE.
Based on a similar procedure in CPNNI.PAS
}
procedure GetSubTree (var T, SubT: TREEOBJ);
procedure Traverse (p:NODE_PTR);
var
q, r: NODE_PTR;
begin
if (p <> NIL) then begin
if not p^.IsFlag (tn_DELETE) then begin
{ p is part of subtree... }
q := SubT.ST.TopOfStack;
if (q^.Child = NIL) then begin
{ Make a child of q... }
r := new (NODE_PTR, Init);
q^.child := r;
r^.anc := q;
q^.IncDegree;
if (p^.IsLeaf) then begin
{...r is a leaf }
SubT.IncLeaves;
r^.SetLeaf;
r^.SetNamePtr (p^.NodeNamePtr);
SubT.NL[p^.NodeNamePtr] := r;
r^.SetWeight (1);
r^.IncDegree;
r^.Cluster.AddToSet (p^.NodeNamePtr);
q^.AddWeight(1);
q^.Cluster.AddToSet (p^.NodeNamePtr);
end
else begin
{...r is an internal }
SubT.IncInternals;
SubT.ST.Push (r);
end;
end
else begin
{ ...make a sibling of q's child. }
r := new (NODE_PTR, Init);
q^.child^.sib := r;
r^.anc := q;
q^.IncDegree;
if (p^.IsLeaf) then begin
SubT.IncLeaves;
r^.SetLeaf;
r^.SetNamePtr (p^.NodeNamePtr);
SubT.NL[p^.NodeNamePtr] := r;
r^.SetWeight (1);
r^.Cluster.AddToSet (p^.NodeNamePtr);
q^.AddWeight(1);
q^.Cluster.AddToSet (p^.NodeNamePtr);
end
else begin
SubT.IncInternals;
SubT.ST.Push (r);
end;
end; { if q^.child then else }
end; { if not p^.IsFlag }
Traverse (p^.child);
if (not p^.IsLeaf) and (not p^.IsFlag (tn_DELETE)) then begin
{ We've visited all the descendants of the part of
the subtree rooted at the node on the top of
the stack. Update this node's information, then
pop it off the stack.
}
r := SubT.ST.TopOfStack;
q := r^.anc;
if (q <> NIL) then begin
q^.Cluster.AddSetToSet (r^.Cluster);
q^.AddWeight (r^.GetWeight);
end;
SubT.ST.Pop;
end;
{ Unmark as we go down tree }
p^.SetFlag (tn_DELETE, False);
Traverse (p^.sib);
end;
end;
begin
SubT.Init;
SubT.MakeRoot;
SubT.IncInternals;
SubT.ST.Push (SubT.Root);
Traverse (T.Root);
{ prune off subroot }
SubT.Root := SubT.Root^.child;
Dispose (SubT.Root^.anc, Done);
SubT.Root^.anc := NIL;
end;
{-----------------------------AgreeTree------------------------------------}
{ The main recursive procedure to find the greatest agreement
subtree of T1 and T2. Returns in SubTreeSize the size of the
subtree, and in Result the set of leaves in the subtree. }
procedure AgreeTree (var T1, T2: TREEOBJ; var SubTreeSize:integer;
var Result:CLUSTEROBJ);
var
AG : AG_PTR; { information on agreement subtrees }
q,
left,
right : NODE_PTR; { temporary node ptrs }
C : CLUSTEROBJ; { cluster along path }
S, { temporary sets }
sc : CLUSTER;
i,j,k, { loop counters }
Card,
Code :integer;
Ai, { ptrs to AG }
LastAi : integer;
SubT1, { subtrees to be checked }
SubT2 : TREEOBJ_PTR;
SubTSize : integer; { size of agreement subtree }
SubTResult : CLUSTEROBJ; { leaves in agreement subtree }
T1s : integer;
ASubTreeSize : integer;
ASubTree : CLUSTEROBJ;
{$IFDEF DEBUG_AGREE1}
Spacer: array[0..20] of char;
{$ENDIF}
{ Find in the list of subtrees the subtree upto and
including LastSubTree that's color is before code
(i.e. it belongs on an earlier branch in T1) and
is part of the largest subtree so far. Note that
ties are ignored, so they may in fact be more than
one solution. }
function Previous (LastSubtree, code:integer):integer;
var
i,prev,Max: integer;
begin
Max := 0;
prev := 0;
for i := 1 to LastSubtree do
if (AG^[i].Color < Code) then
if (AG^[i].total > max) then begin
max := AG^[i].total;
prev := i;
end;
Previous := prev;
end;
begin
{ Check if user wants to abort...}
{$IFDEF WINDOWS}
if (Counter <> NIL) then begin
Counter^.PassOnMsg;
if bUserAbort then
Exit;
end;
{$ENDIF}
{$IFDEF DEBUG_AGREE1}
Inc (Level);
Spacer[0] := #0;
for i := 1 to Level do
StrCat (Spacer, '⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -