mmsearch.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: [phone]                   =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 20.01.1998 - 18:00:00 $                                      =}
{========================================================================}
unit MMSearch;

{$I COMPILER.INC}

interface

uses SysUtils;

type
   TCompareFunc = function(p1, p2: Pointer): integer;

function  bsearch(key, base: Pointer; nelem, width: integer; fcmp: TCompareFunc): Pointer;
function  lsearch(key, base: Pointer; var nelem: integer; width: integer; fcmp: TCompareFunc): Pointer;
function  lfind(key, base: Pointer; nelem, width: integer; fcmp: TCompareFunc): Pointer;
procedure qsort(pBase: Pointer; nElem, width: integer; fcmp: TCompareFunc);

implementation

var
   qWidth: integer;

(*======================================================================*)
(* bsearch - binary search                                              *)
(*======================================================================*)
function bsearch(key, base: Pointer; nelem, width: integer; fcmp: TCompareFunc): Pointer;
var
   kmin, probe: PChar;
   i, j: integer;

begin
   kmin := base;
   while (nelem > 0) do
   begin
      i := nelem shr 1;
      probe := kmin + i * width;
      j := fcmp(key,Probe);
      if (j = 0) then
      begin
         Result := Probe;
         exit;
      end
      else if (j < 0) then nelem := i
      else
      begin
         kmin := probe + width;
         nelem := nelem - i - 1;
      end;
   end;
   Result := nil;
end;

(*======================================================================*)
(* Exchange - exchanges two objects                                     *)
(*======================================================================*)
procedure Exchange(leftP, rightP: Pointer);
var
   i: integer;
   c: char;
   lp,rp: PChar;

begin
   lp := leftP;
   rp := rightP;

   for i := 0 to qWidth-1 do
   begin
      c := rp^;
      rp^ := lp^;
      inc(rp);
      lp^ := c;
      inc(lp);
   end;
end;

(*======================================================================*)
(* qsorthelp                                                            *)
(*======================================================================*)
procedure qsorthelp(pivotP: PChar; nElem: integer; fcmp: TCompareFunc);
label tailRecursion,qbreak;
var
   leftP, rightP, pivotEnd, pivotTemp, leftTemp: PChar;
   lNum, retval: integer;

begin
tailRecursion:
   if (nElem <= 2) then
   begin
      if (nElem = 2) then
      begin
         rightP := qWidth + pivotP;
         if Fcmp(pivotP, rightP) > 0 then Exchange (pivotP, rightP);
      end;
      exit;
   end;

   rightP := (nElem - 1) * qWidth + pivotP;
   leftP  := (nElem shr 1) * qWidth + pivotP;

   { sort the pivot, left, and right elements for "median of 3" }

   if Fcmp(leftP, rightP) > 0 then Exchange(leftP, rightP);
   if Fcmp(leftP, pivotP) > 0 then Exchange(leftP, pivotP)
   else if Fcmp(pivotP, rightP) > 0 then Exchange(pivotP, rightP);

   if (nElem = 3) then
   begin
      Exchange(pivotP, leftP);
      exit;
   end;

   { now for the classic Hoare algorithm }
   leftP := pivotP + qWidth;
   pivotEnd := leftP;

   repeat
        retval := Fcmp(leftP, pivotP);
        while (retval <= 0) do
        begin
           if (retval = 0) then
           begin
              Exchange(leftP, pivotEnd);
              inc(pivotEnd, qWidth);
           end;
           if (leftP < rightP) then inc(leftP, qWidth)
           else goto qBreak;
           retval := Fcmp(leftP, pivotP);
        end;

        while (leftP < rightP) do
        begin
           retval := Fcmp(pivotP, rightP);
           if (retval < 0) then dec(rightP, qWidth)
           else
           begin
              Exchange(leftP, rightP);
              if (retval <> 0) then
              begin
                 inc(leftP, qWidth);
                 dec(rightP, qWidth);
              end;
              break;
           end;
        end;
   until (leftP >= rightP);

qBreak:

   if Fcmp(leftP, pivotP) <= 0 then leftP := leftP + qWidth;

   leftTemp := leftP - qWidth;

    pivotTemp := pivotP;

    while (pivotTemp < pivotEnd) and (leftTemp >= pivotEnd) do
    begin
       Exchange(pivotTemp, leftTemp);
       inc(pivotTemp, qWidth);
       dec(leftTemp, qWidth);
    end;

    lNum := (leftP - pivotEnd) div qWidth;
    nElem := ((nElem * qWidth + pivotP) - leftP) div qWidth;

    { Sort smaller partition first to reduce stack usage }
    if (nElem < lNum) then
    begin
       qSortHelp(leftP, nElem, fcmp);
       nElem := lNum;
    end
    else
    begin
       qSortHelp(pivotP, lNum, fcmp);
       pivotP := leftP;
    end;

    goto tailRecursion;
end;

(*======================================================================*)
(* qsort - sorts using the quick sort routine                           *)
(*======================================================================*)
procedure qsort(pBase: Pointer; nElem, width: integer; fcmp: TCompareFunc);
begin
   qWidth := width;
   if (qWidth = 0) then exit;

   qsorthelp(pBase, nElem, fcmp);
end;

(*======================================================================*)
(* _lsearch - searches a table                                          *)
(*                                                                      *)
(* Description performs lfind or lsearch depending on the value of flag.*)
(*             If flag is 1 it updates the table if no match, if flag   *)
(*             is 0 it only searches.                                   *)
(*======================================================================*)
function _lsearch(key, Base: Pointer; var nelem: integer; width: integer;
                  fcmp: TCompareFunc; Flag: Boolean): Pointer;

var
   Wrk: integer;
   bse: PChar;

begin
   bse := PChar(Base);

   Wrk := nelem;
   while Wrk > 0  do
   begin
      if fcmp(key, bse) = 0 then
      begin
         Result := bse;
         exit;
      end;
      inc(bse, width);
      dec(Wrk);
   end;

   if Flag then
   begin
      inc(nelem);
      move(bse^, PChar(key)^, width);
   end
   else bse := nil;
   Result := bse;
end;

(*======================================================================*)
(* lsearch - searches and updates a table                               *)
(*                                                                      *)
(* Description lfind and lsearch search a table for information. Because*)
(*             these are linear searches, the table entries do not need *)
(*             to be sorted before a call to lfind or lsearch. If the   *)
(*             item that key  points to is not in the table, lsearch    *)
(*             appends that item to the table, but lfind does not.      *)
(*======================================================================*)
function lsearch(key, base: Pointer; var nelem: integer; width: integer;
                 fcmp: TCompareFunc): Pointer;
begin
   Result := _lsearch(key,base,nelem,width,fcmp,True);
end;

(*======================================================================*)
(* lfind - perform a linear search                                      *) 
(*======================================================================*)
function lfind(key, base: Pointer; nelem: integer; width: integer;
               fcmp: TCompareFunc): Pointer;
begin
   Result := _lsearch(key,base,nelem,width,fcmp,False);
end;

end.