第6回 B木から要素を削除する方法を学ぼう

unit BTree;

interface

uses
  SysUtils, Classes, StrUtils, Dialogs;

type

  TKeyVal = record
    Key: Integer;
    Val: Integer;
  end;

  TBTreeNode = class(TObject)
  private
    FCount: Integer;
    FMaxKeys: integer;
    FKeys: array of Integer;
    FVals: array of integer;
    FChildNodes: array of TBTreeNode;
    FOrder: integer;
    FIsRoot: Boolean;
    function GetChildNodes(Index: Integer): TBtreeNode;
    function GetKeys(Index: Integer): Integer;
    function GetVals(Index: Integer): Integer;
    procedure InsertKeyVal(Index: Integer; const new_key, new_val: Integer);
    procedure InsertChildNode(Index: Integer; const new_node: TBtreeNode);
    procedure SetChildNodes(Index: Integer; const Value: TBtreeNode);
    procedure SetKeys(Index: Integer; const Value: Integer);
    procedure SetVals(Index: Integer; const Value: Integer);
    function IsLeaf:Boolean;
    procedure SetIsRoot(const Value: Boolean);
  protected
    procedure DumpNodes(var S : String; depth : Integer);
    function InternalAdd(new_key, new_val:Integer; var new_node:TBtreeNode;var return_key, return_val:Integer):boolean;
    function InternalDel(del_key:Integer; var new_root:TBTreeNode):boolean;
    procedure GetRightMostinTree(var right_key, right_val : Integer);
    procedure GetLeftMostInNode(var left_key, left_val : Integer; var return_node:TBTReeNode);
    procedure GetRightMostInNode(var right_key, right_val : Integer; var return_node:TBTReeNode);
    procedure SetCount(Value : Integer);
  public
    constructor Create(Order:Integer);
    destructor  Destroy;override;
    property Order    : Integer read FOrder;
    property MaxKeys  : Integer read FMaxKeys;
    property Keys[Index:Integer]:Integer read GetKeys write SetKeys;
    property Vals[Index:Integer]:Integer read GetVals write SetVals;
    property ChildNodes[Index:Integer]:TBtreeNode read GetChildNodes write SetChildNodes;
    property Count:Integer read FCount write SetCount;
    property IsRoot:Boolean read FIsRoot write SetIsRoot;
  end;

  TBtree = class(TObject)
  private
    FCount : Integer;
    FOrder : Integer;
    FRoot  : TBTreeNode;
  protected
  public
    function DumpNodes:String;
    procedure Add(new_key, new_val:Integer);
    procedure Del(del_key:Integer);
    constructor Create(Order:Integer);
    destructor Destroy;override;
    property Order : Integer read FOrder;
    property Count : Integer read FCount;
  end;

implementation

{ TBTreeNode }

//節点のコンストラクタ
constructor TBTreeNode.Create(Order:Integer);
begin
  inherited Create;

  FCount    := 0;
  FOrder    := Order;
  FMaxKeys  := Order * 2;
  FIsRoot   := False;

  //実装を簡易にするため、0..2*K、つまり要素数2K+1の配列とする
  SetLength(FKeys, FMaxKeys + 1);
  SetLength(FVals, FMaxKeys + 1);

  //子節点へのリンクは2K+1個を使用するので、余分を1つとる
  //こうしておくと、分割の際に、K+1個ずつ分配しやすい
  SetLength(FChildNodes, FMaxKeys + 2);

end;

//節点のデストラクタ
//子節点があれば、それを解放する
destructor TBTreeNode.Destroy;
var
  idx : Integer;
begin
  //ルートが不要になった際に連鎖解放されないための仕掛け
  if (IsRoot = False) then
  begin
    for idx := 0 to FCount do
    begin
      if (FChildNodes[idx] <> nil) then FChildNodes[idx].Free;
    end;
  end;

  inherited;
end;

//節点の状態を返す処理
procedure TBTreeNode.DumpNodes(var S: String; depth: Integer);
var
  idx : Integer;
begin
  //節点が葉かどうかで処理を分ける
  if (IsLeaf = True) then
  //葉である場合
  begin
    for idx := 0 to FCount -1 do
    begin
      S := S + DupeString('  ', depth) + IntToStr(FKeys[idx]) + #13#10;
    end;
  end else
  //葉でない場合
  begin
    for idx := 0 to FCount -1 do
    begin
      FChildNodes[idx].DumpNodes(S, depth + 1);
      S := S + DupeString('  ', depth) + IntToStr(FKeys[idx]) + #13#10;
    end;
    FChildNodes[FCount].DumpNodes(S, depth + 1);
  end;
end;

function TBTreeNode.GetChildNodes(Index: Integer): TBtreeNode;
begin
  result := FChildNodes[Index];
end;

function TBTreeNode.GetKeys(Index: Integer): Integer;
begin
  result := FKeys[Index];
end;

//節点内の一番左端の値を返して削除する
procedure TBTreeNode.GetLeftMostInNode(var left_key, left_val: Integer;
  var return_node: TBTReeNode);
var
  idx : Integer;
begin

  //左端の値を戻り値に入れる
  left_key := FKeys[0];
  left_val := FVals[0];
  return_node := FChildNodes[0];

  //左へ詰める
  for idx := 0 to FCount - 1 do
  begin
    FKeys[idx] := FKeys[idx+1];
    FVals[idx] := FVals[idx+1];
  end;
  for idx  := 0 to FCount do
    FChildNodes[idx] := FChildNodes[idx+1];

  //クリーンアップ
  FChildNodes[FCount+1] := nil;
  Dec(FCount);
end;

//節点内の一番右端の値を返して削除する
procedure TBTreeNode.GetRightMostInNode(var right_key, right_val: Integer;
  var return_node: TBTReeNode);
begin

  //右端の値を戻り値に入れる
  right_key := FKeys[FCount - 1];
  right_val := FVals[FCount - 1];
  return_node := FChildNodes[FCount];

  //クリーンアップ
  FChildNodes[FCount] := nil;
  Dec(FCount);
end;

//部分木の中の最右端を返す
procedure TBTreeNode.GetRightMostinTree(var right_key, right_val: Integer);
begin
  if (FChildNodes[FCount] <> nil) then
  begin
    FChildNodes[FCount].GetRightMostinTree(right_key, right_val);
  end else
  begin
    right_key := FKeys[FCount - 1];
    right_val := FVals[FCount - 1];
    //ここではキーを削除しない
  end;
end;

function TBTreeNode.GetVals(Index: Integer): Integer;
begin
  result := FVals[Index];
end;

//節点への要素の追加
function TBTreeNode.InternalAdd(new_key, new_val:Integer; var new_node:TBtreeNode;var return_key, return_val:Integer):boolean;
var
  idx : Integer;
begin
  //新しいキーがバケット内のどの位置にあたるかをチェックしておく
  //idxには、new_key の位置が入る
  if (FCount = 0) then
    idx := 0
  else
    for idx := 0 to FCount - 1 do
      if (FKeys[idx] > new_key) then break;

  //葉の場合とそうでない場合で処理を分ける
  if (IsLeaf = True) then
  //節点が葉である場合
  begin
    //新しいキーより大きい値の左側へ新しいキーを挿入する
    //余分を1つ取ってあるので必ず挿入できる
    InsertKeyVal(idx, new_key, new_val);

    //すでにバケットがいっぱいかどうかで処理を分ける
    if (FCount > FMaxkeys) then
    begin
      //バケットの分割が発生する
      result := True;

      //分割用の新しい節点を生成
      new_node := TBTreeNode.Create(FOrder);

      //新節点へ値を移動する
      for idx := 0 to FOrder - 1 do
      begin
        //中央値はK番目にあたるので、K+1番目から上を新節点へ移動
        //(K-1)+(K+1)=2K
        new_node.Keys[idx] := FKeys[idx + FOrder + 1];
        new_node.Vals[idx] := FVals[idx + FOrder + 1];
      end;

      //親節点へ返すキーと値の組をセット
      return_key := FKeys[FOrder];
      return_val := FVals[FOrder];

      //分割によって、CountはKになる
      FCount := FOrder;
      new_node.SetCount(FOrder);

      exit;
    end else
    begin
      //分割は発生していない
      result := False;
      exit;
    end;
  end else
  //節点が葉で無い場合の処理
  begin
    //新しいキーより大きいキーの左側の子節点へキーを追加する
    //idxには、キーの位置が入っているので、同じ位置のFChildNodesがそれにあたる

    //追加した結果分割が発生したかどうかで処理を分ける
    if (FChildNodes[idx].InternalAdd(new_key, new_val, new_node, return_key, return_val) = True) then
    //分割が発生した
    begin
      //分割の結果返されたキーを挿入するのも、idxの位置になるので
      //これを再度チェックする必要はない

      //新しいキーより大きい値の左側へ新しいキーを挿入する
      //余分を1つ取ってあるので必ず挿入できる
      InsertKeyVal(idx, return_key, return_val);

      //新しい子節点を追加する
      //位置としては、右側の子節点となるので、idx+1の位置へ挿入する
      InsertChildNode(idx + 1, new_node);

      //すでにバケットがいっぱいかどうかで処理を分ける
      if (FCount > FMaxkeys) then
      begin
        //バケットの分割が発生する
        result := True;

        //分割用の新しい節点を生成
        new_node := TBTreeNode.Create(FOrder);

        //新節点へ値を移動する
        for idx := 0 to FOrder - 1 do
        begin
          //中央値はK番目にあたるので、K+1番目から上を新節点へ移動
          //0+K+1=K+1 〜 (K-1)+(K+1)=2K を移動する
          new_node.Keys[idx] := FKeys[idx + FOrder + 1];
          new_node.Vals[idx] := FVals[idx + FOrder + 1];

          //子節点へのリンクも同様に移動し、移動元をnilで埋める
          new_node.ChildNodes[idx] := FChildNodes[idx + FOrder + 1];
          FChildNodes[idx + FOrder + 1] := nil;
        end;

        //子節点へのリンクは、一番右側がはみ出すのでこれを移動する
        new_node.ChildNodes[FOrder] := FChildNodes[FMaxKeys + 1];
        FChildNodes[FMaxKeys + 1] := nil;

        //親節点へ返すキーと値の組をセット
        return_key := FKeys[FOrder];
        return_val := FVals[FOrder];

        //分割によって、CountはKになる
        FCount := FOrder;
        new_node.SetCount(FOrder);

        exit;

      end else
      //分割は発生していない
      begin
        result := False;
        exit;
      end;
    end else
    //分割が発生していない
    begin
      result := False;
      exit;
    end;
  end;
end;

//節点からの要素の削除
function TBTreeNode.InternalDel(del_key: Integer; var new_root:TBTreeNode): boolean;
var
  idx, Match       : Integer;
  IsMatch, IsShort : Boolean;
  key, val         : Integer;
  new_node, return_node  : TBTreeNode;
  return_key, return_val : Integer;
begin
  result := False;

  //削除するキーがバケット内のどの位置にあたるかをチェックしておく
  //マッチするキーがあればフラグを立てる
  //idxには、マッチした位置または子節点へ下がる位置が入る
  IsMatch := False;
  Match   := FCount;
  for idx := 0 to FCount - 1 do
  begin
    if (FKeys[idx] = del_key) then
    begin
      IsMatch := True;
      Match   := idx;
      break;
    end;
    if (FKeys[idx] > del_key) then
    begin
      IsMatch := False;
      Match   := idx;
      break;
    end;
  end;
  //削除キーがバケット内の要素のどれよりも大きい場合
  //マッチせずに、初期値のままとなる


  //葉の場合とそうでない場合で処理を分ける
  if (IsLeaf = True) then
  //節点が葉である場合
  begin
    //マッチするキーがあるので、それを削除する
    if (IsMatch = True) then
    begin
      //該当するキーを削除して左へ寄せる
      //マッチを無視して、マッチから右を左へ寄せれば良い
      for idx := Match to FCount - 1 do
      begin
        FKeys[idx] := FKeys[idx + 1];
        FVals[idx] := FVals[idx + 1];
      end;
      FKeys[FCount] := 0;
      FVals[FCount] := 0;
      Dec(FCount);

      //削除によって節点の要素がK個を割った場合
      //親の節点に要素を1つ要求する
      if (FCount < FOrder) then result := True;

    end else
    //マッチするキーがないのでエラーを返す
    begin
      Exception.CreateFmt('Not Find %d in the tree.', [del_key]);
    end;
  end else
  //節点が葉でない場合の処理
  begin
    if (IsMatch = True) then
    begin
      //該当するキーを削除して、左部分木の右端で置き換える
      //結果がTrueの場合には、
      FChildNodes[Match].GetRightMostInTree(key, val);
      FKeys[Match] := key;
      FVals[Match] := val;

      //もらったキーを左部分木から削除する
      //複数同じキーがあるのであれば、どれが削除されても結果は変わらない
      IsShort := FChildNodes[Match].InternalDel(key, new_root);

    end else
    //マッチするキーが無いので、子の節点へ削除キーを渡す
    begin
      //削除の結果、バケットの要素が不足しているかどうかがIsShortに入る
      IsShort := FChildNodes[Match].InternalDel(del_key, new_root);

    end;

    //子節点での削除の結果、要素が足りないといわれたので
    //右側の節点の要素をもらいに行く
    //MatchがCount-1である場合は左側からもらう、それ以外は右側から
    if (IsShort = True) then
    begin
      //MatchがCountである場合は左側を残し、それ以外は右側を残す
      //つまり右端を例外視する
      if (Match < FCount) then
      //この場合は、右側を残す
      begin
        //右側の子節点の要素がぎりぎりの場合はマージする
        if (FChildNodes[Match+1].Count = FOrder) then
        begin
          //右側の子節点の要素を右寄せする
          for idx := FOrder - 1 downto 0 do
          begin
            FChildNodes[Match+1].Keys[idx+FOrder] := FChildNodes[Match+1].Keys[idx];
            FChildNodes[Match+1].Vals[idx+FOrder] := FChildNodes[Match+1].Vals[idx];
          end;
          for idx := FOrder downto 0 do
            FChildNodes[Match+1].ChildNodes[idx+FOrder] := FChildNodes[Match+1].ChildNodes[idx];

          //左側の子節点の残りの要素を右側の子節点へ移動
          for idx := 0 to FChildNodes[Match].Count - 1 do
          begin
            FChildNodes[Match+1].Keys[idx] := FChildNodes[Match].Keys[idx];
            FChildNodes[Match+1].Vals[idx] := FChildNodes[Match].Vals[idx];
          end;
          for idx := 0 to FChildNodes[Match].Count do
            FChildNodes[Match+1].ChildNodes[idx] := FChildNodes[Match].ChildNodes[idx];

          //マッチしているキーを右側の子節点の空いているFOrder-1へ移す
          FChildNodes[Match+1].Keys[FOrder-1] := FKeys[Match];
          FChildNodes[Match+1].Vals[FOrder-1] := FVals[Match];

          //最終的に右側の子節点は満杯となる
          FChildNodes[Match+1].Count := FMaxKeys;

          //自節点内で譲渡した要素の分を左に詰める
          for idx := Match to FCount - 1 do
          begin
            FKeys[idx] := FKeys[idx+1];
            FVals[idx] := FVals[idx+1];
          end;
          for idx := Match to FCount do
            FChildNodes[idx] := FChildNodes[idx+1];

          //要素が1つ減る

          Dec(FCount);

          //結果としてバランス条件が崩れた場合、親へ波及する
          if (FCount < FOrder) then result := True;

          //ルートの場合はどんどん要素が減ってなくなる場合がある
          if (FIsRoot = True) and (FCount = 0) then
          begin
            new_root := FChildNodes[0];
            new_root.Count := FMaxKeys;
            new_root.IsRoot := True;
          end;
        end else
        //右側の子節点から要素をもらえる場合
        //MatchがCountより小さい場合は右側からもらう
        begin
          //右側の子節点の左端の要素をもらう
          FChildNodes[Match+1].GetLeftMostInNode(key, val, return_node);

          //左側の子節点の右端へ自分のマッチした要素を追加する
          FChildNodes[Match].Keys[FChildNodes[Match].count] := FKeys[Match];
          FChildNodes[Match].Vals[FChildNodes[Match].count] := FVals[Match];
          FChildNodes[Match].ChildNodes[FChildNodes[Match].count + 1] := return_node;
          FChildNodes[Match].Count := FChildNodes[Match].Count + 1;

          //自分のマッチした要素を右側の子節点から返った値で置き換える
          FKeys[Match] := key;
          FVals[Match] := val;

        end;
      end else
      //Match=Countの場合
      begin
        //左側の子節点の要素がぎりぎりの場合はマージする
        if (FChildNodes[Match-1].Count = FOrder) then
        begin

          //右側の子節点の残りの要素を左側の子節点へ移動
          for idx := 0 to FChildNodes[Match].Count - 1 do
          begin
            FChildNodes[Match-1].Keys[FOrder+idx+1] := FChildNodes[Match].Keys[idx];
            FChildNodes[Match-1].Vals[FOrder+idx+1] := FChildNodes[Match].Vals[idx];
          end;
          for idx := 0 to FChildNodes[Match].Count do
            FChildNodes[Match-1].ChildNodes[FOrder+idx+1] := FChildNodes[Match].ChildNodes[idx];

          //マッチしているキーを左側の子節点の右端へ移す
          FChildNodes[Match-1].Keys[FOrder] := FKeys[Match-1];
          FChildNodes[Match-1].Vals[FOrder] := FVals[Match-1];

          //最終的に右側の子節点は満杯となる
          FChildNodes[Match-1].Count := FMaxKeys;

          //自節点内で譲渡した要素の分を左に詰める
          for idx := Match to FCount - 1 do
          begin
            FKeys[idx] := FKeys[idx+1];
            FVals[idx] := FVals[idx+1];
          end;
          for idx := Match to FCount do
            FChildNodes[idx] := FChildNodes[idx+1];

          //要素が1つ減る
          Dec(FCount);

          //結果としてバランス条件が崩れた場合、親へ波及する
          if (FCount < FOrder) then result := True;

          //ルートの場合はどんどん要素が減ってなくなる場合がある
          if (FIsRoot = True) and (FCount = 0) then
          begin
            new_root := FChildNodes[Match-1];
            new_root.Count := FMaxKeys;
            new_root.IsRoot := True;
          end;
        end else
        //左側の子節点から要素をもらえる場合
        //MatchがCountである場合は左側からもらう
        begin
          //左側の子節点の右端の要素をもらう
          FChildNodes[Match-1].GetRightMostInNode(key, val, return_node);

          //右側の子節点の0位置へ自分のマッチした要素を追加する
          for idx := FChildNodes[Match].Count - 1 downto 0 do
          begin
            FChildNodes[Match].Keys[idx+1]:=FChildNodes[Match].Keys[idx];
            FChildNodes[Match].Vals[idx+1]:=FChildNodes[Match].Vals[idx];
          end;
          for idx := FChildNodes[Match].Count downto 0 do
            FChildNodes[Match].ChildNodes[idx+1]:=FChildNodes[Match].ChildNodes[idx];

          FChildNodes[Match].Keys[0] := FKeys[Match-1];
          FChildNodes[Match].Vals[0] := FVals[Match-1];
          FChildNodes[Match].ChildNodes[0] := return_node;
          FChildNodes[Match].Count := FChildNodes[Match].Count + 1;

          //自分のマッチした要素を右側の子節点から返った値で置き換える
          FKeys[Match-1] := key;
          FVals[Match-1] := val;

        end;
      end;
    end;
  end;
end;

function TBTreeNode.IsLeaf: Boolean;
begin
  result := (FChildNodes[0] = nil);
end;

procedure TBTreeNode.SetChildNodes(Index: Integer; const Value: TBtreeNode);
begin
  FChildNodes[index] := Value;
end;

procedure TBTreeNode.SetCount(Value: Integer);
begin
  FCount := Value;
end;

procedure TBTreeNode.SetIsRoot(const Value: Boolean);
begin
  FIsRoot := Value;
end;

procedure TBTreeNode.SetKeys(Index: Integer; const Value: Integer);
begin
  FKeys[Index] := Value;
end;

//Indexを指定した位置に、ChildNodeを挿入する
procedure TBTreeNode.InsertChildNode(Index: Integer;
  const new_node: TBtreeNode);
var
  idx : Integer;
begin
  //追加するキーのために場所を確保する
  for idx := FCount + 1 downto index + 1 do
  begin
    FChildNodes[idx] := FChildNodes[idx - 1];
  end;

  FChildNodes[index] := new_node;


end;

//Indexを指定した位置に、キー＝Valueを挿入する
procedure TBTreeNode.InsertKeyVal(Index: Integer; const new_key, new_val: Integer);
var
  idx : Integer;
begin

  //追加するキーのために場所を確保する
  for idx := FCount downto index + 1 do
  begin
    FKeys[idx] := FKeys[idx - 1];
    FVals[idx] := FVals[idx - 1];
  end;

  FKeys[index] := new_key;
  FVals[index] := new_val;

  Inc(FCount);
end;

procedure TBTreeNode.SetVals(Index: Integer; const Value: Integer);
begin
  FVals[Index] := Value;
end;

{ TBtree }

procedure TBtree.Add(new_key, new_val: Integer);
var
  created_node, old_root : TBTreeNode;
  return_key, return_val : Integer;
begin
  //ルートに対して新しいキーを追加した結果、ルートが分割されるかどうかで処理を分ける
  if(FRoot.InternalAdd(new_key, new_val, created_node, return_key, return_val)=True) then
  begin
    old_root := FRoot;
    old_root.IsRoot := False;

    FRoot := TBTreeNode.Create(FOrder);
    FRoot.IsRoot := True;

    FRoot.Keys[0] := return_key;
    FRoot.Vals[0] := return_val;
    FRoot.ChildNodes[0] := old_root;
    FRoot.ChildNodes[1] := created_node;
    FRoot.Count := 1;
  end;
end;

//B木のコンストラクタ
constructor TBtree.Create(Order: Integer);
begin
  inherited Create;

  FOrder := Order;
  FRoot  := TBtreeNode.Create(Order);
  FRoot.IsRoot := True;
end;

//ツリーから要素を削除する
procedure TBtree.Del(del_key: Integer);
var
  idx, Match : Integer;
  new_root   : TBTreeNode;
begin
  //ルートに対してキーの削除を指示
  //FOrderを割るだけなら捨て置くが、要素が0になった場合
  //子節点をマージして新しいルートにする
  new_root := nil;
  if(FRoot.InternalDel(del_key, new_root) = True) then
  begin
    if (new_root <> nil) then
    begin
      FRoot.Free;
      FRoot := new_root;
    end;
  end;
end;

//B木のデストラクタ
destructor TBtree.Destroy;
begin
  //ルートが不要になった際に連鎖解放されないための仕掛け
  FRoot.IsRoot := False;
  FRoot.Free;

  inherited;
end;

//ツリーの内部状態を返す
function TBtree.DumpNodes: String;
begin
  FRoot.DumpNodes(Result, 0);
end;

end.