Quellcode-Bibliothek

^© Kompilation durch diese Firma

[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]

Datei: flg009.cob Sprache: Delphi

Original von: Natural^©

unit Natural;
//----------------------------------------------------------------------------
//
//1. Paranorm, Inspacenorm kann gelöscht werden??
//----------------------------------------------------------------------------
interface
uses
  GenDefs,OwnUtils,Editor,OptionClass,Memtree;
//----------------------------------------------------------------------------
//
//----------------------------------------------------------------------------
type
  Verb=(keine,mehrmals,dann,entweder,oder,aufrufen,ausgefuehrt,berechnet,
    uebertraegt,vergleicht,entscheidet,selektiert,wenn,sucht,ruft,nicht,
    fortsetzung,loest);
  //----------------------------------------------------------------------------
  //
  //----------------------------------------------------------------------------
function memtreelong(T:TMemTree;lnr,col:integer):JString;
procedure displayres(var Root:TMemTree;var RE:TEde);
function Expression(var T:TMemTree):JString;
procedure StartRtfSource(Pwin:TEde);
implementation
uses
  Windows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,
  Dialogs,StdCtrls,Utilities,jpeg,ExtCtrls,Menus,ToolWin,Buttons,Math,
  StrUtils,ImgList,Printers,Chart,CheckLst,Clipbrd,ComCtrls,DateUtils;
const
  linelen=80;
  Paranorm='';
  Inspacenorm=' ';
  Variante: array [Verb] of JString=('keine','mehrmals wird','','entweder',
    'oder','aufrufen','ausgeführt','berechnet','überträgt','vergleicht',
    'entscheidet','selektiert','wenn ','sucht','ruft','nicht','','löst');
var
  lvl:integer;
  edt:^TRichEdit;
  lastfolgeline:integer;
  lastlevel:integer;
  lastphrase:Verb;
  streamatt:TMemoryStream;
  WinLnr:integer;
  TimeSet:TDateTime;
  Duration:Longint;
  Durmin:Longint;
  Durmax:Longint;
  Duravg:Longint;
  Durn:Longint;
  ThisBlock:JString;
  LastFunc:JString;
  ExprDepth:integer;
  Callsofexpr:integer;
//-----------------------------------------------------------------
//
//Stats Dur
//
//----------------------------------------------------------------
function Incr(var counter:integer):integer;
begin
  counter:=counter+1;
  result:=Counter;
end;
//-----------------------------------------------------------------
//
//Stats Dur
//
//----------------------------------------------------------------
procedure StartDur();
begin
  TimeSet:=Now;
end;
//----------------------------------------------------------------
//
//End Stats Dur
//
//----------------------------------------------------------------
procedure EndDur();
begin
  Duration:=MilliSecondsBetween(Now,TimeSet);
  if Duration>Durmax then
    Durmax:=Duration;
  if Duration<Durmin then
    Durmin:=Duration;
  Duravg:=(Duravg*Durn+Duration)div(Durn+1);
  Durn:=Durn+1;
end;
//----------------------------------------------------------------
//
//Start rtf
//
//----------------------------------------------------------------
procedure StartRtfSource(Pwin:TEde);
var
  S:JString;
  i:integer;
begin
  edt.Clear;
  edt.lines.Clear;
  edt.ReadOnly:=false;
  edt.PlainText:=false;
  streamatt:=TMemoryStream.Create;
  streamatt.Position:=0;
  S:=Pwin.RtfHeader;
  for i:=1 to Length(S) do
    streamatt.WriteBuffer(S[i],1);
end;
//----------------------------------------------------------------
//
//Close rtf
//
//----------------------------------------------------------------
procedure CloseRtfSource;
begin
  edt.lines.Clear;
  streamatt.WriteBuffer(AnsiString(' }'),2);
  streamatt.Position:=0;
  edt.lines.LoadFromStream(streamatt);
  edt.ReadOnly:=true;
  streamatt.Free;
end;
//----------------------------------------------------------------
//
//Large Font
//
//----------------------------------------------------------------
function Large:JString;
begin
  Large:=SetSize+IntToStr(4*Opt.r.FontSize);
end;
//----------------------------------------------------------------
//
//Middle Font
//
//----------------------------------------------------------------
function Middle:JString;
begin
  Middle:=SetSize+IntToStr(3*Opt.r.FontSize);
end;
//----------------------------------------------------------------
//
//Normal Font
//
//----------------------------------------------------------------
function Normal:JString;
begin
  Normal:=SetSize+IntToStr(2*Opt.r.FontSize);
end;
//----------------------------------------------------------------
//
//Folge
//
//----------------------------------------------------------------
function folge(phrase:Verb):JString;
var
  r:JString;
begin
  if (lastphrase=phrase) then begin
    r:=SetColor+'7'+Variante[phrase]+SetNoColor;
    lastfolgeline:=WinLnr;
    lastphrase:=phrase;
  end
  else begin
    r:=SetColor+'7'+Variante[phrase]+SetNoColor;
    lastfolgeline:=WinLnr;
    lastphrase:=phrase;
  end;
  folge:=r
end;
//----------------------------------------------------------------
//
//POaragraph
//
//----------------------------------------------------------------
function Para:JString;
begin
  WinLnr:=WinLnr+1;
  Para:=RtfParagraph;
end;
//----------------------------------------------------------------
//
//test for duplicate paragraph
//
//----------------------------------------------------------------
function CheckPara(S:JString):JString;
begin
  //if S='' then Checkpara:=''
  //else if midstr(S,length(S)-3,4)=RtfParagraph then Checkpara:=S
  //else Checkpara:=S+Para;
  CheckPara:=S
end;
//----------------------------------------------------------------
//
//LLength
//
//----------------------------------------------------------------
function Restlength(S:JString):integer;
var
  p:integer;
begin
  p:=Pos(RtfParagraph,S);
  while p>0 do begin
    S:=MidStr(S,p+Length(RtfParagraph),Length(S)-p-Length(RtfParagraph));
    p:=Pos(RtfParagraph,S);
  end;
  Restlength:=Length(S)
end;
//----------------------------------------------------------------
//
//level indenting
//
//----------------------------------------------------------------
function level(T:JString):JString;
var
  i:integer;
  S:JString;
begin
  S:='';
  for i:=1 to lvl do
    S:=S+Inspacenorm;
  S:=S+T;
  level:=S;
end;
//----------------------------------------------------------------
//
//line in rtf
//
//----------------------------------------------------------------
procedure winlines(C:integer;S:AnsiString);
var
  ll:integer;
begin
  if S<>'' then begin
    if S[1] in ['0'..'9'] then
      S:=Inspacenorm+S;
    if C<>0 then
      S:=SetColor+IntToStr(C)+S;
    S:=level(S);
    if C<>0 then
      S:=S+SetNoColor;
    //attention for {}
    S:=StringReplace(S,'\{','{',[rfReplaceAll]);
    S:=StringReplace(S,'{',' \{',[rfReplaceAll]);
    S:=StringReplace(S,'\}','}',[rfReplaceAll]);
    S:=StringReplace(S,'}','\}',[rfReplaceAll]);
    ll:=Length(S);
    streamatt.WriteBuffer(S[1],ll);
  end;
  lastlevel:=lvl;
end;
//----------------------------------------------------------------
//
//Item format
//
//----------------------------------------------------------------
function item(C:integer;S:JString):JString;
var
  Erg:JString;
begin
  Erg:='';
  if S<>'' then begin
    if C<>0 then
      Erg:=SetColor+IntToStr(C);
    Erg:=Erg+S;
    if C<>0 then
      Erg:=Erg+SetNoColor;
  end;
  item:=Erg
end;
//----------------------------------------------------------------
//
//Script format
//
//----------------------------------------------------------------
function Script(S:JString):JString;
var
  Erg:JString;
begin
  Erg:='';
  if S<>'' then begin
    Erg:=Italic;
    Erg:=Erg+S;
    Erg:=Erg+ItalicOff;
  end;
  Script:=Erg
end;
//----------------------------------------------------------------
//
//look for a certain lnr
//
//----------------------------------------------------------------
function memtreelong(T:TMemTree;lnr,col:integer):JString;
var
  DB:JString;
begin
  if T=nil then
    memtreelong:=''
  else if T.Line=lnr then
    memtreelong:=T.LongText
  else begin
    DB:=memtreelong(T.Child,lnr,col);
    if DB='' then
      memtreelong:=memtreelong(T.Sibling,lnr,col)
    else
      memtreelong:=DB
  end
end;
//----------------------------------------------------------------
//
//Traverse
//
//----------------------------------------------------------------
procedure traverse(T:TMemTree);
var
  DB:JString;
begin
  if T<>nil then begin
    DB:=T.Text;
    winlines(5,IntToStr(T.level)+':'+DB+Para);
    if T.Child<>nil then begin
      lvl:=lvl+1;
      traverse(T.Child);
      lvl:=lvl-1
    end;
    traverse(T.Sibling);
  end;
end;
//----------------------------------------------------------------
//
//function ?
//
//----------------------------------------------------------------
function IsFunction(T:TMemTree):boolean;
begin
  if (T<>nil)and(T.Text=S_function) then
    IsFunction:=true
  else
    IsFunction:=false;
end;
//----------------------------------------------------------------
//
//call ?
//
//----------------------------------------------------------------
function IsCall(T:TMemTree):boolean;
begin
  if (T<>nil)and(Pos('$',T.Text)>=1)and(Pos('.',T.Text)>=1) then
    IsCall:=true
  else
    IsCall:=false;
end;
//----------------------------------------------------------------
//
//get temporyry parent
//
//----------------------------------------------------------------
function TempParent(T:TMemTree):JString;
var
  p:integer;
begin
  TempParent:='';
  if (T<>nil) then begin
    p:=Pos('$',T.Text);
    if p>2 then
      TempParent:=MidStr(T.Text,1,p-2);
  end;
end;
//----------------------------------------------------------------
//
//Block ?
//
//----------------------------------------------------------------
function IsBlock(T:TMemTree):boolean;
var pi:JString;
begin
  pi:=getpar(S_Typ,T.LongText);
  if (T<>nil)and(T.Text>'')and(pi=S_Block) then
    IsBlock:=true
  else
    IsBlock:=false;
end;
//----------------------------------------------------------------
//
//Or ?
//
//----------------------------------------------------------------
function IsIf(T:TMemTree):boolean;
begin
  if (T<>nil)and(T.Text=S_if) then
    IsIf:=true
  else
    IsIf:=false;
end;
//----------------------------------------------------------------
//
//Assign ?
//
//----------------------------------------------------------------
function IsAssign(T:TMemTree):boolean;
begin
  if (T<>nil)and(T.Text=S_assign) then
    IsAssign:=true
  else
    IsAssign:=false;
end;
//----------------------------------------------------------------
//
//logical cond ?
//
//----------------------------------------------------------------
function IsCondition(T:TMemTree):boolean;
begin
  if (T<>nil)and((T.Text=S_or)or(T.Text=S_and)or(T.Text=S_not)or(T.Text='0')or
      (T.Text='1')) then
    IsCondition:=true
  else
    IsCondition:=false;
end;
//----------------------------------------------------------------
//
//= ?
//
//----------------------------------------------------------------
function IsEqual(T:TMemTree):boolean;
begin
  if (T<>nil)and(T.Text=S_eq) then
    IsEqual:=true
  else
    IsEqual:=false;
end;
//----------------------------------------------------------------
//
//Compose ?
//
//----------------------------------------------------------------
function IsCompose(T:TMemTree):boolean;
begin
  if (T<>nil)and(T.Text=S_compose) then
    IsCompose:=true
  else
    IsCompose:=false;
end;
//----------------------------------------------------------------
//
//Or ?
//
//----------------------------------------------------------------
function IsOr(T:TMemTree):boolean;
begin
  if (T<>nil)and(T.Text=S_or) then
    IsOr:=true
  else
    IsOr:=false;
end;
//----------------------------------------------------------------
//
//Or ?
//
//----------------------------------------------------------------
function IsUnion(T:TMemTree):boolean;
begin
  if (T<>nil)and(T.Text=S_Union) then
    IsUnion:=true
  else
    IsUnion:=false;
end;
//----------------------------------------------------------------
//
//Expose ?
//
//----------------------------------------------------------------
function IsExpose(T:TMemTree):boolean;
begin
  if (T<>nil)and(T.Text=S_replicator) then
    IsExpose:=true
  else
    IsExpose:=false;
end;
//----------------------------------------------------------------
//
//Operator  of Expression
//
//----------------------------------------------------------------
function Oper(T:TMemTree):JString;
var
  FC:TMemTree;
  TL:JString;
begin
  TL:='';
  if T<>nil then begin
    ExprDepth:=ExprDepth+1;
    FC:=T.Child;
    if IsFunction(T) then begin //function
      TL:=LowerCase(FC.Text);
    end
    else begin //operator
      TL:=LowerCase(T.Text);
    end;
  end;
  Oper:=TL
end;
//----------------------------------------------------------------
//
//Operator  Priority
//
//----------------------------------------------------------------
function Prio(TL:JString):integer;
begin
  if (TL=S_max) then
    Prio:=10
  else if (TL=S_min) then
    Prio:=10
  else if (TL=S_extension) then
    Prio:=10
  else if (TL=S_mod) then
    Prio:=10
  else if (TL=S_sqrt) then
    Prio:=10
  else if (TL=S_abs) then
    Prio:=10
  else if (TL=S_log) then
    Prio:=10
  else if (TL=S_log10) then
    Prio:=10
  else if (TL=S_convert) then
    Prio:=10
  else if (TL=S_Sum) then
    Prio:=10
  else if (TL=S_Prod) then
    Prio:=10
  else if (TL=S_subscript) then
    Prio:=10
  else if (TL=S_substring) then
    Prio:=10
  else if (TL=S_interval) then
    Prio:=10
  else if (TL=S_Fak) then
    Prio:=9
  else if (TL=S_Star) then
    Prio:=9
  else if (TL=S_catenate) then
    Prio:=8
  else if (TL=S_power) then
    Prio:=8
  else if (TL=S_mult) then
    Prio:=7
  else if (TL=S_divnat) then
    Prio:=7
  else if (TL=S_divrat) then
    Prio:=7
  else if (TL=S_plus) then
    Prio:=6
  else if (TL=S_minus) then
    Prio:=6
  else if (TL=S_or) then
    Prio:=5
  else if (TL=S_and) then
    Prio:=4
  else if (TL=S_not) then
    Prio:=3
  else if (TL=S_ne) then
    Prio:=2
  else if (TL=S_ge) then
    Prio:=2
  else if (TL=S_gt) then
    Prio:=2
  else if (TL=S_lt) then
    Prio:=2
  else if (TL=S_le) then
    Prio:=2
  else if (TL=S_eq) then
    Prio:=2
  else
    Prio:=11;
end;
//----------------------------------------------------------------
//
//expression
//
//----------------------------------------------------------------
function Expression(var T:TMemTree):JString;
var
  FC,NC,TC,TCC,TCCE:TMemTree;//enr:integer;
  E,Comma,Repl,FCE,TL,FCL,PLI,LINT,RINT,INTVAR,TempNr:JString;
  //----------------------------------------------------------------
  //
  //Bracket
  //
  //----------------------------------------------------------------
  function Brexpression(T:TMemTree;TL:JString):JString;
  var
    E:JString;
  begin
    E:=Expression(T);
    if T=nil then
      result:=E
    else if Prio(Oper(T))<Prio(TL) then
      result:='('+E+')'
    else
      result:=E;
  end;
begin
  //enr:=incr(Callsofexpr);    //debuggvars
  E:='';
  if T<>nil then begin
    ExprDepth:=ExprDepth+1;
    FC:=T.Child;
    if IsFunction(T) then begin //function
      //------------------------------------------------------------------------
      //function call
      //------------------------------------------------------------------------
      if FC<>nil then
        NC:=FC.Sibling
      else
        NC:=nil;
      FCL:=LowerCase(FC.Text);
      if FC<>nil then
        NC:=FC.Sibling
      else
        NC:=nil;
      PLI:='';
      Comma:='';
      while NC<>nil do begin
        PLI:=PLI+Comma+Expression(NC);
        Comma:=',';
        NC:=NC.Sibling;
      end;
      if (FCL=S_max) then
        E:='max('+PLI+')'
      else if (FCL=S_min) then
        E:='min('+PLI+')'
      else if (FCL=S_extension) then
        E:='Extension('+PLI+')'
      else if (FCL=S_mod) then
        E:='mod('+PLI+')'
      else if (FCL=S_sqrt) then
        E:='sqrt('+PLI+')'
      else if (FCL=S_abs) then
        E:='||'+PLI+'||'
      else if (FCL=S_log) then
        E:='log('+PLI+')'
      else if (FCL=S_log10) then
        E:='log10('+PLI+')'
      else if (FCL=S_convert) then
        E:='conv('+PLI+')'
      else if (FCL=S_Sum)or(FCL=S_Prod) then begin
        Repl:=Summenzeichen;
        if FCL=S_Prod then
          Repl:=Produktzeichen;
        Repl:=Large+Repl+Normal;
        NC:=FC.Sibling;
        TC:=NC.Sibling;
        TCC:=TC.Sibling;
        TCCE:=TCC.Sibling;
        E:=Bold+Repl+'\{'+BoldOff+Expression(TC)+'<='+Expression(NC)
          +'<='+Expression(TCC);
        E:=E+Bold+'|'+BoldOff+Expression(TCCE);
        E:=E+Bold+'\}'+BoldOff;
      end
      else begin
        E:=FCL+'('+PLI+')';
      end;
    end
    else begin
      //------------------------------------------------------------------------
      //operator
      //------------------------------------------------------------------------
      TL:=LowerCase(T.Text);
      //catcher(enr=3);
      if (FC=nil) then begin //varname
        if TL[1]='$' then begin //special names
          TempNr:=MidStr(TL,2,Length(TL)-1);
          E:='i'+Subscript+TempNr+SubscriptOff;
        end
        else
          E:=TL
      end
      else if (TL=S_Fak) then begin
        E:=Brexpression(FC,TL);
        E:=E+'!'
      end
      else if (TL=S_Star) then begin
        E:=Brexpression(FC,TL);
        E:=E+'*'
      end
      else if (TL=S_not) then
        E:='not '+Brexpression(FC,TL)
      else begin
        //------------------------------------------------------------------------
        //multiadic
        //------------------------------------------------------------------------
        if FC<>nil then
          NC:=FC.Sibling
        else
          NC:=nil;
        if (TL=S_subscript) then
          E:=Brexpression(FC,TL)+'['+Expression(NC)+']'
        else if (TL=S_substring) then
          E:=Brexpression(FC,TL)+'[:'+Expression(NC)+':]'
        else if (TL=S_interval) then begin
          LINT:=Brexpression(FC,TL);
          RINT:=Brexpression(FC.Child,TL);
          INTVAR:=FC.Sibling.Text;
          NC:=FC.Sibling.Child;
          E:='['+LINT+'<='+INTVAR+'<='+RINT+':'+Expression(NC)+']'
        end
        else begin
          //------------------------------------------------------------------------
          //dyadic
          //------------------------------------------------------------------------
          //Catcher(Enr=4);
          FCE:=Brexpression(FC,TL);
          //if Restlength(FCE)>80 then
          //  FCE:=FCE+Paranorm+level(folge(fortsetzung));
          if (TL=S_and) then
            E:=FCE+S_and+Brexpression(NC,TL)
          else if (TL=S_or) then
            E:=FCE+S_or+Brexpression(NC,TL)
          else if (TL=S_lt) then
            E:=FCE+'<'+Brexpression(NC,TL)
          else if (TL=S_le) then
            E:=FCE+'<='+Brexpression(NC,TL)
          else if (TL=S_eq) then
            E:=FCE+'=='+Brexpression(NC,TL)
          else if (TL=S_ne) then
            E:=FCE+'<>'+Brexpression(NC,TL)
          else if (TL=S_ge) then
            E:=FCE+'>='+Brexpression(NC,TL)
          else if (TL=S_gt) then
            E:=FCE+'>'+Brexpression(NC,TL)
          else if (TL=S_plus) then
            E:=FCE+S_plus+Brexpression(NC,TL)
          else if (TL=S_catenate) then
            E:=FCE+S_catenate+Brexpression(NC,TL)
          else if (TL=S_minus) then
            E:=FCE+S_minus+Brexpression(NC,TL)
          else if (TL=S_mult) then begin
            if Pos(' ',FCE)>0 then
              FCE:=FCE;
            E:=FCE+S_mult+Brexpression(NC,TL)
          end
          else if (TL=S_divnat) then
            E:=FCE+S_divnat+Brexpression(NC,TL)
          else if (TL=S_divrat) then
            E:=FCE+S_divrat+Brexpression(NC,TL)
          else if (TL=S_power) then
            E:=FCE+S_power+Brexpression(NC,TL)
          else
            E:=T.Text;
        end;
      end;
    end;
    ExprDepth:=ExprDepth-1;
  end;
  Expression:=E
end;
//----------------------------------------------------------------
//
//list of exprs
//
//----------------------------------------------------------------
function explist(var T:TMemTree):JString;
var
  C:TMemTree;
  E:JString;
begin
  E:='';
  if T<>nil then begin
    E:=E+SetColor+'5'+T.Text+SetNoColor;
    C:=T.Sibling;
    While C<>nil do begin
      E:=E+Para+SetColor+'5'+level(C.Text)+SetNoColor;
      C:=C.Sibling;
    end;
  end;
  explist:=E;
end;
//----------------------------------------------------------------
//
//expr type
//
//----------------------------------------------------------------
function exptyp(T:TMemTree):Verb;
var
  FC,NC:TMemTree;
  E:Verb;
var
  TL:JString;
begin
  if T=nil then
    TL:=''
  else
    TL:=LowerCase(T.Text);
  E:=uebertraegt;
  if T<>nil then begin
    FC:=T.Child;
    if FC<>nil then
      NC:=FC.Sibling
    else
      NC:=nil;
    if (TL=S_or) then
      E:=entscheidet
    else if (TL=S_and) then
      E:=entscheidet
    else if (TL=S_not) then
      E:=entscheidet
    else if (TL=S_Fak) then
      E:=berechnet
    else if (TL=S_Star) then
      E:=uebertraegt
    else if (TL=S_lt) then
      E:=vergleicht
    else if (TL=S_le) then
      E:=vergleicht
    else if (TL=S_eq) then
      E:=vergleicht
    else if (TL=S_ne) then
      E:=vergleicht
    else if (TL=S_ge) then
      E:=vergleicht
    else if (TL=S_gt) then
      E:=vergleicht
    else if (TL=S_plus) then
      E:=berechnet
    else if (TL=S_minus) then
      E:=berechnet
    else if (TL=S_mult) then
      E:=berechnet
    else if (TL=S_divnat) then
      E:=berechnet
    else if (TL=S_divrat) then
      E:=berechnet
    else if (TL=S_power) then
      E:=berechnet
    else if (TL=S_subscript) then
      E:=selektiert
    else if (TL=S_substring) then
      E:=selektiert
    else if (TL=S_interval) then
      E:=selektiert
    else if (TL=S_max) then
      E:=sucht
    else if (TL=S_min) then
      E:=sucht
    else if (TL=S_convert) then
      E:=berechnet
    else if (TL=S_extension) then
      E:=loest
    else if (TL=S_mod) then
      E:=berechnet
    else if (TL=S_sqrt) then
      E:=berechnet
    else if (TL=S_abs) then
      E:=berechnet
    else if (TL=S_log) then
      E:=berechnet
    else if (TL=S_log10) then
      E:=berechnet
    else if (TL=S_function) then begin
      if (FC.Text=S_Sum) then
        E:=berechnet
      else if (FC.Text=S_Prod) then
        E:=berechnet
      else
        E:=ruft
    end
    else begin
      E:=exptyp(FC);
      if E=uebertraegt then
        E:=exptyp(NC);
    end;
  end;
  exptyp:=E
end;
//----------------------------------------------------------------
//
//Assigns = Block
//
//----------------------------------------------------------------
function Command(var N:TMemTree):JString;
var
  FC,NC:TMemTree;
  E,EF,B,Func:JString;
  V:Verb;
begin
  Command:='';
  if N<>nil then begin
    if N.Line=0 then
      N.Line:=WinLnr;
    E:='';
    if IsBlock(N) then begin
      ThisBlock:=N.Text;
      N:=N.Child;
      E:=CheckPara(E);
      LastFunc:=''
    end;
    FC:=N.Child;
    if IsUnion(N) then begin
      E:=E+Command(FC);
      NC:=FC.Sibling;
      E:=E+Command(NC);
    end
    else if IsIf(N) then begin
      E:=level(folge(wenn)+inspacenorm);
      lvl:=lvl+1;
      E:=CheckPara(E+Expression(FC)+inspacenorm+Para+inspacenorm);
      NC:=FC.Sibling;
      if NC<>nil then begin
        E:=E+Command(NC);
        while NC.Sibling<>nil do begin
          NC:=NC.Sibling;
          E:=E+Command(NC);
        end;
      end;
      E:=CheckPara(E);
      lvl:=lvl-1;
    end
    else if IsAssign(N) then begin
      NC:=FC.Sibling;
      if IsCall(FC) then begin
        Func:=TempParent(FC);
        EF:=Expression(NC);
        if Func=LastFunc then begin
          E:=E+' , '+EF;
        end
        else begin
          if LastFunc<>'' then
            E:=E+Paranorm;
          E:=E+level(Func+Inspacenorm+EF);
        end;
        LastFunc:=Func;
      end
      else begin
        if LastFunc<>'' then
          E:=E+Paranorm;
        V:=berechnet;
        E:=E+level(folge(V)+inspacenorm);
        B:=Expression(FC)+':='+Expression(NC);
        E:=CheckPara(E+Inspacenorm+B);
      end;
      E:=E+Para
    end;
    //else
    //error(100,'Block inkonsistent');
    Command:=E;
  end;
end;
//----------------------------------------------------------------
//
//interpret
//
//----------------------------------------------------------------
function interpret(var p:TMemTree):JString;
var
  FC,NC:TMemTree;
  LA,LB,LC,LD,Tx,Erg:JString;
begin
  Erg:='';
  if p<>nil then begin
    Tx:=p.Text;
    FC:=p.Child;
    if FC<>nil then
      NC:=FC.Sibling
    else
      NC:=nil;
    if IsBlock(p) then begin
      Erg:=Command(p);
      //Erg:=CheckPara(Erg);
    end
    else if IsExpose(p) then begin
      lvl:=lvl+1;
      LA:=interpret(FC);
      lvl:=lvl-1;
      if LA<>'' then begin
        Erg:=level(item(3,folge(mehrmals)))+Paranorm+LA;
        Erg:=Erg+level(item(3,folge(ausgefuehrt)));
      end;
    end
    else if IsCompose(p) then begin
      LA:=interpret(FC);
      LB:=interpret(NC);
      Erg:=Erg+CheckPara(LA)+LB;
    end
    else if IsOr(p) then begin
      LA:=level(item(3,folge(entweder)))+Para;
      lvl:=lvl+1;
      LB:=interpret(FC);
      lvl:=lvl-1;
      LC:=level(item(3,folge(oder)))+Para;
      lvl:=lvl+1;
      LD:=interpret(NC);
      lvl:=lvl-1;
      if LB<>'' then
        Erg:=LA+LB+LC+LD
      else
        Erg:=LD
    end;
  end;
  interpret:=Erg
end;
//----------------------------------------------------------------
//
//display res
//
//----------------------------------------------------------------
procedure displayres(var Root:TMemTree;var RE:TEde);
var
  Method,FileTree,Compl,Extree,IFTRee,TreeBug:TMemTree;
  SE,M,H,WL:JString;
  Debug:boolean;
begin
  //set address of richedit window
  Duration:=0;
  Durmax:=0;
  Durmin:=100000;
  Durn:=0;
  Duravg:=0;
  edt:=@RE;
  WinLnr:=0;
  Callsofexpr:=0;
  StartRtfSource(RE);
  WinLnr:=1;
  lastfolgeline:=-2;
  lastphrase:=keine;
  lvl:=0;
  lastlevel:=-1;
  Debug:=false;
  if Debug then begin
    winlines(0,Underline+'Baumnotation'+UnderLineOff+Para);
    traverse(Root);
  end;
  FileTree:=Root;
  Method:=FileTree.Child;
  while not Debug and (Method<>nil) do begin
    M:=Method.Text;
    Compl:=Method.Child;
    Method:=Method.Sibling;
    IFTRee:=Method.Child;
    Method:=Method.Sibling;
    if Method<>nil then begin
      Extree:=Method;
      TreeBug:=Method.Sibling;
      lvl:=1;
      ExprDepth:=0;
      H:=SetColor+'5'+M+SetNoColor;
      //Metainformation
      winlines(2,Normal+Underline+'Analyse von "'+H+'"'+UnderLineOff+Para);
      lvl:=2;
      winlines(2,Underline+'Komplexität'+UnderLineOff+Para);
      lvl:=3;
      winlines(0,Middle+Omega+Normal+'('+Expression(Compl)+')'+Para);
      //Schnittstellen
      lvl:=2;
      winlines(2,Normal+Underline+'Schnittstellen'+UnderLineOff+Para);
      lvl:=3;
      SE:=explist(IFTRee);
      if SE<>'' then
        winlines(0,trim(SE)+Para)
      else begin
        lvl:=2;
        winlines(0,level(folge(keine))+Para);
      end;
      //Seiteneffekte
      lvl:=2;
      winlines(2,Normal+Underline+'Seiteneffekte'+UnderLineOff+Para);
      lvl:=3;
      ThisBlock:='';
      LastFunc:='';
      SE:=interpret(Extree);
      //WL:=MidStr(SE,length(SE)-7,8);
      //rework {}
      if Pos('}',SE)>0 then
        SE:=SE+Inspacenorm+RtfParagraph;
      if SE<>'' then begin
        lvl:=0;
        winlines(0,SE)
      end
      else begin
        lvl:=2;
        winlines(0,level(folge(keine))+Para);
      end;
      if TreeBug<>nil then begin
        lvl:=2;
        winlines(2,Underline+'Probleme'+UnderLineOff+Para);
        lvl:=3;
        WL:=explist(TreeBug.Child);
        winlines(0,WL+Para);//nur für Debug
        winlines(0,Para);
        Method:=TreeBug.Sibling;//TreeBug.Sibling
      end
      else
        Method:=nil;
      lvl:=2;
    end;
  end;
  CloseRtfSource();
end;
//----------------------------------------------------------------
//
//Ende dieser Quelle
//
//----------------------------------------------------------------
end.

¤ Dauer der Verarbeitung: 0.29 Sekunden (vorverarbeitet) ¤

Download des Quellennavigators
Download des sprechenden Kalenders
in der Quellcodebibliothek suchen

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.