Dream 45/Amiga_Dream_45.iso/Amiga/Magazine/Dossier-LaTeX/mathekne.lha/ableiten0.976.pasc

Text File | 1992-01-07 | 31KB | 1,404 lines

program AComp; (* Ableitungs-Compiler *)
(* von Carsten Hammer ; alle Rechte vorbehalten *)
(* Dies Programm soll die Ableitung einer Funktion berechnen *)
(* und den Rechenweg in ein Latex-File ausgeben (abl.tex).   *)
(* Die Vereinfachung hab ich noch nicht ganz durchschaut     *)
(* und kann sie deshalb noch nicht implementieren.           *)
(* Wer auch an sowas programmiert und Fragen hat oder mir    *)
(* weiterhelfen kann, der melde sich unter:                  *)
(* Carsten Hammer   *)
(* Schwindstr.7     *)
(* Bielefeld 1      *)
{$path "dh0:allerlei/include/"}
{$incl "req.lib","intuition.lib"}

type zeiger =^knoten;
     knoten = record
              a,b: zeiger;
              wert: string[999];
              end;
     Directoryname = String[DSize];
     Filename =String[Fchars];
     Pathname = String[162];
var wurzel: zeiger;
    eingabe,ausgabe,jj,hilf:string[999];
    j,k,gnot,schalter:integer;
    f:text;
    erlaeut:string;
    dir:Directoryname;
    Datei:Filename;
    Pfad:Pathname;
    Erfolg:long;
    ESS:p_ESStructure;
    FReq:Filerequester;


function klammerrⁿck(g:zeiger,o:integer):integer;
begin
repeat
o:=o-1;
if g^.wert[o]=")" then o:=klammerrⁿck(g,o)-1;
until g^.wert[o]="(";
klammerrⁿck:=o;
end;

function klammervor(g:zeiger,o:integer):integer;
begin
repeat
o:=o+1;
if g^.wert[o]="(" then o:=klammervor(g,o)+1;
until g^.wert[o]=")";
klammervor:=o;
end;

function xabh(p:zeiger):integer;
var x:integer;
begin
x:=0;
if p<>nil then
 begin
 if p^.a<>nil then x:=xabh(p^.a);
 if (p^.b<>nil)and(x=0) then x:=xabh(p^.b);
 if (pos("x",p^.wert)<>0)or(x<>0)then xabh:=1
 else xabh:=0;
 end
else
 begin
 xabh:=0;
 end;
end;

procedure _ausgabe(var q:zeiger);forward;

procedure ausgeben(var p:zeiger);
begin
j:=1;
k:=0;
ausgabe:="";
jj:="$$";
_ausgabe(p);
if erlaeut<>"" then jj:=jj+"\eqno \hbox{("+erlaeut+")}";
jj:=jj+"$$";
writeln(f,jj);
writeln(ausgabe);
end;

procedure zurⁿckformen(var p:zeiger);
begin
j:=1;
k:=0;
ausgabe:="";
jj:="$$";
_ausgabe(p);
jj:=jj+"$$";
end;


function prior(var h:zeiger,i:integer):integer;
var pstri:char;
        r:integer;
begin
if i<1 then i:=1;
pstri:=h^.wert[i];
case pstri of
"+":r:=1;
"-":r:=1;
"*":r:=2;
"/":r:=2;
"^":r:=3;
else
r:=4;
end;
prior:=r;
end;

procedure ⁿberprⁿfen(var e:zeiger);
var j,ia,iz:integer;
    s1,s2:string[999];
begin
ia:=0;
iz:=0;
j:=1;
if length(e^.wert)>1 then
 begin
 if e^.wert[1]="(" then ia:=1;
 if e^.wert[1]=")" then error("Klammer-zu am Anfang?");
 if e^.wert[1]=" " then e^.wert:=copy(e^.wert,2,length(e^.wert)-1);
 repeat
 j:=j+1;
 if (e^.wert[j]=" ")then e^.wert:=copy(e^.wert,1,j-1)+copy(e^.wert,j+1,length(e^.wert)-j);
 s1:=copy(e^.wert,1,j-2);
 if length(e^.wert)>j then s2:=copy(e^.wert,j+1,length(e^.wert)-j)
 else s2:="";
 (*writeln("s1,s2:",s1,":",s2,"!",ia,"k",iz);*)
 if (e^.wert[j-1]="-")and(e^.wert[j]="-")then e^.wert:=s1+"+"+s2 else
 if (e^.wert[j-1]="+")and(e^.wert[j]="+")then e^.wert:=s1+"+"+s2 else
 if (e^.wert[j-1]="+")and(e^.wert[j]="-")then e^.wert:=s1+"-"+s2 else
 if (e^.wert[j-1]="-")and(e^.wert[j]="+")then e^.wert:=s1+"-"+s2;
 if e^.wert[j]="(" then ia:=ia+1;
 if e^.wert[j]=")" then iz:=iz+1;
 if length(e^.wert)<(length(s1+s2)+2) then j:=j-1;
 if e^.wert[j]=" " then j:=j-1;
 until j=length(e^.wert);
 end
else
 begin
 if e^.wert=" " then error("Leerstring?");
 end;
if ia<>iz then error("Klammerfehler");
end;

function konst(var x:integer,var p:zeiger):integer;
var a:string;
begin
end;

procedure umformung(var quelle:zeiger);
var x,xx,t,auslass: integer;
    a,b:zeiger;
begin
if quelle^.wert="" then error("Fehlender Term oder fehlende Klammerung");
hilf:="";
x:=length(quelle^.wert)+1;
repeat
x:=x-1;
if quelle^.wert[x]=")" then
 begin
 hilf:=" ";
 x:=klammerrⁿck(quelle,x);
 end;
if x>1 then if (prior(quelle,x-1)=2)or(prior(quelle,x-1)=3) then
 begin
 x:=x-1;
 end;
until (prior(quelle,x)=1) or (x=1);
if (x=1)and(prior(quelle,x)=1) then
 begin
 if quelle^.wert[1]="+" then       (*      +ausdruck       *)
  begin
  quelle^.wert:=copy(quelle^.wert,2,length(quelle^.wert)-1);
  umformung(quelle);
  end
 else
  begin
  new(a);                          (*       -ausdruck        *)
  a^.wert:=copy(quelle^.wert,2,length(quelle^.wert)-1);
  a^.a:=nil;
  a^.b:=nil;
  quelle^.wert:=copy(quelle^.wert,1,1);
  quelle^.a:=a;
  quelle^.b:=nil;  (* redundant *)
  umformung(a);
  end;
 end
else
 begin
 if (prior(quelle,x)=1)and(prior(quelle,x-1)=4)and(x>1) then    (*   ausdr+ausdr  *)
  begin
  new(a);
  new(b);
  a^.wert:=copy(quelle^.wert,1,x-1);
  a^.a:=nil;
  a^.b:=nil;
  b^.wert:=copy(quelle^.wert,x+1,length(quelle^.wert)-x);
  b^.a:=nil;
  b^.b:=nil;
  quelle^.wert:=quelle^.wert[x];
  quelle^.a:=a;
  quelle^.b:=b;
  umformung(a);
  umformung(b);
  end
 else     (*    x=0    kein +\-im ausdruck  *)
  begin
  x:=length(quelle^.wert)+1;
  repeat
  x:=x-1;
  if quelle^.wert[x]=")" then x:=klammerrⁿck(quelle,x);
  until (prior(quelle,x)=2) or (x=1);
  if x>1 then   (*  ausdr*ausdr  *)
   begin
   new(a);
   new(b);
   a^.wert:=copy(quelle^.wert,1,x-1);
   a^.a:=nil;
   a^.b:=nil;
   b^.wert:=copy(quelle^.wert,x+1,length(quelle^.wert)-x);
   b^.a:=nil;
   b^.b:=nil;
   quelle^.wert:=quelle^.wert[x];
   quelle^.a:=a;
   quelle^.b:=b;
   umformung(a);
   umformung(b);
   end
  else
   begin
   x:=0;
   repeat
   x:=x+1;
   if quelle^.wert[x]="(" then x:=klammervor(quelle,x);
   until (quelle^.wert[x]="^") or (x=length(quelle^.wert));
   if x<length(quelle^.wert) then                     (*   ausdr^ausdr   *)
    begin
    new(a);
    new(b);
    a^.wert:=copy(quelle^.wert,1,x-1);
    a^.a:=nil;
    a^.b:=nil;
    b^.wert:=copy(quelle^.wert,x+1,length(quelle^.wert)-x);
    b^.a:=nil;
    b^.b:=nil;
    quelle^.wert:=quelle^.wert[x];
    quelle^.a:=a;
    quelle^.b:=b;
    umformung(a);
    umformung(b);
    end
   else
    begin
    if quelle^.wert<>"x" then
     begin
     x:=length(quelle^.wert)+1;         (* ausdruckxausdruck *)
     repeat
     x:=x-1;
     if quelle^.wert[x]=")" then x:=klammerrⁿck(quelle,x);
     until (quelle^.wert[x]="x") or (x=1);
     if ("x"=quelle^.wert[x])and(x<length(quelle^.wert)) then
(*  x*ausdruck oder ausdruckx*ausdruck          *)
      begin
      new(a);
      new(b);
      a^.wert:=copy(quelle^.wert,1,x);
      a^.a:=nil;
      a^.b:=nil;
      b^.wert:=copy(quelle^.wert,x+1,length(quelle^.wert)-x);
      b^.a:=nil;
      b^.b:=nil;
      quelle^.wert:="*";
      quelle^.a:=a;
      quelle^.b:=b;
      umformung(a);
      umformung(b);
      end
     else
      begin
      if (x=length(quelle^.wert))and(x>1) then            (* ausdruck*x       *)
       begin                    (*                  *)
       new(a);
       new(b);
       a^.wert:=copy(quelle^.wert,1,length(quelle^.wert)-1);
       a^.a:=nil;
       a^.b:=nil;
       b^.wert:="x";
       b^.a:=nil;
       b^.b:=nil;
       quelle^.wert:="*";
       quelle^.a:=a;
       quelle^.b:=b;
       umformung(a);
       end
      else
       begin
       hilf:="";            (*                hilf-Generierung     *)
       x:=length(quelle^.wert)+1; (* gleiche Anzahl Zeichen aber     *)
       repeat                     (* Klammerinnenterme fehlen       *)
       x:=x-1;
       if quelle^.wert[x]=")" then
        begin
        auslass:=x;
        x:=klammerrⁿck(quelle,x);
        repeat
        auslass:=auslass-1;
        hilf:=" "+hilf;
        until auslass=x;
   (*    if (quelle^.wert[x]="(")and(x>1) then x:=x-1;*)
        end;
       hilf:=quelle^.wert[x]+hilf;
       until x=1;
       (*writeln("quelle^.wert=",quelle^.wert);
       writeln("        hilf=",hilf);*)
       x:=0;
       xx:=0;
       if pos("e",hilf)>0 then
        begin
        x:=pos("e",hilf);
        xx:=1;
        end;
       if pos("pi",hilf)>0 then
        begin
        x:=pos("pi",hilf);
        xx:=2;
        end;
       if pos("nu",hilf)>0 then
        begin
        x:=pos("nu",hilf);
        xx:=2;
        end;
       if pos("mu",hilf)>0 then
        begin
        x:=pos("mu",hilf);
        xx:=2;
        end;
       if pos("eta",hilf)>0 then
        begin
        x:=pos("eta",hilf);
        xx:=3;
        end;
       if pos("rho",hilf)>0 then
        begin
        x:=pos("rho",hilf);
        xx:=3;
        end;
       if pos("tau",hilf)>0 then
        begin
        x:=pos("tau",hilf);
        xx:=3;
        end;
       if pos("phi",hilf)>0 then
        begin
        x:=pos("phi",hilf);
        xx:=3;
        end;
       if pos("psi",hilf)>0 then
        begin
        x:=pos("psi",hilf);
        xx:=3;
        end;
       if pos("beta",hilf)>0 then
        begin
        x:=pos("beta",hilf);
        xx:=4;
        end;
       if pos("alpha",hilf)>0 then
        begin
        x:=pos("alpha",hilf);
        xx:=5;
        end;
       if pos("gamma",hilf)>0 then
        begin
        x:=pos("gamma",hilf);
        xx:=5;
        end;
       if pos("delta",hilf)>0 then
        begin
        x:=pos("delta",hilf);
        xx:=5;
        end;
       if pos("theta",hilf)>0 then
        begin
        x:=pos("theta",hilf);
        xx:=5;
        end;
       if pos("kappa",hilf)>0 then
        begin
        x:=pos("kappa",hilf);
        xx:=5;
        end;
       if pos("sigma",hilf)>0 then
        begin
        x:=pos("sigma",hilf);
        xx:=5;
        end;
       if pos("epsilon",hilf)>0 then
        begin
        x:=pos("epsilon",hilf);
        xx:=7;
        end;
       (*writeln("an:",x,"lang",xx);*)
       if x>1 then
        begin
        new(a);
        new(b);
        a^.wert:=copy(quelle^.wert,1,x-1);
        a^.a:=nil;
        a^.b:=nil;
        b^.wert:=copy(quelle^.wert,x,length(quelle^.wert)-x+1);
        b^.a:=nil;
        b^.b:=nil;
        quelle^.wert:="*";
        quelle^.a:=a;
        quelle^.b:=b;
        (*writeln("ab",a^.wert,":",b^.wert);*)
        umformung(a);
        umformung(b);
        end;
       if (x=1)and(length(quelle^.wert)>xx) then
        begin
        new(a);
        new(b);
        a^.wert:=copy(quelle^.wert,1,xx);
        a^.a:=nil;
        a^.b:=nil;
        b^.wert:=copy(quelle^.wert,xx+1,length(quelle^.wert)-xx);
        b^.a:=nil;
        b^.b:=nil;
        quelle^.wert:="*";
        quelle^.a:=a;
        quelle^.b:=b;
        umformung(b);
        end;
       (*writeln("bis hier?",hilf);*)
       x:=0;
       xx:=0;
       if pos("ln",hilf)>0 then
        begin
        x:=pos("ln",hilf);
        xx:=2;
        end;
       if pos("sin",hilf)>0 then
        begin
        x:=pos("sin",hilf);
        xx:=3;
        end;
       if pos("cos",hilf)>0 then
        begin
        x:=pos("cos",hilf);
        xx:=3;
        end;
       if pos("tan",hilf)>0 then
        begin
        x:=pos("tan",hilf);
        xx:=3;
        end;
       if pos("sqr",hilf)>0 then
        begin
        x:=pos("sqr",hilf);
        xx:=3;
        end;
       if pos("tanh",hilf)>0 then
        begin
        x:=pos("tanh",hilf);
        xx:=4;
        end;
       if pos("arcsin",hilf)>0 then
        begin
        x:=pos("arcsin",hilf);
        xx:=6;
        end;
       if pos("arccos",hilf)>0 then
        begin
        x:=pos("arccos",hilf);
        xx:=6;
        end;
       if pos("arctan",hilf)>0 then
        begin
        x:=pos("arctan",hilf);
        xx:=6;
        end;
       if x>1 then
        begin
        new(a);
        new(b);
        a^.wert:=copy(quelle^.wert,1,x-1);
        a^.a:=nil;
        a^.b:=nil;
        b^.wert:=copy(quelle^.wert,x,length(quelle^.wert)-x+1)
        b^.a:=nil;
        b^.b:=nil;
        quelle^.wert:="*";
        quelle^.a:=a;
        quelle^.b:=b;
        (*writeln("jetzt umformung(a)",a^.wert,":",b^.wert);*)
        umformung(a);
        (*writeln("jetzt umformung(b)");*)
        umformung(b);
        end
       else
        begin
        (*write("marke1");*)
        t:=length(quelle^.wert);
        if x=1 then
         begin
         if quelle^.wert[x+xx]="(" then t:=klammervor(quelle,x+xx);
         if t=length(quelle^.wert) then
          begin
          new(a);
(*   funktion(ausdruck)       *)
          a^.wert:=copy(quelle^.wert,xx+1,length(quelle^.wert)-xx);
          a^.a:=nil;
          a^.b:=nil;
          quelle^.wert:=copy(quelle^.wert,1,xx);
          quelle^.a:=a;
          umformung(a);
          end
         else
          begin
          new(a);
          new(b);                            (* sonst funktion(ausdruck)ausdruck  *)
          a^.wert:=copy(quelle^.wert,1,t);
          a^.a:=nil;
          a^.b:=nil;
          b^.wert:=copy(quelle^.wert,t+1,length(quelle^.wert)-t);
          b^.a:=nil;
          b^.b:=nil;
          quelle^.wert:="*";
          quelle^.a:=a;
          quelle^.b:=b;
          umformung(a);
          umformung(b);
          end;
         end
        else
         begin
         (*write("marke2");*)
         if quelle^.wert[1]="(" then
          begin
          x:=klammervor(quelle,1);
          if x<length(quelle^.wert) then
           begin
           new(a);
           new(b);
           a^.wert:=copy(quelle^.wert,2,x-2);
           a^.a:=nil;
           a^.b:=nil;
           b^.wert:=copy(quelle^.wert,x+1,length(quelle^.wert)-x);
           b^.a:=nil;
           b^.b:=nil;
           quelle^.wert:="*";
           quelle^.a:=a;
           quelle^.b:=b;
           umformung(a);
           umformung(b);
           end
          else
           begin
           quelle^.wert:=copy(quelle^.wert,2,length(quelle^.wert)-2);
           umformung(quelle);
           end;
          end;
         end;
        end;
       end;
      end;
     end
    else
     begin
(* An dieser Stelle muss quelle^.wert ein "x" enthalten    *)
     end
    end;
   end;
  end;
 end;
end;


procedure _ausgabe;
var v:integer;
begin
j:=j+1;
if q^.wert="/" then jj:=jj+"{";
if (q^.a<>nil)and(q^.b<>nil)and((prior(q^.a,1)<prior(q,1))or((prior(q^.a,1)=3)and(prior(q,1)=3))or((q^.wert="^")and(q^.a^.wert="sqr")))then
begin
ausgabe:=ausgabe+"(";
if q^.wert<>"/"then jj:=jj+"{\left(";        (*   linke Klammer setzen    *)
k:=k+1;
end;
if (q^.a<>nil)and(q^.b<>nil) then _ausgabe(q^.a);
if (q^.a<>nil)and(q^.b<>nil)and((prior(q^.a,1)<prior(q,1))or((prior(q^.a,1)=3)and(prior(q,1)=3))or((q^.wert="^")and(q^.a^.wert="sqr")))then
begin
ausgabe:=ausgabe+")";
if q^.wert<>"/"then jj:=jj+"\right)}";       (*    rechte Klammer setzen  *)
k:=k+1;
end;
k:=k+length(q^.wert);
ausgabe:=ausgabe+q^.wert;
if "pi"=q^.wert then jj:=jj+"\pi"
else if "eta"=q^.wert then jj:=jj+"\eta"
else if "ln"=q^.wert then jj:=jj+"\ln"
else if "sin"=q^.wert then jj:=jj+"\sin"
else if "cos"=q^.wert then jj:=jj+"\cos"
else if "tan"=q^.wert then jj:=jj+"\tan"
else if "sqr"=q^.wert then jj:=jj+"\sqrt{"
else if "/"=q^.wert then jj:=jj+"\over "
else if "*"=q^.wert then jj:=jj+"\cdot "
else if "a"=q^.wert then jj:=jj
else if "arccos"=q^.wert then jj:=jj+"\arccos"
else if "arcsin"=q^.wert then jj:=jj+"\arcsin"
else if "arctan"=q^.wert then jj:=jj+"\arctan"
else if "tanh"=q^.wert then jj:=jj+"\tanh"
else if "rho"=q^.wert then jj:=jj+"\rho"
else if "tau"=q^.wert then jj:=jj+"\tau"
else if "phi"=q^.wert then jj:=jj+"\phi"
else if "psi"=q^.wert then jj:=jj+"\psi"
else if "epsilon"=q^.wert then jj:=jj+"\epsilon"
else if "gamma"=q^.wert then jj:=jj+"\gamma"
else if "delta"=q^.wert then jj:=jj+"\delta"
else if "beta"=q^.wert then jj:=jj+"\beta"
else if "theta"=q^.wert then jj:=jj+"\theta"
else if "lambda"=q^.wert then jj:=jj+"\lambda"
else if "kappa"=q^.wert then jj:=jj+"\kappa"
else if "sigma"=q^.wert then jj:=jj+"\sigma"
else if "omega"=q^.wert then jj:=jj+"\omega"
else if "alpha"=q^.wert then jj:=jj+"\alpha"
else jj:=jj+q^.wert;
if (q^.a<>nil)and(q^.b=nil)and(not((prior(q,1)=1)and(prior(q^.a,1)<>1)))then
begin
ausgabe:=ausgabe+"(";
if q^.wert<>"sqr" then jj:=jj+"{\left(";  (*  linke Klammer setzen  *)
k:=k+1;
end;
if (q^.a<>nil)and(q^.b=nil) then _ausgabe(q^.a);
if (q^.a<>nil)and(q^.b=nil)and(not((prior(q,1)=1)and(prior(q^.a,1)<>1)))then
begin
ausgabe:=ausgabe+")";
if q^.wert="sqr" then jj:=jj+"}";
if q^.wert<>"sqr" then jj:=jj+"\right)}"; (*  rechte Klammer setzen  *)
if q^.wert="a" then jj:=jj+"^\prime";
k:=k+1;
end;
if (q^.b<>nil) and (prior(q^.b,1)<prior(q,1))then
begin
ausgabe:=ausgabe+"(";
if q^.wert<>"/"then jj:=jj+"{\left(";
k:=k+1;
end;
if q^.b<>nil then _ausgabe(q^.b);
if (q^.b<>nil) and (prior(q^.b,1)<prior(q,1))then
begin
ausgabe:=ausgabe+")";
if q^.wert<>"/" then jj:=jj+"\right)}";
k:=k+1;
end;
if q^.wert="/" then jj:=jj+"}";
j:=j-1;
ausgabe[k+1]:=chr(0);
end;

function kopie(var i:zeiger):zeiger;
var j:zeiger
begin
new(j);
j^.wert:=i^.wert;
if i^.a<>nil then j^.a:=kopie(i^.a)
else j^.a:=nil;
if i^.b<>nil then j^.b:=kopie(i^.b)
else j^.b:=nil;
kopie:=j;
end;

procedure ableinf(var p:zeiger);
var h:zeiger;
begin
new(h);
h^.wert:=p^.wert;
p^.wert:="a";
h^.a:=p^.a;
h^.b:=p^.b;
p^.a:=h;
p^.b:=nil;
end;

procedure ablaust(var p:zeiger);
var h:zeiger;
begin
h:=p;
p:=p^.a;
dispose(h);
end;

procedure kill(var q:zeiger); (*  q darf nicht nil sein!!! *)
begin
(*writeln("kill:",q^.wert);*)
if q^.a<>nil then kill(q^.a);
if q^.b<>nil then kill(q^.b);
if (q^.a=nil)and(q^.b=nil) then
 begin
 dispose(q);
(* writeln("Erfolg!!");*)
 q:=nil;
 end;
end;

function vergleich(var q1,q2:zeiger):integer;
var h:integer;
begin
h:=0;
if (q1=nil)or(q2=nil) then
 begin
 if q1=q2 then h:=1
 else h:=0;
 end
else
 begin
 if q1^.wert=q2^.wert then
  begin
  h:=1;
  h:=h*vergleich(q1^.a,q2^.a);
  h:=h*vergleich(q1^.b,q2^.b);
  end;
 end;
vergleich:=h;
end;

procedure _vereinfachen(var quelle:zeiger);
var h:zeiger;
begin
(*write("ve",quelle^.wert);
if quelle=nil then write("nil!!");
if quelle^.a=nil then write("anil!");
if quelle^.b=nil then write("bnil!");*)
if (quelle^.wert<>"")and(quelle^.a<>nil) then
begin
(*writeln("nun kommen wir zum vereinfachenden Teil",quelle^.wert);*)
 gnot:=gnot+1;
 (*if quelle^.a=nil then write("a2nil!");
 if quelle^.b=nil then write("b2nil!");*)
 if (quelle^.wert="-")and(vergleich(quelle^.a,quelle^.b)=1) then
  begin
  kill(quelle^.a);
  kill(quelle^.b);
  quelle^.wert:="0";
  quelle^.a:=nil;
  quelle^.b:=nil;
  ausgeben(wurzel);
  schalter:=1;
  end;
 if (quelle^.wert="/")and(vergleich(quelle^.a,quelle^.b)=1) then
  begin
  kill(quelle);
  new(quelle);
  quelle^.wert:="1";
  quelle^.a:=nil;
  quelle^.b:=nil;
  ausgeben(wurzel);
  schalter:=1;
  end;
 (*write("stufe:",gnot);
 if quelle^.a<>nil then write("nil<>a");
 if quelle^.b<>nil then writeln("nil<>b");*)
 if (quelle^.wert="*")or(quelle^.wert="^")then  (*  falls nicht ende des baums *)
  begin
  if quelle^.a^.wert="0" then         (*            0*ausdruck        *)
   begin                             (*            0^ausdruck        *)
   kill(quelle^.a);
   kill(quelle^.b);
   quelle^.wert:="0";
   (*writeln("0*^ausdruck");*)
   ausgeben(wurzel);
   schalter:=1;
   end;
  if quelle^.b^.wert="1" then         (*            ausdruck*1        *)
   begin                             (*            ausdruck^1        *)
   quelle^.wert:=quelle^.a^.wert;
   kill(quelle^.b);
   h:=quelle^.a;
   quelle^.b:=quelle^.a^.b;
   quelle^.a:=quelle^.a^.a;
   dispose(h);
   (*writeln("ausdruck*^1");*)
   ausgeben(wurzel);
   schalter:=1;
   end;
  if (quelle^.a^.wert="1")and(quelle^.wert="*") then (* 1*ausdruck   *)
   begin
   quelle^.wert:=quelle^.b^.wert;
   kill(quelle^.a);
   h:=quelle^.b;
   quelle^.a:=quelle^.b^.a;
   quelle^.b:=quelle^.b^.b;
   dispose(h);
   (*writeln("1*ausdruck");*)
   ausgeben(wurzel);
   schalter:=1;
   end;
  if (quelle^.a^.wert="1")and(quelle^.wert="^") then (* 1^ausdruck   *)
   begin
   quelle^.wert:=quelle^.a^.wert;
   kill(quelle^.b);
   h:=quelle^.a;
   quelle^.b:=quelle^.a^.b;
   quelle^.a:=quelle^.a^.b;
   dispose(h);
    (*writeln("1^ausdruck");*)
   ausgeben(wurzel);
   schalter:=1;
   end;
  if (quelle^.wert="*")and(quelle^.b^.wert="0") then (* ausdruck*0   *)
   begin
   kill(quelle^.a);
   kill(quelle^.b);
   quelle^.wert:="0";
   (*writeln("ausdruck*0");*)
   ausgeben(wurzel);
   schalter:=1;
   end;
  if (quelle^.wert="^")and(quelle^.b^.wert="0") then (* ausdruck^0   *)
   begin
   kill(quelle^.a);
   kill(quelle^.b);
   quelle^.wert:="1";
  (*writeln("ausdruck^0");*)
   ausgeben(wurzel);
   schalter:=1;
   end;
  end;
 if (quelle^.wert="/")and(quelle^.a^.wert="0") then (* 0/ausdruck  *)
  begin
  kill(quelle);
  new(quelle);
  quelle^.wert:="0";
  quelle^.a:=nil;
  quelle^.b:=nil;
 (*writeln("0/ausdruck");*)
  ausgeben(wurzel);
  schalter:=1;
  end;
 if (prior(quelle,1)=1) then
  begin
  if(quelle^.a^.wert="0")and(quelle^.b<>nil) then    (*  0+ausdruck *)
   begin
   kill(quelle^.a);
   quelle^.a:=quelle^.b;
   quelle^.b:=nil;
  (*writeln("0+ausdruck");*)
   ausgeben(wurzel);
   schalter:=1;
   end;
  end;
 if (prior(quelle,1)=1)and(quelle^.b<>nil) then
  begin
  if(quelle^.b^.wert="0") then                   (* ausdruck+0  *)
   begin
   quelle^.wert:=quelle^.a^.wert;
   kill(quelle^.b);
   if quelle^.b<>nil then writeln("fehler-hier nicht genilt - warum?");
   h:=quelle^.a;
   quelle^.b:=quelle^.a^.b;
   quelle^.a:=quelle^.a^.a;
   dispose(h);
(*   writeln("ausdruck+0");*)
   ausgeben(wurzel);
   schalter:=1;
   end;
  end;
 if quelle^.a<>nil then
 begin
(* writeln("a<>nil");*)
 _vereinfachen(quelle^.a);
 end;
 if quelle^.b<>nil then
 begin
(* writeln("b<>nil");*)
 _vereinfachen(quelle^.b);
 end;
 gnot:=gnot-1;
end;
end;

procedure vereinfachen(var p:zeiger);
begin
repeat
schalter:=0;
zurⁿckformen(wurzel);
kill(wurzel);
new(wurzel);
wurzel^.wert:=ausgabe;
wurzel^.a:=nil;
wurzel^.b:=nil;
ⁿberprⁿfen(wurzel);
umformung(wurzel);
_vereinfachen(wurzel);
until schalter=0;
end;

procedure ableitung(var p:zeiger);
var a:array[1..10] of zeiger;
    s:string[999];
    v:integer;
begin
if (prior(p,1)=1)and(p^.b<>nil) then      (*         summenregel             *)
 begin
 ableinf(p^.a);
 ableinf(p^.b);
 erlaeut:="Summenformel";
 ausgeben(wurzel);
 erlaeut:="";
 ablaust(p^.a);
 if xabh(p^.a)<>0 then
  begin
  ableitung(p^.a);
  end
 else
  begin
  kill(p^.a);
  new(p^.a);
  p^.a^.wert:="0";
  p^.a^.a:=nil;
  p^.a^.b:=nil;
  end;
 ablaust(p^.b);
 if xabh(p^.b)<>0 then
  begin
  ableitung(p^.b);
  end
 else
  begin
  kill(p^.b);
  new(p^.b);
  p^.b^.wert:="0";
  p^.b^.a:=nil;
  p^.b^.b:=nil;
  end;
 end;
if (prior(p,1)=1)and(p^.b=nil) then ableitung(p^.a);
if p^.wert="*" then     (*        produktregel             *)
 begin
 if (xabh(p^.a)<>0)and(xabh(p^.b)<>0) then
  begin
  new(a[1]);
  new(a[2]);
  a[1]^.a:=kopie(p^.a);  (*           p^.wert                *)
  ableinf(a[1]^.a);      (*           /       \              *)
  a[1]^.wert:="*";       (*    a[1]^.wert      a[2]^.wert    *)
  a[1]^.b:=p^.b;         (*   /     \            /     \     *)
  p^.wert:="+";          (*  /       \          /       \    *)
  a[2]^.a:=p^.a;       (* a[1]^.a  a[1]^.b   a[2]^.a  a[2]^.b *)
  a[2]^.wert:="*";
  a[2]^.b:=kopie(p^.b);
  ableinf(a[2]^.b);
  p^.a:=a[1];
  p^.b:=a[2];
  erlaeut:="Produktregel";
  ausgeben(wurzel);
  erlaeut:="";
  ablaust(a[1]^.a);
  ableitung(a[1]^.a);
  ablaust(a[2]^.b);
  ableitung(a[2]^.b);
  end
  else
  begin
  if xabh(p^.a)<>0 then
   begin
   ableinf(p^.a);
   ausgeben(wurzel);
   ablaust(p^.a);
   ableitung(p^.a);
   end
   else
   begin
   if xabh(p^.b)<>0 then
    begin
    ableinf(p^.b);
    ausgeben(wurzel);
    ablaust(p^.b);
    ableitung(p^.b);
    end
    else
    begin
    ableinf(p);
    erlaeut:="konst.";
    ausgeben(wurzel);
    erlaeut:="";
    ablaust(p);
    kill(p);
    new(p);
    p^.wert:="0";
    p^.a:=nil;
    p^.b:=nil;
    end;
   end;
  end;
 end;
if p^.wert="/" then    (*          quotientenregel          *)
  begin
  if (xabh(p^.a)<>0)and(xabh(p^.b)<>0) then
  begin
   new(a[1]);
   new(a[2]);
   new(a[3]);
   new(a[4]);
   new(a[5]);
   a[1]^.a:=kopie(p^.a);
   ableinf(a[1]^.a);
   a[1]^.wert:="*";
   a[1]^.b:=p^.b;
   a[2]^.a:=p^.a;
   a[2]^.wert:="*";
   a[2]^.b:=kopie(p^.b);
   ableinf(a[2]^.b);
   a[5]^.a:=a[1];
   a[5]^.wert:="-";
   a[5]^.b:=a[2];
   a[3]^.a:=kopie(p^.b);
   a[3]^.wert:="^";
   a[3]^.b:=a[4];
   a[4]^.a:=nil;
   a[4]^.wert:="2";
   a[4]^.b:=nil;
   p^.a:=a[5];
   p^.b:=a[3];
   erlaeut:="Quotientenregel";
   ausgeben(wurzel);
   erlaeut:="";
   ablaust(a[1]^.a);
   ableitung(a[1]^.a);
   ablaust(a[2]^.b);
   ableitung(a[2]^.b);
  end
  else
  begin
   if xabh(p^.a)<>0 then
   begin
    ableinf(p^.a);
    ausgeben(wurzel);
    ablaust(p^.a);
    ableitung(p^.a);
   end
   else
   begin
    if xabh(p^.b)<>0 then
    begin
    new(a[1]);
    new(a[2]);
    new(a[3]);
    new(a[4]);
    a[1]^.wert:="*";
    a[1]^.b:=kopie(p^.b);
    a[1]^.a:=p^.a;
    a[2]^.wert:="/";
    a[2]^.a:=a[1];
    a[2]^.b:=a[3];
    a[3]^.wert:="^";
    a[3]^.a:=p^.b;
    a[3]^.b:=a[4];
    a[4]^.wert:="2";
    a[4]^.a:=nil;
    a[4]^.b:=nil;
    p^.wert:="-";
    p^.a:=a[2];
    p^.b:=nil;
    ableinf(a[1]^.b);
    ausgeben(wurzel);
    ablaust(a[1]^.b);
    ableitung(a[1]^.b);
    end
   else
    begin
    ableinf(p);
    ausgeben(wurzel);
    ablaust(p);
    kill(p);
    new(p);
    p^.wert:="0";
    p^.a:=nil;
    p^.b:=nil;
    end;
   end;
  end;
 end;
if p^.wert="^" then                 (*       potenzregel          *)
 begin
 if (p^.a^.wert="x")and(xabh(p^.b)=0) then (*  x^konst.      *)
  begin
  new(a[1]);
  p^.wert:="*";
  a[1]^.wert:="^";
  a[1]^.a:=p^.a;
  new(a[3]);
  a[3]^.wert:="1";
  a[3]^.a:=nil;
  a[3]^.b:=nil;
  new(a[4]);
  a[4]^.wert:="-";
  a[4]^.a:=p^.b;
  a[4]^.b:=a[3];
  a[1]^.b:=a[4];
  a[2]:=kopie(p^.b);
  p^.a:=a[2];
  p^.b:=a[1];
  erlaeut:="einf.Potenzreg.";
  ausgeben(wurzel);
  erlaeut:="";
  end
 else
  begin
  if (xabh(p^.a)=0)and(xabh(p^.b)<>0) then
   begin            (* konst^g(x) *)
   new(a[1]);
   new(a[2]);
   new(a[3]);
   a[1]^.wert:="^";
   a[1]^.a:=p^.a;
   a[1]^.b:=p^.b;
   a[2]^.wert:="*";
   a[2]^.a:=kopie(p^.b);
   a[2]^.b:=a[3];
   a[3]^.wert:="ln";
   a[3]^.a:=kopie(p^.a);
   a[3]^.b:=nil;
   p^.wert:="*";
   p^.a:=a[1];
   p^.b:=a[2];
   ableinf(a[2]^.a);
   erlaeut:="$konst.^{f(x)}$";
   ausgeben(wurzel);
   erlaeut:="";
   ablaust(a[2]^.a);
   ableitung(a[2]^.a);
   end
  else
   begin   (* f(x)^konst.    *)
   if (xabh(p^.a)<>0)and(xabh(p^.b)=0) then
    begin
    new(a[1]);
    new(a[2]);
    new(a[3]);
    new(a[4]);
    a[1]^.wert:="^";
    a[1]^.a:=p^.a;
    a[1]^.b:=a[3];
    a[2]^.wert:="*";
    a[2]^.a:=kopie(p^.b);
    a[2]^.b:=kopie(p^.a);
    a[3]^.wert:="-";
    a[3]^.a:=p^.b;
    a[3]^.b:=a[4];
    a[4]^.wert:="1";
    a[4]^.a:=nil;
    a[4]^.b:=nil;
    p^.wert:="*";
    p^.a:=a[1];
    p^.b:=a[2];
    ableinf(a[2]^.b);
    erlaeut:="$f(x)^{konst}$";
    ausgeben(wurzel);
    erlaeut:="";
    ablaust(a[2]^.b);
    ableitung(a[2]^.b);
    end
   else
    begin
    v:=2;                       (* f(x)^g(x)       *)
    repeat
     new(a[v]);
     v:=v+1;
    until v=11;
    p^.wert:="*";
    a[2]^.a:=p^.a;
    a[2]^.wert:="^";
    a[2]^.b:=p^.b;
    a[6]^.a:=a[7];
    a[6]^.wert:="+";
    a[6]^.b:=a[9];
    a[7]^.a:=kopie(p^.b);
    ableinf(a[7]^.a);
    a[7]^.wert:="*";
    a[7]^.b:=a[8];
    a[8]^.a:=kopie(p^.a);
    a[8]^.wert:="ln";
    a[8]^.b:=nil;
    a[9]^.a:=a[10];
    a[9]^.wert:="*";
    a[9]^.b:=kopie(p^.a);
    ableinf(a[9]^.b);
    a[10]^.a:=kopie(p^.b);
    a[10]^.wert:="/";
    a[10]^.b:=kopie(p^.a);
    p^.a:=a[2];
    p^.b:=a[6];
    erlaeut:="Potenz.-regel";
    ausgeben(wurzel);
    erlaeut:="";
    ablaust(a[7]^.a);
    ableitung(a[7]^.a);
    ablaust(a[9]^.b);
    ableitung(a[9]^.b);
   end;
  end;
 end;
end;
if prior(p,1)=4 then
 begin
 if p^.wert="x" then        (*           x           *)
  begin
  p^.wert:="1";
  p^.a:=nil;
  p^.b:=nil;
  end
 else
  begin
  if p^.wert="sin"then      (*         sin           *)
   begin
   new(a[1]);
   a[1]^.a:=p^.a;
   a[1]^.wert:="cos";
   a[1]^.b:=nil;
   p^.a:=a[1];
   p^.wert:="*";
   p^.b:=kopie(a[1]^.a);
   ableinf(p^.b);
   erlaeut:="Sinus-abl";
   ausgeben(wurzel);
   erlaeut:="";
   ablaust(p^.b);
   ableitung(p^.b);
   end
  else
   begin
   if p^.wert="cos"then     (*          cos        *)
    begin
    new(a[1]);
    a[1]^.a:=p^.a;
    a[1]^.wert:="sin";
    a[1]^.b:=nil;
    new(a[2]);
    a[2]^.a:=a[1];
    a[2]^.wert:="-";
    a[2]^.b:=nil;
    p^.a:=a[2];
    p^.wert:="*";
    p^.b:=kopie(a[1]^.a);
    ableinf(p^.b);
    erlaeut:="Cosinus-abl.";
    ausgeben(wurzel);
    erlaeut:="";
    ablaust(p^.b);
    ableitung(p^.b);
    end
   else
    begin
    if p^.wert="ln"then        (*        ln           *)
     begin
     p^.b:=kopie(p^.a);
     p^.wert:="/";
     ableinf(p^.a);
     erlaeut:="Log.nat.-regel";
     ausgeben(wurzel);
     erlaeut:="";
     ablaust(p^.a);
     ableitung(p^.a);
     end
    else
     begin
     if p^.wert="sqr"then     (*          sqr          *)
      begin
      p^.wert:="/";
      new(a[1]);
      p^.b:=a[1];
      a[1]^.wert:="*";
      new(a[2]);
      a[1]^.a:=a[2];
      a[1]^.b:=kopie(p^.a);
      a[2]^.wert:="2";
      a[2]^.a:=nil;
      a[2]^.b:=nil;
      ableinf(p^.a);
      erlaeut:="Wurzel-regel";
      ausgeben(wurzel);
      erlaeut:="";
      ablaust(p^.a);
      ableitung(p^.a);
      end
     else
      begin
      if p^.wert="tan" then    (*        tan            *)
       begin
       new(a[1]);
       new(a[2]);
       new(a[3]);
       p^.wert:="/";
       p^.b:=a[1];
       a[1]^.wert:="^";
       a[1]^.a:=a[2];
       a[1]^.b:=a[3];
       a[2]^.wert:="cos";
       a[2]^.a:=kopie(p^.a);
       a[2]^.b:=nil;
       a[3]^.wert:="2";
       a[3]^.a:=nil;
       a[3]^.b:=nil;
       ableinf(p^.a);
       erlaeut:="Tangens-abl";
       ausgeben(wurzel);
       erlaeut:="";
       ablaust(p^.a);
       ableitung(p^.a);
       end
      else
       begin
       p^.wert:="0";            (*          konst         *)
       p^.a:=nil;
       p^.b:=nil;
       end;
      end;
     end;
    end;
   end;
  end;
 end;
end;

function value(p:zeiger):integer;
begin
end;

begin
if FromWB then
 begin
  Assign(input,"con:0/0/640/120/Matheknecht");
  reset(input);
  output:=input;
 end;
openlib(reqbase,"req.library",0);
FReq:=Filerequester(0,"",nil,nil,nil,nil,0,15,35,10,0,3,1,3,3,1,2,1,
1,1,1,1,1,1,chr(0),datestamp(0,0,0),0,0,0,0,nil,"","",0,0,0,0,0,0,0,0,
nil,nil,nil,"",nil,0,0,0,0);
gnot:=0;
erlaeut:="";
FReq.Title:="Wohin mit dem LaTeX-File?";
dir:="ram:";
FReq.Dirname:=^dir;
datei:="abl.tex";
FReq.Filename:=^datei;
pfad:="";
FReq.Pathname:=^pfad;
FReq.Flags:=FRQloading;
clrscr;
write("Matheknecht");
writeln("von Carsten Hammer Version0.976");
writeln("Schwindstr.7");
writeln("48 Bielefeld 1");
new(wurzel);
ausgabe:="";
(*eingabe:="ln(sqr(x/2))+x^2"; *)
repeat
write("F(x)=");
readln(eingabe);
until eingabe<>"";
wurzel^.wert:=eingabe;
wurzel^.a:=nil;
wurzel^.b:=nil;
ⁿberprⁿfen(wurzel);
writeln("Eingabe vorerst in Ordnung:",wurzel^.wert);
umformung(wurzel);
Erfolg:=FileRequest(^FReq);
if Erfolg<>0 then
begin
rewrite(f,pfad)
writeln(f,"\documentstyle[12pt]{article}");
(*writeln(f,"\textwidth8in \textheigth30cm");
writeln(f,"\topmargin0in \headheight0in \headsep0in");
writeln(f,"\evensidemargin0in \oddsidemargin0in");*)
writeln(f,"\begin{document}");
writeln(f,"Folgende Funktion differenziere ich nach x:");
ausgeben(wurzel);
writeln(f,"Nu ma los!!");
ableitung(wurzel);
vereinfachen(wurzel);
writeln("Damit haben wir die Ableitung von ",eingabe," als: ");
writeln(f,"Nun ham wir`s geschafft!");
ausgeben(wurzel);
writeln(f,"\end{document}");
kill(wurzel);
end
else writeln("Na denn eben nicht!");
if fromwb then delay(150);
(* close(f); *)
closelib(reqbase);
(*if FromWB then Close (input);*)
end.