Delphi - string tree

string tree usage

VAR 
 ST:TStringTree;
 Code:integer;
 s:shortstring;

ST:=TStringTree.create;
ST.lowercase:=true;	// converts all new strings to lowercase
code:=1;
ST.addstring('Symbol1',code);
code:=2;
ST.addstring('Symbol2',code);

if ST.findstring('Symbol3',code) then { code holds the assigned number }
else { string not there }

the code

unit StringTree;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  stdctrls;

type
 CodeType=integer;

 TCharObj =class(TObject)
  terminal:boolean;
  ch:char;
  code:CodeType;
  prev,next:TCharObj;
  up,dn:TCharObj;
  constructor create(c:char);
  destructor destroyall;
 end;
 
  TStringTree = class(TObject)
  private
    { Private declarations }
   fhead:TCharObj;
   fsize:integer;
   fcase:boolean;
  protected
    { Protected declarations }
   procedure appendstring(s:shortstring;from:byte;var at:TCharObj;z:CodeType; mode:byte);
   function insertstring(s:shortstring;from:byte;var at:TCharObj;var z:CodeType):boolean;
   function _findstring(s:shortstring;from:byte;var at:TCharObj;var z:CodeType):boolean;
  public
    { Public declarations }
   constructor create;
   destructor destroy;
   function addstring(s:shortstring;var z:CodeType):boolean;  // true if added, false if there+code
   function findstring(s:shortstring;var z:Codetype):boolean; // true if found, returns code
  published
    { Published declarations }
   property size:integer read fsize;
   property lowercase:boolean read fcase write fcase; 
   property head:TCharObj read fhead;
  end;

procedure Register;

implementation

procedure lowercasestring(var s:shortstring);
var i:integer;
begin
 for i:=1 to length(s) do begin 
  if (s[i]>='A')and (s[i]<='Z') then s[i]:=chr(ord(s[i])+$20);
  end;
end;

//..................................................
constructor TCharObj.create(c:char);
begin
 inherited create;
 terminal:=false;
 ch:=c;
 code:=0;
 next:=nil;prev:=nil;
 up:=nil;dn:=nil;
end;
destructor TCharObj.destroyall;
begin
 if next<>nil then next.destroyall;
 if dn<>nil then dn.destroyall;
 inherited destroy;
end;
//..................................................
constructor TStringTree.create;
begin
 inherited create;
 fhead:=nil;
 fsize:=0;
 fcase:=false;
end;

destructor TStringTree.destroy;
var p:TCharobj;
begin
 if fhead<>nil then fhead.destroyall;
 inherited destroy;
end;

// mode 0 - new, 1 - next, 2 - up, 3 - down
procedure TStringTree.appendstring(s:shortstring;from:byte;var at:TCharObj;z:CodeType; mode:byte);
var p,v:TCharObj;
 i:integer;
begin
 v:=at;
 for i:=from to length(s) do begin
  p:=TCharObj.create(s[i]);
  if (i=from) then begin // the first of these
   case mode of
    0: at:=p;     // head
    1: begin at.next:=p; p.prev:=at; end;  // next
    2: begin 
        p.dn:=at; p.up:=at.up; if p.up<>nil then p.up.dn:=p; // up
        p.prev:=at.prev; if p.up=nil then begin
         if p.prev<>nil then p.prev.next:=p
         else fhead:=p; 
         end;
        at.up:=p;
       end;
    3: begin 
        p.dn:=at.dn; p.up:=at; if p.dn<>nil then p.dn.up:=p; // down
        p.prev:=at.prev;
        at.dn:=p;
       end;
    end; //case         
   end 
  else begin
   v.next:=p;
   p.prev:=v;
   end;
  v:=p;
  inc(fSize);
  end;
 p.terminal:=true;
 p.code:=z;
end;

function TStringTree.insertstring(s:shortstring;from:byte;var at:TCharObj;var z:CodeType):boolean;
var v,l,p:TCharObj;
 found:boolean;
begin
 if at=nil then begin  // just append the linear rest
  appendstring(s,from,at,z,0);
  result:=true;
  end
 else begin // there is a next
  found:=false; v:=at; l:=v;
  repeat
   if (ord(v.ch)nil) then begin // there is a next letter
     l:=v; v:=v.dn;
     end
    else begin // there is no next letter
     appendstring(s,from,v,z,3);
     found:=true;
     result:=true;
     end;
    end
   else begin // pos reached
    if (ord(v.ch)=ord(s[from])) then begin  // pos found
     if (from < length(s)) then 
      result:=insertstring(s,from+1,v.next,z)
     else begin
      if v.terminal then begin // symbol exists
       result:=false;
       z:=v.code;
       end
      else begin // char exists, but not the symbol
        v.terminal:=true;
        v.code:=z;
        result:=true;
       end;
      end;
     found:=true;
     end
    else begin  // bigger insert before
     appendstring(s,from,v,z,2);
     result:=true;
     found:=true;
     end;
    end;
  until found;
  end;
end;

function TStringTree._findstring(s:shortstring;from:byte;var at:TCharObj;var z:CodeType):boolean;
var v,l,p:TCharObj;
 found:boolean;
begin
 if at=nil then begin  // just append the linear rest
  result:=false;
  end
 else begin // there is a next
  found:=false; v:=at; l:=v;
  repeat
   if (ord(v.ch)nil) then begin // there is a next letter
     l:=v; v:=v.dn;
     end
    else begin // there is no next letter
     result:=false;
     found:=true;
     end;
    end
   else begin // pos reached
    if (ord(v.ch)=ord(s[from])) then begin  // pos found
     if (from < length(s)) then result:=_findstring(s,from+1,v.next,z)
     else begin
      if v.terminal then begin
       result:=true;
       z:=v.code;
       end
      else result:=false;
      end;
     found:=true;
     end
    else begin  // bigger insert before
     result:=false;
     found:=true;
     end;
    end;
  until found;
  end;
end;

function TStringTree.addstring(s:shortstring;var z:CodeType):boolean;
var u:shortstring;
begin
 u:=s;
 if fcase then lowercasestring(u);
 result:=insertstring(u,1,fhead,z);
end;

function TStringTree.findstring(s:shortstring;var z:Codetype):boolean; // true if found, returns code
var u:shortstring;
begin
 u:=s;
 if fcase then lowercasestring(u);
 result:=_findstring(u,1,fhead,z);
end;

procedure Register;
begin
 // RegisterComponents('Samples', [TStringTree]);
end;

end.