Лохонулся таки в InsertFixup.
В условии цикла нужно добавить еще одно ограничение (node.color = red):
PROCEDURE InsertFixup (tree: Tree; node: Node);
VAR
parent, uncle, grandad: Node;
BEGIN
node.color := red;
WHILE (node # tree.root) & (node.color = red) & (node.parent.color = red) DO
parent := node.parent;
grandad := parent.parent; (* grandad # NIL *)
grandad.color := red;
IF parent = grandad.left THEN
uncle := grandad.right;
IF (uncle # NIL) & (uncle.color = red) THEN
parent.color := black;
uncle.color := black;
node := grandad; (* move up *)
ELSE (* uncle.color = black *)
(* preparation for the right rotation *)
IF node = parent.right THEN (* parent.right.color = red *)
RotateLeft(tree, parent);
ELSE
node := parent; (* move up *)
END;
(* node = grandad.left *)
RotateRight(tree, grandad); (* node = grandad.parent *)
node.color := black;
END;
ELSE (* parent = grandad.right *)
uncle := grandad.left;
IF (uncle # NIL) & (uncle.color = red) THEN
parent.color := black;
uncle.color := black;
node := grandad; (* move up *)
ELSE (* uncle.color = black *)
(* preparation for the left rotation *)
IF node = parent.left THEN (* parent.left.color = red *)
RotateRight(tree, parent);
ELSE
node := parent; (* move up *)
END;
(* node = grandad.right *)
RotateLeft(tree, grandad); (* node = grandad.parent *)
node.color := black;
END;
END;
END;
tree.root.color := black;
END InsertFixup;
И еще одна вариация на тему (чтобы не менять условие цикла):
PROCEDURE InsertFixup (tree: Tree; node: Node);
VAR
parent, uncle, grandad: Node;
BEGIN
node.color := red;
WHILE (node # tree.root) & (node.parent.color = red) DO
parent := node.parent;
grandad := parent.parent; (* grandad # NIL *)
grandad.color := red;
IF parent = grandad.left THEN
uncle := grandad.right;
IF (uncle # NIL) & (uncle.color = red) THEN
parent.color := black;
uncle.color := black;
node := grandad; (* move up *)
(* node.color = red *)
ELSE (* uncle.color = black *)
(* preparation for the right rotation *)
IF node = parent.right THEN (* parent.right.color = red *)
RotateLeft(tree, parent); (* parent = node.left *)
node.color := black;
node := parent; (* move down *)
ELSE
parent.color := black;
END;
(* node.color = red *)
(* node.parent.color = black *)
RotateRight(tree, grandad);
END;
ELSE (* parent = grandad.right *)
uncle := grandad.left;
IF (uncle # NIL) & (uncle.color = red) THEN
parent.color := black;
uncle.color := black;
node := grandad; (* move up *)
(* node.color = red *)
ELSE (* uncle.color = black *)
(* preparation for the left rotation *)
IF node = parent.left THEN (* parent.left.color = red *)
RotateRight(tree, parent); (* parent = node.right *)
node.color := black;
node := parent; (* move down *)
ELSE
parent.color := black;
END;
(* node.color = red *)
(* node.parent.color = black *)
RotateLeft(tree, grandad);
END;
END;
END;
tree.root.color := black;
END InsertFixup;
ps Второй вариант ближе к исходному, чем первый.