调试平衡二叉搜索树的过程

Question

我已经实现了红黑搜索树，目前正在研究以下功能：

以下功能目前有效：

• 向树添加新节点

• 打印树：

  -- 对于每个节点，打印如下信息：值，颜色，父元素的值

  -- 树的每个“层”都打印在单独的一行上

• 树木平衡：

  -- 节点重新着色

  -- 左转重新着色

  -- 右转重新着色

我写了一个左转的程序：

procedure LeftRotation(var p: NodePtr);
var
    grandpa, dad, son: NodePtr;
begin
    son := p^.left;
    dad := p^.prev;
    grandpa := p^.prev^.prev;
    grandpa^.left := p;
    p^.prev := grandpa;
    dad^.prev := p;
    dad^.right := son;
    if son <> nil then
        son^.prev := dad;
    p^.left := dad;
end;

我遇到了运行时错误 216.

我通过调试器运行程序：

55      dad^.prev := p;
1: p = 0x7ffff7ff1140
2: p^.value = 65
(gdb) 
56      dad^.right := son;
1: p = 0x7ffff7ff1140
2: p^.value = 65
(gdb) 
57      if son <> nil then
1: p = 0x0
2: p^.value = <error: Cannot access memory at address 0x18>

我发现在程序的第 11 行之后，指向当前节点的指针中放置了一个 nil 值：

dad^.right := son;

我不确定发生这种情况的原因，因为通过重新着色实现左右旋转的过程更加复杂并且使用相同的逻辑，但它们可以正常工作。这些过程允许在新元素按升序或降序排序时平衡树：

procedure RightRotationAndRecolor(var p: NodePtr);
var
    GreatGrandpa, grandpa, dad, bro: NodePtr;
begin
    dad := p^.prev;
    bro := p^.prev^.right;
    grandpa := p^.prev^.prev;
    GreatGrandpa := p^.prev^.prev^.prev;
    if GreatGrandpa <> nil then begin
        if GrandpaIsRightSon(grandpa) then
            GreatGrandpa^.right := dad
        else
            GreatGrandpa^.left := dad;
    end;
    if bro <> nil then
        bro^.prev := grandpa;
    grandpa^.left := bro;
    dad^.right := grandpa;
    dad^.prev := GreatGrandpa;
    grandpa^.prev := dad;
    dad^.color := black;
    grandpa^.color := red;
end;

节目全文如下：

program RBTreeDemo;
 
type
    col = (red, black);
 
    NodePtr = ^Node;
    Node = record
        left, right, prev: NodePtr;
        value: integer;
        color: col;
    end;
 
    NodePosition = ^NodePtr;
 
function TreeHeight(p: NodePtr): word;
var
    CurrHeight: word = 0;
begin
    if p = nil then begin
        TreeHeight := 0;
        exit;
    end;
    if TreeHeight(p^.left) >= TreeHeight(p^.right) then
        CurrHeight := TreeHeight(p^.left)
    else
        CurrHeight := TreeHeight(p^.right);
    TreeHeight := CurrHeight + 1;
end;
 
function CurrentRootIs(p: NodePtr): NodePosition;
begin
    if p^.prev = nil then
        CurrentRootIs := @p
    else
        CurrentRootIs := CurrentRootIs(p^.prev);
end;
 
function GrandpaIsRightSon(p: NodePtr): boolean;
begin
    if p^.value = p^.prev^.right^.value then
        GrandpaIsRightSon := true
    else
        GrandpaIsRightSon := false;
end;
 
procedure LeftRotation(var p: NodePtr);
var
    grandpa, dad, son: NodePtr;
begin
    son := p^.left;
    dad := p^.prev;
    grandpa := p^.prev^.prev;
    grandpa^.left := p;
    p^.prev := grandpa;
    dad^.prev := p;
    dad^.right := son;
    if son <> nil then
        son^.prev := dad;
    p^.left := dad;
end;
 
procedure RightRotationAndRecolor(var p: NodePtr);
var
    GreatGrandpa, grandpa, dad, bro: NodePtr;
begin
    dad := p^.prev;
    bro := p^.prev^.right;
    grandpa := p^.prev^.prev;
    GreatGrandpa := p^.prev^.prev^.prev;
    if GreatGrandpa <> nil then begin
        if GrandpaIsRightSon(grandpa) then
            GreatGrandpa^.right := dad
        else
            GreatGrandpa^.left := dad;
    end;
    if bro <> nil then
        bro^.prev := grandpa;
    grandpa^.left := bro;
    dad^.right := grandpa;
    dad^.prev := GreatGrandpa;
    grandpa^.prev := dad;
    dad^.color := black;
    grandpa^.color := red;
end;
 
procedure LeftRotationAndRecolor(var p: NodePtr);
var
    GreatGrandpa, grandpa, dad, bro: NodePtr;
begin
    dad := p^.prev;
    bro := p^.prev^.left;
    grandpa := p^.prev^.prev;
    GreatGrandpa := p^.prev^.prev^.prev;
    if GreatGrandpa <> nil then begin
        if GrandpaIsRightSon(grandpa) then
            GreatGrandpa^.right := dad
        else
            GreatGrandpa^.left := dad;
    end;
    if bro <> nil then
        bro^.prev := grandpa;
    grandpa^.right := bro;
    dad^.left := grandpa;
    dad^.prev := GreatGrandpa;
    grandpa^.prev := dad;
    dad^.color := black;
    grandpa^.color := red;
end;
 
function DadIsLeftSon(p: NodePtr): boolean;
begin
    if p^.prev^.prev^.left = nil then begin
        DadIsLeftSon := false;
        exit;
    end;
    if p^.prev^.prev^.left^.value = p^.prev^.value then
        DadIsLeftSon := true
    else
        DadIsLeftSon := false;
end;
 
function DadIsRightSon(p: NodePtr): boolean;
begin
    if p^.prev^.prev^.right = nil then begin
        DadIsRightSon := false;
        exit;
    end;
    if p^.prev^.prev^.right^.value = p^.prev^.value then
        DadIsRightSon := true
    else
        DadIsRightSon := false;
end;
 
function ImLeftSon(p: NodePtr): boolean;
begin
    if p^.prev^.left = nil then begin
        ImLeftSon := false;
        exit;
    end;
    if p^.prev^.left^.value = p^.value then
        ImLeftSon := true
    else
        ImLeftSon := false;
end;
 
function ImRightSon(p: NodePtr): boolean;
begin
    if p^.prev^.right = nil then begin
        ImRightSon := false;
        exit;
    end;
    if p^.prev^.right^.value = p^.value then
        ImRightSon := true
    else
        ImRightSon := false;
end;
 
procedure SetGrandpaColorRed(var p: NodePtr);
begin
    if p^.prev^.prev^.prev = nil then
        exit
    else
        p^.prev^.prev^.color := red;
end;
 
procedure SetDadAndUncleColorBlack(var p: NodePtr);
begin
    if (p^.prev^.prev^.left = nil) or (p^.prev^.prev^.right = nil) then
        exit;
    p^.prev^.prev^.left^.color := black;
    p^.prev^.prev^.right^.color := black;
end;
 
procedure recolor(var p: NodePtr);
begin
    SetDadAndUncleColorBlack(p);
    SetGrandpaColorRed(p);
end;
 
function UncleIsBlack(p: NodePtr): boolean;
begin
    if (p^.prev^.prev^.left = nil) or (p^.prev^.prev^.right = nil) then begin
        UncleIsBlack := true;
        exit;
    end;
    if (p^.prev^.prev^.left^.color = black) or
        (p^.prev^.prev^.right^.color = black)
    then begin
        UncleIsBlack := true
    end else
        UncleIsBlack := false;
end;
 
function UncleIsRed(p: NodePtr): boolean;               {technically I check}
begin                                       {if both parent and uncle are red}
    if (p^.prev^.prev^.left = nil) or (p^.prev^.prev^.right = nil) then begin
        UncleIsRed := false;
        exit;
    end;
    if (p^.prev^.prev^.left^.color = red) and
        (p^.prev^.prev^.right^.color = red)
    then begin
        UncleIsRed := true
    end else
        UncleIsRed := false;
end;
 
function DadIsRed(p: NodePtr):boolean;
begin
    if p^.prev^.color = red then
        DadIsRed := true
    else
        DadIsRed := false
end;
 
function DadIsBlack(p: NodePtr):boolean;
begin
    if p^.prev^.color = black then
        DadIsBlack := true
    else
        DadIsBlack := false
end;
 
procedure SelfBalance(var p: NodePtr);
begin
    if (p^.prev = nil) or DadIsBlack(p) or (p^.color = black) then
        exit;
    if DadIsRed(p) then begin
        if UncleIsRed(p) then begin
            recolor(p);
            SelfBalance(p^.prev^.prev);
        end else
        if UncleIsBlack(p) and ImRightSon(p) and DadIsRightSon(p) then begin
            LeftRotationAndRecolor(p);
            SelfBalance(p^.prev);
        end else
        if UncleIsBlack(p) and ImLeftSon(p) and DadIsLeftSon(p) then begin
            RightRotationAndRecolor(p);
            SelfBalance(p^.prev);
        end else
        if UncleIsBlack(p) and ImRightSon(p) and DadIsLeftSon(p) then begin
            LeftRotation(p);
            RightRotationAndRecolor(p^.left);
            SelfBalance(p);
        end;
    end;
end;
 
procedure FindNode(
    n: integer; var p, previous: NodePtr; var position: NodePosition
);
begin
    if (p = nil) or (p^.value = n) then begin
        position := @p;
        exit;
    end;
    previous := p;
    if n < p^.value then
        FindNode(n, p^.left, previous, position)
    else
        FindNode(n, p^.right, previous, position);
end;
 
procedure AddNode(var p: NodePtr; var height: word);
var
    n: integer;
    previous: NodePtr = nil;
    position: NodePosition = nil;
begin
    read(n);
    FindNode(n, p, previous, position);
    if position^ <> nil then
        writeln('The node ', n, ' already exists')
    else begin
        new(position^);
        position^^.value := n;
        position^^.right := nil;
        position^^.left := nil;
        position^^.prev := previous;
        if position^^.prev <> nil then begin
            position^^.color := red;
            SelfBalance(position^);
            position := CurrentRootIs(position^);       {check if root changed}
            p := position^;                             {and set new root}
        end else
            position^^.color := black;
        height := TreeHeight(p);
    end;
end;
 
procedure PrintColor(p: NodePtr);
begin
    if p^.color = black then
        write(',blk(')
    else
        write(',red(');
end;
 
procedure PrintTreeLevel(p: NodePtr; height, CurrentHeight: word);
begin
    if p = nil then
        exit;
    if height = CurrentHeight then begin
        write(p^.value);
        PrintColor(p);
        if p^.prev = nil then
            write(' ) ')
        else
            write(p^.prev^.value, ') ');
    end else begin
        PrintTreeLevel(p^.left, height, CurrentHeight + 1);
        PrintTreeLevel(p^.right, height, CurrentHeight + 1);
    end;
end;
 
procedure PrintTree(root: NodePtr; height: word);
var
    i: word;
begin
    for i := 1 to height do begin
        PrintTreeLevel(root, i, 1);
        writeln;
    end;
end;
 
var
    root: NodePtr = nil;
    height: word = 0;
    c: char;
begin
    while true do begin
        while not SeekEoln do begin
            AddNode(root, height);
        end;
        readln;
        writeln;
        PrintTree(root, height);
        writeln('current tree height is ', height);
        write('Continue input? y/n ');
        readln(c);
        if c <> 'y' then
            halt;
    end;
end.