{*********************************************************

 SlavaNap source code.

 Copyright 2001,2002 by SlavaNap development team
 Released under GNU General Public License

 Latest version is available at
 http://www.slavanap.org

**********************************************************

 Unit: SlavaStrings

 TStringList replacement

*********************************************************}
unit SlavaStrings;

interface

uses
  SysUtils, Classes2, Windows;

type
  PStringHashItem = ^TStringHashItem;
  TStringHashItem = Packed record
    Data: string;
    Next: PStringHashItem;
  end;
  TStringHash = Packed record
    Count: Integer;
    First: PStringHashItem;
  end;
  PStringHash = ^TStringHash;

function StrHash_Create: PStringHash;
procedure StrHash_Reset(var Hash: TStringHash);
function StrHash_Free(Hash: PStringHash): PStringHash;
procedure StrHash_Clear(var Hash: TStringHash);
function StrHash_Add(var Hash: TStringHash; Str: string): PStringHashItem;
function StrHash_AddEx(var Hash: TStringHash; Str: string): PStringHashItem;
function StrHash_Delete(var Hash: TStringHash; Str: string;
  Ignore_case: Boolean): Boolean;
procedure StrHash_DeleteFirst(var Hash: TStringHash);
function StrHash_FindString(Hash: TStringHash; Str: string;
  Ignore_case: Boolean): Boolean;
function StrHash_FindStringEx(Hash: TStringHash; Str: string;
  Ignore_case: Boolean): string;
function StrHash_LoadFromFile(var Hash: TStringHash; FileName: string): Boolean;
function StrHash_SaveToFile(Hash: TStringHash; FileName: string): Boolean;
function StrHash_SaveToFileSorted(Hash: TStringHash; FileName: string): Boolean;
procedure StrHash_CopyToStringList(Hash: TStringHash; List: TMyStringList);
procedure StrHash_Copy(Src: TStringHash; var Dst: TStringHash);
procedure StrHash_Reverse(var Hash: TStringHash);
function StrHash_Equal(H1, H2: TStringHash): Boolean;

implementation

uses
  STypes, Memory_Manager;

function StrHash_Create: PStringHash;
var
  Hash: PStringHash;
begin
  Hash := AllocMem(SizeOf(TStringHash));
  Hash^.First := nil;
  Hash^.Count := 0;
  Result := Hash;
end;

procedure StrHash_Reset(var Hash: TStringHash);
begin
  Hash.First := nil;
  Hash.Count := 0;
end;

function StrHash_Free(Hash: PStringHash): PStringHash;
begin
  Result := nil;
  if Hash = nil then Exit;
  StrHash_Clear(Hash^);
  Finalize(Hash^);
  FreeMem(Hash, SizeOf(TStringHash));
end;

procedure StrHash_Clear(var Hash: TStringHash);
var
  Item: PStringHashItem;
begin
  while Hash.First <> nil do
  begin
    Item := Hash.First;
    Hash.First := Item^.Next;
    Item^.Data := '';
    Finalize(Item^);
    FreeMem(Item, SizeOf(TStringHashItem));
  end;
  Hash.Count := 0;
end;

function StrHash_Add(var Hash: TStringHash; Str: string): PStringHashItem;
var
  Item: PStringHashItem;
begin
  Item := AllocMem(SizeOf(TStringHashItem));
  Pointer(Item^.Data) := nil;
  Item^.Data := Str;
  Item^.Next := Hash.First;
  Hash.First := Item;
  Inc(Hash.Count);
  Result := Item;
end;

function StrHash_AddEx(var Hash: TStringHash; Str: string): PStringHashItem;
var
  Item, Prev: PStringHashItem;
begin
  Item := AllocMem(SizeOf(TStringHashItem));
  Pointer(Item^.Data) := nil;
  Item^.Data := Str;
  Item^.Next := nil;
  Inc(Hash.Count);
  Result := Item;
  if Hash.First = nil then
    Hash.First := Item
  else
  begin
    Prev := Hash.First;
    while Prev^.Next <> nil do
      Prev := Prev^.Next;
    Prev^.Next := Item;
  end;
end;

function StrHash_Delete(var Hash: TStringHash; Str: string;
  Ignore_case: Boolean): Boolean;
var
  Prev, Item: PStringHashItem;
begin
  if Ignore_case then
    Str := AnsiLowerCase(Str);
  Prev := nil;
  Item := Hash.First;
  while Item <> nil do
  begin
    if (Ignore_case and (AnsiLowerCase(Item^.Data) = Str)) or ((Ignore_case =
      False) and (Item^.Data = Str)) then
    begin
      if Prev = nil then
        Hash.First := Item^.Next
      else
        Prev^.Next := Item^.Next;
      Item^.Data := '';
      Dec(Hash.Count);
      Finalize(Item^);
      FreeMem(Item, SizeOf(TStringHashItem));
      Result := True;
      Exit;
    end;
    Prev := Item;
    Item := Item^.Next;
  end;
  Result := False;
end;

procedure StrHash_DeleteFirst(var Hash: TStringHash);
var
  Item: PStringHashItem;
begin
  if Hash.First = nil then Exit;
  Item := Hash.First;
  Hash.First := Item^.Next;
  Dec(Hash.Count);
  Item^.Data := '';
  Finalize(Item^);
  FreeMem(Item, SizeOf(TStringHashItem));
end;

function StrHash_FindString(Hash: TStringHash; Str: string;
  Ignore_case: Boolean): Boolean;
var
  Item: PStringHashItem;
begin
  Item := Hash.First;
  if Ignore_case then
    Str := AnsiLowerCase(Str);
  while Item <> nil do
  begin
    if (Ignore_case and (AnsiLowerCase(Item^.Data) = Str)) or ((Ignore_case =
      False) and (Item^.Data = Str)) then
    begin
      Result := True;
      Exit;
    end;
    Item := Item^.Next;
  end;
  Result := False;
end;

function StrHash_FindStringEx(Hash: TStringHash; Str: string;
  Ignore_case: Boolean): string;
var
  Item: PStringHashItem;
begin
  Item := Hash.First;
  if Ignore_case then
    Str := AnsiLowerCase(Str);
  while Item <> nil do
  begin
    if (Ignore_case and (AnsiLowerCase(Item^.Data) = Str)) or ((Ignore_case =
      False) and (Item^.Data = Str)) then
    begin
      Result := Item^.Data;
      Exit;
    end;
    Item := Item^.Next;
  end;
  Result := '';
end;

function StrHash_LoadFromFile(var Hash: TStringHash; FileName: string): Boolean;
var
  List: TMyStringList;
  I: Integer;
begin
  StrHash_Clear(Hash);
  List := CreateStringList;
  try
    List.LoadFromFile(FileName);
  except
    FreeStringList(List);
    Result := False;
    Exit;
  end;
  for I := List.Count - 1 downto 0 do
    StrHash_Add(Hash, List.Strings[I]);
  FreeStringList(List);
  Result := True;
end;

function StrHash_SaveToFile(Hash: TStringHash; FileName: string): Boolean;
var
  List: TMyStringList;
begin
  List := CreateStringList;
  StrHash_CopyToStringList(Hash, List);
  Result := True;
  try
    List.SaveToFile(FileName);
  except
    Result := False;
  end;
  FreeStringList(List);
end;

function StrHash_SaveToFileSorted(Hash: TStringHash; FileName: string): Boolean;
var
  List: TMyStringList;
begin
  List := CreateStringList;
  StrHash_CopyToStringList(Hash, List);
  List.Sort;
  Result := True;
  try
    List.SaveToFile(FileName);
  except
    Result := False;
  end;
  FreeStringList(List);
end;

procedure StrHash_CopyToStringList(Hash: TStringHash; List: TMyStringList);
var
  Item: PStringHashItem;
begin
  List.Clear;
  Item := Hash.First;
  while Item <> nil do
  begin
    List.Add(Item^.Data);
    Item := Item^.Next;
  end;
end;

procedure StrHash_Reverse(var Hash: TStringHash);
var
  Item, Prev, Next: PStringHashItem;
begin
  if Hash.Count < 2 then Exit;
  Item := Hash.First;
  Prev := nil;
  while Item <> nil do
  begin
    Next := Item^.Next;
    Item^.Next := Prev;
    Prev := Item;
    Item := Next;
  end;
  Hash.First := Prev;
end;

procedure StrHash_Copy(Src: TStringHash; var Dst: TStringHash);
var
  F, T, Prev, Item: PStringHashItem;
begin
  StrHash_Clear(Dst);
  T := Src.First;
  Prev := nil;
  F := nil;
  Item := nil;
  while T <> nil do
  begin
    Item := StrHash_Add(Dst, T^.Data);
    if Prev = nil then
      F := Item
    else
      Prev^.Next := Item;
    Prev := Item;
    Item^.Next := nil;
    T := T^.Next;
  end;
  Dst.First := F;
end;

function StrHash_Equal(H1, H2: TStringHash): Boolean;
var
  P: PStringHashItem;
begin
  Result := False;
  if H1.Count <> H2.Count then Exit;
  P := H1.First;
  while P <> nil do
  begin
    if not StrHash_FindString(H2, P^.Data, False) then Exit;
    P := P^.Next;
  end;
  Result := True;
end;

end.
