Quelle MemTree.pas Sprache: Delphi

unit MemTree;
//----------------------------------------------------------------------------
//
//----------------------------------------------------------------------------
interface
uses
  //----------------------------------------------------------------------------
  //local
  //----------------------------------------------------------------------------
  GenDefs,OwnUtils,Utilities,
  //----------------------------------------------------------------------------
  //global
  //----------------------------------------------------------------------------
  ComCtrls,StrUtils,SysUtils;
//----------------------------------------------------------------------------
//
//----------------------------------------------------------------------------
type
  TMemTree= class(TObject)
    Text:JString;
    LongText:JString;
    Line:integer;
    Column:integer;
    Child:TMemTree;
    Sibling:TMemTree;
    Parent:TMemTree;
    Count:integer;
    Level:integer;
    constructor create(S:JString;l:integer);
    destructor Destroy;override;
    function addsibling(S:JString;l:integer):TMemTree;
    function addchild(S:JString;l:integer):TMemTree;
    procedure LoadTreeFromStream(TC:PAnsiChar);
  end;
implementation
//----------------------------------------------------------------
//TMemTree
//
//----------------------------------------------------------------
constructor TMemTree.create(S:JString;l:integer);
begin
  inherited create();
  Text:=Functor(S);
  LongText:=S;
  Line:=0;
  Column:=0;
  Parent:=nil;
  Child:=nil;
  Sibling:=nil;
  Count:=1;
  Level:=l;
end;
//----------------------------------------------------------------
//TMemTree
//
//----------------------------------------------------------------
destructor TMemTree.Destroy;
begin
  inherited Free;
end;
//----------------------------------------------------------------
//TMemTree
//addfirst
//----------------------------------------------------------------
function TMemTree.addchild(S:JString;l:integer):TMemTree;
var
  c:TMemTree;
begin
  c:=TMemTree.create(S,l);
  c.Parent:=self;
  c.Level:=l;
  if Child=nil then begin
    Child:=c;
  end
  else
    errorn(106,'fehlerhafte Baumstruktur');
  addchild:=c
end;
//----------------------------------------------------------------
//TMemTree
//addfirst
//----------------------------------------------------------------
function TMemTree.addsibling(S:JString;l:integer):TMemTree;
var
  c,te:TMemTree;
begin
  c:=TMemTree.create(S,l);
  c.Level:=l;
  if Sibling=nil then begin
    Sibling:=c;
  end
  else begin
    te:=self;
    while te.Sibling<>nil do
      te:=te.Sibling;
    te.Sibling:=c;
  end;
  addsibling:=c
end;
//----------------------------------------------------------------
//Load Tree from Stream/String
//if possible
//----------------------------------------------------------------
procedure TMemTree.LoadTreeFromStream(TC:PAnsiChar);
var
  stack: array [0..stackmax] of TMemTree;
  lev,lastlev,offs,next,Count,tptr:integer;
  //left, right, middle:integer; B:String;
  eofs:boolean;
  R,Fi:AnsiString;
  procedure ShortenString();
  const
    ll=24;
  var
    i,ri,n:integer;
    S:AnsiString;
  begin
    S:=MidStr(R,1,1);
    ri:=1;
    for i:=2 to length(R) do
      if MidStr(R,i,1)=S then
        ri:=i;
    if ri>ll then begin
      n:=ri-ll;
      R:=MidStr(R,1,ll)+' ... '+MidStr(R,n,length(R)-ri+2*ll);
    end
  end;
//get next record from memory stream
  function nextrec:AnsiString;
  var
    S:AnsiString;
  begin
    next:=offs;
    lastlev:=lev;
    lev:=0;
    S:='';
    while (TC[next]>chr(15))and(TC[next]<=chr(255)) do begin
      S:=S+TC[next];
      next:=next+1;
    end;
    eofs:=TC[next]=chr(0);
    offs:=next+1;
    Count:=Count+1;
    if (length(S)>1) then
      lev:=strtoint(getpar(S_Lev,S));
    nextrec:=S;
  end;
//start of loadfromstream
begin
  offs:=0;
  eofs:=false;
  tptr:=0;//Reset Stream
  Count:=0;
  lev:=0;
  lastlev:=0;//Reset Tree
  while not eofs do begin
    R:=nextrec;
    //if Pos('max3.5',R)>0 then
    //R:=R;
    if tptr>=stackmax then
      errorn(107,'Stackmax erreicht');
    if (MidStr(R,1,length(S_LNav))<>S_LNav)and
      (MidStr(R,1,length(S_LNav))<>S_LSem)and
      (MidStr(R,1,length(S_LNav))<>S_LExp)and(R<>'') then
      errorn(108,'Schnittstelle korrupt:'+R);
    if length(R)>KeyMax then begin
      R:=getattribute(S_Lab,R);
      errorn(134,'Attribut für IDE zu lang');
    end;
    if not eofs then begin
      Fi:=getpar(S_Fil,R);
      //check for error
      if Count=1 then begin
        stack[0]:=addchild(R,lev);
        tptr:=0;
        lastlev:=lev
      end
      else if lev>lastlev then begin
        stack[tptr+1]:=stack[tptr].addchild(R,lev);
        tptr:=tptr+1;
        lastlev:=lev
      end
      else if lev=lastlev then begin
        stack[tptr]:=stack[tptr].addsibling(R,lev);
      end
      else if lev<lastlev then begin
        while (tptr>0)and(stack[tptr].Level>lev) do begin
          tptr:=tptr-1
        end;
        if stack[tptr].Level=lev then
          stack[tptr]:=stack[tptr].addsibling(R,lev);
        //else                          errorn(109,'falsche Baumstruktur');
        lastlev:=lev
      end
    end
  end;
end;
end.

quality97%

¤ Dauer der Verarbeitung: 0.13 Sekunden (vorverarbeitet) ¤

Wurzel

Suchen

Beweissystem der NASA

Beweissystem Isabelle

NIST Cobol Testsuite

Cephes Mathematical Library

Wiener Entwicklungsmethode

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.