membintree.pas

Delphi快速开发Web Server

{
  "Balanced Binary Search Tree" - Copyright (c) Danijel Tkalcec
  @exclude
}

unit memBinTree;

{$INCLUDE rtcDefs.inc}

interface

uses
  SysUtils, memPtrPool;

type
  itemType=longword;
  infoType=longword;

type
  pnode=^tnode;
  tnode=record
    key:itemType;
    info:infoType;
    b,b2:boolean;
    l,l2,r,r2:pnode;
    end;

  pnodearr=^tnodearr;
  tnodearr=array[0..(MaxLongInt div SizeOf(tnode))-1] of tnode;

  pParentList=^tParentList;
  tParentList=record
    NodeCount:byte;
    Nodes:array[0..100] of pnode;
    end;

  tBinTree=class(tObject)
  private
    myPoolSize:longint;
    myPools:array of pointer;
    pool:tPtrPool;
    cnt:cardinal;
    head,z:pnode;
    Parents:pParentList;
    procedure del_node(node:pnode);
    function new_node(const k:itemType; const i:infoType; const bi:boolean; const ll,rr:pnode):pnode;
  public
    constructor Create(size:integer);
    destructor Destroy; override;

    function empty:boolean;

    function Count:cardinal;

    procedure PoolSize(size:integer);

    function search(const v:itemType):infoType;      // Search for exact "v"
    function search_min(var i:infoType):itemType;
    function search_max(var i:infoType):itemType;
    function search_l(const v:itemType; var i:infoType):itemType;  // Search index lower than "v"
    function search_g(const v:itemType; var i:infoType):itemType;  // Search index higher than "v"
    function search_le(const v:itemType; var i:infoType):itemType;  // Search index for lower or equel to "v"
    function search_ge(const v:itemType; var i:infoType):itemType;  // Search index for higher or equal to "v"

    function isearch(const v:infoType):itemType;      // Search for info, exact "v"
    function isearch_min(var i:itemType):infoType;
    function isearch_max(var i:itemType):infoType;
    function isearch_l(const v:infoType; var i:itemType):infoType;  // Search for info lower than "v"
    function isearch_g(const v:infoType; var i:itemType):infoType;  // Search for info higher than "v"
    function isearch_le(const v:infoType; var i:itemType):infoType;  // Search for info lower or equel to "v"
    function isearch_ge(const v:infoType; var i:itemType):infoType;  // Search for info higher or equal to "v"

    procedure change(const v:itemType;const info:infoType);
    procedure insert(const v:itemType;const info:infoType);
    procedure remove(const v:itemType);
    procedure removeall;
  public
    property RootNode:pnode read head;
    property NilNode:pnode read z;
    end;

implementation

const
  itemMin=0;
  infoNil=0;

function tBinTree.Empty:boolean;
  begin
  Result:=head^.r=z;
  end;

function tBinTree.New_Node(const k:itemType; const i:infoType; const bi:boolean; const ll,rr:pnode):pnode;
  var
    a:longint;
    p:pnodearr;
  begin
  if myPoolSize>0 then
    begin
    Result:=pool.Get;
    if Result=nil then // Pool empty, need to resize pool and create a new list
      begin
      SetLength(myPools,Length(myPools)+1); // Resize myPools list
      GetMem(p,SizeOf(tnode)*myPoolSize); // Create new list
      myPools[length(myPools)-1]:=p; // store list
      pool.Size:=pool.Size+myPoolSize; // resize Pool
      for a:=0 to myPoolSize-1 do
        pool.Put(@p^[a]);
      Result:=pool.Get;
      end;
    end
  else
    GetMem(Result,SizeOf(tnode));
  FillChar(Result^,SizeOf(tnode),0);
  with Result^ do
    begin
    key:=k;
    info:=i;
    l:=ll; l2:=l;
    r:=rr; r2:=r;
    b:=bi; b2:=b;
    end;
  end;

procedure tBinTree.PoolSize(size:integer);
// PoolSize;
  begin
  if (pool.Size=0) or (myPoolSize>0) then
    myPoolSize:=size;
  end;

procedure tBinTree.Del_Node(node:pnode);
// del_node
  begin
  if myPoolSize>0 then
    pool.Put(node)
  else
    FreeMem(node);
  end;

constructor tBinTree.Create(size:integer);
// Create
  begin
  inherited Create;
  cnt:=0;
  myPoolSize:=size;
  pool:=tPtrPool.Create;
  z:=new_node(itemMin,infoNil,false,nil,nil);
  z^.l:=z; z^.r:=z;
  z^.l2:=z; z^.r2:=z;
  head:=new_node(itemMin,infoNil,false,z,z);
  head^.l2:=z; head^.r2:=z;
  New(Parents);
  end;

procedure tBinTree.Change(const v:itemType;const info:infoType);
// Change
  begin
  remove(v);
  insert(v,info);
  end;

procedure tBinTree.RemoveAll;
// RemoveAll
  procedure RemoveThis(var t:pnode);
    begin
    if t^.l<>z then RemoveThis(t^.l);
    if t^.r<>z then RemoveThis(t^.r);
    t^.info:=infoNil;
    t^.key:=itemMin;
    t^.r2:=z;
    t^.l2:=z;
    del_node(t);
    t:=z;
    end;
  begin
  if head^.r<>z then RemoveThis(head^.r);
  head^.info:=infoNil;
  head^.key:=itemMin;
  head^.r2:=z;
  head^.l2:=z;
  cnt:=0;
  end;

destructor tBinTree.Destroy;
// Destroy;
  var
    a:longint;
  begin
  RemoveAll;

  Dispose(Parents);

  if assigned(head) then
    begin
    head^.info:=infoNil;
    head^.key:=itemMin;
    del_node(head);
    end;

  if assigned(z) then
    begin
    z^.info:=infoNil;
    z^.key:=itemMin;
    del_node(z);
    end;

  for a:=0 to Length(myPools)-1 do
    FreeMem(myPools[a]);
  SetLength(myPools,0);
  pool.destroy;

  inherited;
  end;

function tBinTree.Search(const v:itemType):infoType;
// Search
  var
    x:pnode;
  begin
  x:=head^.r;
  while (x<>z) and (v<>x^.key) do
    if (v<x^.key) then x:=x^.l else x:=x^.r;
  Result:=x^.info;
  end;

function tBinTree.iSearch(const v:infoType):itemType;
// iSearch
  var
    x:pnode;
  begin
  x:=head^.r2;
  while (x<>z) and (v<>x^.info) do
    if (v<x^.info) then x:=x^.l2 else x:=x^.r2;
  Result:=x^.key;
  end;

function tBinTree.Search_Min(var i:infoType):itemType;
// Search_Min
  var
    x:pnode;
  begin
  x:=head^.r;
  if x<>z then
    begin
    while x^.l<>z do x:=x^.l;
    i:=x^.info;
    Result:=x^.key;
    end
  else
    begin
    i:=infoNil;
    Result:=itemMin;
    end;
  end;

function tBinTree.iSearch_Min(var i:itemType):infoType;
// iSearch_Min
  var
    x:pnode;
  begin
  x:=head^.r2;
  if x<>z then
    begin
    while (x^.l2<>z) do x:=x^.l2;
    i:=x^.key;
    Result:=x^.info;
    end
  else
    begin
    i:=itemMin;
    Result:=infoNil;
    end;
  end;

function tBinTree.Search_Max(var i:infoType):itemType;
// Search_Max
  var
    x:pnode;
  begin
  x:=head^.r;
  if x<>z then
    begin
    while x^.r<>z do x:=x^.r;
    i:=x^.info;
    Result:=x^.key;
    end
  else
    begin
    i:=infoNil;
    Result:=itemMin;
    end;
  end;

function tBinTree.iSearch_Max(var i:itemType):infoType;
// iSearch_Max
  var
    x:pnode;
  begin
  x:=head^.r2;
  if x<>z then
    begin
    while (x^.r2<>z) do x:=x^.r2;
    i:=x^.key;
    Result:=x^.info;
    end
  else
    begin
    i:=itemMin;
    Result:=infoNil;
    end;
  end;

function tBinTree.Search_L(const v:itemType; var i:infoType):itemType;
// Search_L
  var
    x,y:pnode;
  begin
  x:=head^.r; y:=head;
  while x<>z do
    begin
    if (x^.key<v) then
      begin
      y:=x;
      x:=x^.r;
      end
    else
      begin
      if (x^.key=v) and (x^.l<>z) then y:=x^.l;
      x:=x^.l;
      end;
    end;
  Result:=y^.key;
  i:=y^.info;
  end;

function tBinTree.iSearch_L(const v:infoType; var i:itemType):infoType;
// iSearch_L
  var
    x,y:pnode;
  begin
  x:=head^.r2; y:=head;
  while x<>z do
    begin
    if (x^.info<v) then
      begin
      y:=x;
      x:=x^.r2;
      end
    else
      begin
      if (x^.info=v) and (x^.l2<>z) then y:=x^.l2;
      x:=x^.l2;
      end;
    end;
  Result:=y^.info;
  i:=y^.key;
  end;

function tBinTree.Search_G(const v:itemType; var i:infoType):itemType;
// Search_G
  var
    x,y:pnode;
  begin
  x:=head^.r; y:=head;
  while x<>z do
    begin
    if (x^.key>v) then
      begin
      y:=x;
      x:=x^.l;
      end
    else
      begin
      if (x^.key=v) and (x^.r<>z) then y:=x^.r;
      x:=x^.r;
      end;
    end;
  Result:=y^.key;
  i:=y^.info;
  end;

function tBinTree.iSearch_G(const v:infoType; var i:itemType):infoType;
// iSearch_G
  var
    x,y:pnode;
  begin
  x:=head^.r2; y:=head;
  while x<>z do
    begin
    if (x^.info>v) then
      begin
      y:=x;
      x:=x^.l2;
      end
    else
      begin
      if (x^.info=v) and (x^.r2<>z) then y:=x^.r2;
      x:=x^.r2;
      end;
    end;
  Result:=y^.info;
  i:=y^.key;
  end;

function tBinTree.Search_LE(const v:itemType; var i:infoType):itemType;
// Search_LE
  var
    x,y:pnode;
  begin
  x:=head^.r; y:=head;
  while (x<>z) and (v<>x^.key) do
    begin
    if (x^.key<v) then
      begin
      y:=x;
      x:=x^.r;
      end
    else
      x:=x^.l;
    end;
  if x<>z then
    begin
    Result:=x^.key;
    i:=x^.info;
    end
  else
    begin
    Result:=y^.key;
    i:=y^.info;
    end;
  end;

function tBinTree.iSearch_LE(const v:infoType; var i:itemType):infoType;
// iSearch_LE
  var
    x,y:pnode;
  begin
  x:=head^.r2; y:=head;
  while (x<>z) and (v<>x^.info) do
    begin
    if (x^.info<v) then
      begin
      y:=x;
      x:=x^.r2;
      end
    else
      x:=x^.l2;
    end;
  if x<>z then
    begin
    Result:=x^.info;
    i:=x^.key;
    end
  else
    begin
    Result:=y^.info;
    i:=y^.key;
    end;
  end;

function tBinTree.Search_GE(const v:itemType; var i:infoType):itemType;
// Search_GE
  var
    x,y:pnode;
  begin
  x:=head^.r; y:=head;
  while (x<>z) and (v<>x^.key) do
    begin
    if (x^.key>v) then
      begin
      y:=x;
      x:=x^.l;
      end
    else
      x:=x^.r;
    end;
  if x<>z then
    begin
    Result:=x^.key;
    i:=x^.info;
    end
  else
    begin
    Result:=y^.key;
    i:=y^.info;
    end;
  end;

function tBinTree.iSearch_GE(const v:infoType; var i:itemType):infoType;
// iSearch_GE
  var
    x,y:pnode;
  begin
  x:=head^.r2; y:=head;
  while (x<>z) and (v<>x^.info) do
    begin
    if (x^.info>v) then
      begin
      y:=x;
      x:=x^.l2;
      end
    else
      x:=x^.r2;
    end;
  if x<>z then
    begin
    Result:=x^.info;
    i:=x^.key;
    end
  else
    begin
    Result:=y^.info;
    i:=y^.key;
    end;
  end;

procedure tBinTree.Insert(const v:itemType;const info:infoType);
// Insert
  var
    nx,x,p,g,gg,c:pnode;
    v2:infoType;
  procedure split;
    procedure p_rotate_g;
      begin
      c:=p;
      if (v<c^.key) then
        begin
        p:=c^.l;
        c^.l:=p^.r;
        p^.r:=c;