home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Pascal / MAXONPASCAL3.DMS / in.adf / DEMOS-OS1.3 / Analysator / Analysis.p < prev   
Encoding:
Text File  |  1994-07-24  |  26.4 KB  |  884 lines
  1. Module Analysis;
  2.  
  3. {$include"mathieeedoubtrans.lib" }
  4. {$include "ana.h" }
  5.  
  6. VAR f:              ARRAY['f'..'h',0..99] OF p; EXPORT;
  7.     x,y,hi,lo,step: atyp;
  8.     v:              ARRAY['a'..'d',0..99] OF atyp; EXPORT;
  9.     c1:             char;
  10.     c:              char; EXPORT;
  11.     i:              integer;
  12.     fx:             p;
  13.     everr:          boolean; EXPORT;
  14.     Ein:            Buffer; IMPORT;
  15.  
  16. PROCEDURE InitAnalysis; EXPORT;
  17.   BEGIN
  18.     OpenLib(mathieeedoubtransbase,'mathieeedoubtrans.library',0);
  19.   END;
  20.  
  21. Function Pri(b:p):integer;
  22.   Begin
  23.     Case b^.t Of
  24.       operator: Case b^.name Of
  25.                 '+','-': Pri:=1;
  26.                 '*','/': Pri:=2;
  27.                 '^':     Pri:=3
  28.                 End;
  29.       funktion: Pri:=4;
  30.       variable,literal: Pri:=5
  31.     End
  32.   End;
  33.  
  34. Procedure WriteFunkName(n:char);
  35.   Begin
  36.     Case n Of
  37.       '-': writeP('-');
  38.       '+': writeP('abs');
  39.       'c': writeP('cos');
  40.       'e': writeP('exp');
  41.       'g': writeP('lg');
  42.       'l': writeP('ln');
  43.       'o': writeP('cot');
  44.       'q': writeP('sqr');
  45.       'r': writeP('sqrt');
  46.       's': writeP('sin');
  47.       't': writeP('tan');
  48.       'v': writeP('sgn');
  49.       'C': writeP('arccos');
  50.       'O': writeP('arccot');
  51.       'S': writeP('arcsin');
  52.       'T': writeP('arctan');
  53.     End
  54.   End;
  55.  
  56. Procedure InFix; { globale Funktion: (b:p; pr:integer); EXPORT }
  57.   Var ap:integer;
  58.   Begin
  59.     If b<>Nil Then
  60.     Case b^.t Of
  61.       variable: Begin
  62.                   writeP(b^.name); If b^.name='p' Then writeP('i')
  63.                 End;
  64.       operator: Begin
  65.                   ap:=pri(b);
  66.                   If ap<pr Then writeP('(');
  67.                   InFix(b^.op1,ap);
  68.                   writeP(b^.name); InFix(b^.op2,ap+1);
  69.                   If ap<pr Then writeP(')')
  70.                 End;
  71.       literal: Begin writePR(b^.value,0); WriteP(' ') End;
  72.       Funktion: Begin
  73.                   WriteFunkName(b^.name);
  74.                   If (pri(b^.op1)>=4) And (b^.name<>'-') Then writeP(' ');
  75.                   InFix(b^.op1,4)
  76.                 End
  77.     End
  78.   End;
  79.  
  80. FUNCTION sgn; { globale Funktion: (x:atyp):integer; EXPORT }
  81.   BEGIN
  82.     sgn:=ord(x>0)-ord(x<0)
  83.   END;
  84.  
  85. Function eval; { globale Funktion: (b:p; x:atyp):atyp; EXPORT }
  86.   Var f,e1,e2:atyp;
  87.  
  88.   PROCEDURE Fehler;
  89.     BEGIN
  90.       everr:=true
  91.     END;
  92.  
  93.   Begin
  94.     case b^.t Of
  95.       Variable:Case b^.name Of
  96.                  'x': eval:=x;
  97.                  'e': eval:=e;
  98.                  'p': eval:=pi
  99.                End;
  100.       literal: eval:=b^.value;
  101.       operator: BEGIN e1:=eval(b^.op1,x); e2:=eval(b^.op2,x);
  102.                   Case b^.name Of
  103.                   '+': eval:=e1+e2;
  104.                   '-': eval:=e1-e2;
  105.                   '*': eval:=e1*e2;
  106.                   '/': IF e2=0 THEN Fehler ELSE
  107.                        eval:=e1/e2;
  108.                   '^': IF e2=0 THEN eval:=1
  109.                        ELSE IF e2=1 THEN eval:=e1
  110.                        ELSE IF e2=-1 THEN
  111.                          IF e1=0 THEN Fehler ELSE eval:=1/e1
  112.                        ELSE
  113.                        IF e1>0 THEN eval:=IEEEDpexp(e2*IEEEDpLog(e1))
  114.                        ELSE
  115.                        IF e1=0 THEN eval:=0
  116.                        ELSE
  117.                        IF Abs(Frac(e2))<1e-5 THEN
  118.                          BEGIN
  119.                            e1:=IEEEDpexp(e2*IEEEDpLog(Abs(e1)));
  120.                            IF Odd(Round(e2)) THEN Eval:=-e1
  121.                                              ELSE Eval:=e1
  122.                          END
  123.                        ELSE Fehler;
  124.                   END
  125.                 End;
  126.       funktion: Begin f:=eval(b^.op1,x);
  127.                   Case b^.name Of
  128.                     '-': eval:=-f;
  129.                     '+': eval:=abs(f);
  130.                     'c': eval:=IEEEDpcos(f);
  131.                     'e': eval:=IEEEDpexp(f);
  132.                     'g': eval:=IEEEDpLog(f)/IEEEDpLog(10);
  133.                     'l': IF f<=0 THEN Fehler ELSE
  134.                          eval:=IEEEDpLog(f);
  135.                     'o': BEGIN e1:=IEEEDpsin(f);
  136.                            IF e1=0 THEN Fehler
  137.                            ELSE eval:=IEEEDpcos(f)/e1
  138.                          END;
  139.                     'q': eval:=f*f;
  140.                     'r': IF f<0 THEN Fehler ELSE
  141.                          eval:=IEEEDpsqrt(f);
  142.                     's': eval:=IEEEDpsin(f);
  143.                     't': BEGIN e1:=IEEEDpcos(f);
  144.                            IF e1=0 THEN Fehler
  145.                            ELSE
  146.                              eval:=IEEEDpsin(f)/e1
  147.                          END;
  148.                     'v': eval:=round(ord(f>0)-ord(f<0));
  149.                     'T': eval:=IEEEDpatan(f);
  150.                     'O': IF f=0 THEN Fehler ELSE
  151.                          eval:=IEEEDpatan(1/f)
  152.                   End
  153.                 End
  154.     End
  155.   End;
  156.  
  157.  
  158. Procedure Forget; { globale Funktion: (Var z:p); EXPORT }
  159.   Begin
  160.     If z<>Nil Then
  161.       Begin
  162.         Forget(z^.op1);
  163.         Forget(z^.op2);
  164.         dispose(z);
  165.         z:=Nil
  166.       End
  167.   End;
  168.  
  169.  
  170. Function konstant; { globale Funktion: (b:p):boolean; EXPORT }
  171.   Begin
  172.     If b=Nil Then konstant:=true
  173.     Else
  174.       Case b^.t Of
  175.         variable: konstant:=b^.name<>'x';
  176.         operator: konstant:=konstant(b^.op1) And konstant(b^.op2);
  177.         literal:  konstant:=true;
  178.         funktion: konstant:=konstant(b^.op1)
  179.       End
  180.   End;
  181.  
  182. Procedure Optimize(Var b:p);
  183.   Var h:p;
  184.   Begin
  185.     If b<>Nil Then
  186.       Begin
  187.         Optimize(b^.op1); Optimize(b^.op2);
  188.         If konstant(b) Then
  189.           Begin
  190.             New(h);
  191.             With h^ Do
  192.               Begin
  193.                 t:=literal;
  194.                 name:=' ';
  195.                 op1:=Nil;
  196.                 op2:=Nil;
  197.                 value:=eval(b,0)
  198.               End;
  199.             Forget(b);
  200.             b:=h
  201.           End
  202.       End
  203.   End;
  204.  
  205. FUNCTION copy(c:p):p;
  206.   VAR h:p;
  207.   BEGIN
  208.     IF c=Nil THEN copy:=Nil
  209.     ELSE
  210.       BEGIN
  211.         New(h);
  212.         h^:=c^;
  213.         h^.op1:=copy(c^.op1);
  214.         h^.op2:=copy(c^.op2);
  215.         copy:=h
  216.       END
  217.   END;
  218.  
  219. PROCEDURE Subst(a:p; VAR b:p);
  220.   { In Funktion b wird fuer x jeweils eine Kopie von a eingesetzt }
  221.   BEGIN
  222.     IF b<>NIL THEN
  223.       IF (b^.t=variable) AND (b^.name='x') THEN
  224.         BEGIN dispose(b); b:=copy(a) END
  225.       ELSE
  226.         BEGIN
  227.           Subst(a,b^.op1); Subst(a,b^.op2)
  228.         END
  229.   END;
  230.  
  231. FUNCTION diff(b:p):p;
  232.   VAR h,h1,h2: p;
  233.         b1,b2: boolean;
  234.         e1,e2: atyp;
  235.  
  236.   FUNCTION Neulit(r:atyp):p;
  237.     VAR hl:p;
  238.     BEGIN
  239.       New(hl);
  240.       hl^.t:=literal;
  241.       hl^.value:=r;
  242.       hl^.name:=' ';
  243.       hl^.op1:=Nil;
  244.       hl^.op2:=Nil;
  245.       Neulit:=hl
  246.     END;
  247.  
  248.   FUNCTION Neuop(n:char; o1,o2:p):p;
  249.     VAR hl:p;
  250.     BEGIN
  251.       New(hl);
  252.       hl^.t:=operator;
  253.       hl^.name:=n;
  254.       hl^.op1:=o1;
  255.       hl^.op2:=o2;
  256.       hl^.value:=0;
  257.       Neuop:=hl
  258.     END;
  259.  
  260.   FUNCTION Neufun(nam:char; o:p):p;
  261.     VAR hl:p;
  262.     BEGIN
  263.       New(hl);
  264.       hl^.t:=funktion;
  265.       hl^.name:=nam;
  266.       hl^.op1:=o;
  267.       hl^.op2:=Nil;
  268.       hl^.value:=0;
  269.       Neufun:=hl
  270.     END;
  271.  
  272.   FUNCTION Null(h:p):boolean;
  273.     BEGIN
  274.       IF konstant(h) THEN
  275.         Null:=eval(h,1)=0
  276.       ELSE Null:=false;
  277.     END;
  278.  
  279.   BEGIN
  280.     CASE b^.t OF
  281.       literal: h:=Neulit(0);
  282.       variable: IF b^.name='x' THEN h:=Neulit(1) ELSE h:=Neulit(0);
  283.       operator: BEGIN
  284.                   h1:=diff(b^.op1); b1:=konstant(h1);
  285.                   h2:=diff(b^.op2); b2:=konstant(h2);
  286.                   IF b1 THEN e1:=eval(h1,0) ELSE e1:=-1;
  287.                   IF b2 THEN e2:=eval(h2,0) ELSE e2:=-1;
  288.                   CASE b^.name OF
  289.                     '+','-': IF e2=0 THEN
  290.                                IF e1=0 THEN
  291.                                  BEGIN h:=neulit(0);
  292.                                    Forget(h1); Forget(h2)
  293.                                  END
  294.                                ELSE
  295.                                  BEGIN h:=h1; Forget(h2) END
  296.                              ELSE
  297.                              IF e1=0 THEN
  298.                                BEGIN
  299.                                  IF b^.name='+' THEN h:=h2
  300.                                  ELSE h:=Neufun('-',h2);
  301.                                  Forget(h1)
  302.                                END
  303.                              ELSE
  304.                                h:=Neuop(b^.name,h1,h2);
  305.                     '*': IF e1=0 THEN
  306.                            IF e2=0 THEN
  307.                              BEGIN
  308.                                h:=Neulit(0); Forget(h1); Forget(h2)
  309.                              END
  310.                            ELSE
  311.                            IF e2=1 THEN
  312.                              BEGIN h:=copy(b^.op1); Forget(h1); Forget(h2) END
  313.                            ELSE
  314.                              BEGIN
  315.                                h:=Neuop('*',copy(b^.op1),h2); Forget(h1)
  316.                              END
  317.                          ELSE
  318.                          IF e2=0 THEN
  319.                            BEGIN
  320.                              h:=Neuop('*',copy(b^.op2),h1); Forget(h2)
  321.                            END
  322.                          ELSE
  323.                          IF e1=1 THEN
  324.                            BEGIN
  325.                              h:=Neuop('+',copy(b^.op2),Neuop('*',copy(b^.op1),h2));
  326.                              Forget(h1)
  327.                            END
  328.                          ELSE
  329.                          IF e2=1 THEN
  330.                            BEGIN
  331.                              h:=Neuop('+',Neuop('+',h1,copy(b^.op2)),copy(b^.op1));
  332.                              Forget(h2)
  333.                            END
  334.                          ELSE
  335.                            h:=Neuop('+',Neuop('*',h1,copy(b^.op2)),Neuop('*',copy(b^.op1),h2));
  336.                     '/': BEGIN
  337.                            IF e2=0 THEN      { Nenner konstant }
  338.                              BEGIN
  339.                                h:=Neuop('/',h1,copy(b^.op2));
  340.                                Forget(h2)
  341.                              END
  342.                            ELSE
  343.                            IF e1=0 THEN      { Zähler konstant }
  344.                              BEGIN
  345.                                IF e2=1 THEN   { und Nenner 1-linear }
  346.                                  BEGIN
  347.                                    h:=Neuop('*',Neulit(-eval(b^.op1,0)),
  348.                                                 Neuop('^',copy(b^.op2),
  349.                                                           Neulit(-2)));
  350.                                    Forget(h1); Forget(h2)
  351.                                  END
  352.                                ELSE
  353.                                  BEGIN
  354.                                    h:=Neuop('*',
  355.                                         Neuop('*',Neulit(-eval(b^.op1,0)),
  356.                                                   h2),
  357.                                         Neuop('^',copy(b^.op2),
  358.                                                   Neulit(-2)));
  359.                                    Forget(h1)
  360.                                  END
  361.                              END
  362.                            ELSE
  363.                              BEGIN          { Quotientenregel }
  364.                                h:=Neuop('/',Neuop('-',
  365.                                Neuop('*',h1,copy(b^.op2)),Neuop('*',copy(b^.op1),h2)),
  366.                                Neuop('^',copy(b^.op2),Neulit(2)))
  367.                              END
  368.                          END;
  369.                     '^': IF e2=0 THEN
  370.                            BEGIN
  371.                              e2:=eval(b^.op2,0);
  372.                              IF e2=0 THEN          { f(x)^0 }
  373.                                BEGIN h:=Neulit(0);
  374.                                  Forget(h1); Forget(h2) END
  375.                              ELSE
  376.                              IF e2=1 THEN
  377.                                BEGIN h:=h1; Forget(h2) END
  378.                              ELSE
  379.                              BEGIN     { f(x)^n }
  380.                                IF e2=2 THEN h:=copy(b^.op1)   { f(x)^2 }
  381.                                ELSE h:=Neuop('^',copy(b^.op1),Neulit(e2-1));
  382.                                IF e1=1 THEN
  383.                                  h:=Neuop('*',Neulit(e2),h)
  384.                                ELSE h:=Neuop('*',Neuop('*',Neulit(e2),h1),h);
  385.                                Forget(h2)
  386.                              END
  387.                            END
  388.                          ELSE
  389.                          IF e1=0 THEN
  390.                            BEGIN e1:=eval(b^.op1,0);
  391.                              IF e2=1 THEN    { a^x }
  392.                                IF e1=e THEN     { e^x }
  393.                                  BEGIN
  394.                                    h:=Neufun('e',copy(b^.op2));
  395.                                    Forget(h1); Forget(h2)
  396.                                  END
  397.                                ELSE               { a<>e }
  398.                                  BEGIN
  399.                                    h:=NeuOp('*',Neufun('l',copy(b^.op1)),
  400.                                                 NeuOp('^',copy(b^.op1),
  401.                                                           copy(b^.op2)));
  402.                                    Forget(h1); Forget(h2)
  403.                                  END
  404.                              ELSE           { a^f(x) }
  405.                                IF e1=e THEN  { e^f(x) }
  406.                                  IF e2=1 THEN    { e^x }
  407.                                    BEGIN
  408.                                      h:=Neufun('e',copy(b^.op2));
  409.                                      Forget(h1);Forget(h2)
  410.                                    END
  411.                                  ELSE
  412.                                    BEGIN
  413.                                      h:=Neuop('*',h2,Neufun('e',copy(b^.op2)));
  414.                                      Forget(h1)
  415.                                    END
  416.                                ELSE           { a<>e}
  417.                                IF e2=1 THEN    { a^x }
  418.                                  BEGIN
  419.                                    h:=Neuop('*',Neufun('l',copy(b^.op1))
  420.                                                ,copy(b));
  421.                                    Forget(h1); Forget(h2)
  422.                                  END
  423.                                ELSE
  424.                                  BEGIN
  425.                                    h:=Neuop('*',Neuop('*',
  426.                                                       Neufun('l',copy(b^.op1)),h2)
  427.                                                ,copy(b));
  428.                                    Forget(h1)
  429.                                  END
  430.                            END
  431.                          ELSE           { g(x)^h(x) }
  432.                            BEGIN
  433.                              Forget(h1); Forget(h2);
  434.                              h1:=Neufun('e',Neuop('*',copy(b^.op2),
  435.                                                       Neufun('l',copy(b^.op1))));
  436.                              h:=diff(h1);
  437.                              Forget(h1)
  438.                            END
  439.                   END
  440.                 END;
  441.       funktion: BEGIN h1:=copy(b^.op1); h2:=diff(h1);
  442.                   CASE b^.name OF
  443.                     '-': BEGIN h:=Neulit(-1); Forget(h1) END;
  444.                     '+': h:=Neufun('v',h1);
  445.                     'c': h:=NeuOp('*',Neulit(-1),Neufun('s',h1));
  446.                     'e': h:=Neufun('e',h1);
  447.                     'g': h:=Neuop('*',Neulit(ln(10)),Neuop('^',h1,Neulit(-1)));
  448.                     'l': h:=Neuop('^',h1,Neulit(-1));
  449.                     'o': h:=Neuop('*',Neulit(-1)
  450.                                      ,NeuOp('^',Neufun('s',h1),Neulit(-2)));
  451.                     'q': h:=Neuop('*',Neulit(2),h1);
  452.                     'r': h:=Neuop('*',Neulit(0.5),
  453.                                       NeuOp('^',h1,Neulit(-0.5)));
  454.                     's': h:=Neufun('c',h1);
  455.                     't': h:=NeuOp('^',Neufun('c',h1),Neulit(-2));
  456.                     'v': BEGIN h:=Neulit(0); Forget(h1) END;
  457.                     'C': h:=Neuop('*',Neulit(-1),
  458.                                       Neuop('^',Neuop('-',Neulit(1),
  459.                                                           Neufun('q',h1)),
  460.                                                 Neulit(-0.5)));
  461.                     'O': h:=Neuop('*',Neulit(-1),
  462.                                       Neuop('^',Neuop('+',Neulit(1),
  463.                                                           Neufun('q',h1)),
  464.                                                 Neulit(-1)));
  465.                     'S': h:=Neuop('^',Neuop('-',Neulit(1),
  466.                                                 Neufun('q',h1)),
  467.                                       Neulit(-0.5));
  468.                     'T': h:=Neuop('^',Neuop('+',Neulit(1),
  469.                                                 Neufun('q',h1)),
  470.                                       Neulit(-1))
  471.                   END;
  472.                   IF konstant(h2) THEN e2:=eval(h2,0) ELSE e2:=-1;
  473.                   IF e2=1 THEN
  474.                     Forget(h2)
  475.                   ELSE
  476.                     h:=Neuop('*',h2,h)
  477.                 END
  478.     End;
  479.     diff:=h
  480.   End;
  481.  
  482. FUNCTION GetNum; { globale Funktion: (VAR tx:Buffer; VAR z:char):integer; EXPORT }
  483.   VAR i:integer;
  484.   BEGIN
  485.     i:=0;
  486.     WHILE (z>='0') AND (z<='9') DO
  487.       BEGIN
  488.         i:=10*i + ord(z)-ord('0');
  489.         z := tx.s[tx.p];
  490.         tx.p := tx.p+1
  491.       END;
  492.     GetNum:=i
  493.   END;
  494.  
  495. PROCEDURE Inp; { globale Funktion: (VAR tx:Buffer; VAR i:p); EXPORT }
  496.  
  497.   VAR c:      char;
  498.       err:    boolean;
  499.       pos:    1..100;
  500.       einstr: string[100];
  501.  
  502.   PROCEDURE gts;
  503.     BEGIN
  504.       IF err THEN c:=chr(0)
  505.       ELSE
  506.         BEGIN
  507.           c := tx.s[tx.p];
  508.           tx.p := tx.p+1;
  509.           IF (c>='A') AND (c<='Z') THEN
  510.             c:=chr(ord(c)-ord('A')+ord('a'));
  511.           einstr[pos]:=c;
  512.           pos:=pos+1
  513.         END
  514.     END;
  515.  
  516.   PROCEDURE get;
  517.     BEGIN REPEAT gts UNTIL c<>' ' END;
  518.  
  519.   FUNCTION Neu(tp:typ):p;
  520.     VAR h:p;
  521.     BEGIN
  522.       New(h);
  523.       WITH h^ DO
  524.         BEGIN t:=tp; name:=' '; op1:=NIL; op2:=NIL; value:=0 END;
  525.       Neu:=h
  526.     END;
  527.  
  528.   PROCEDURE Fehler;
  529.     BEGIN
  530.       IF NOT err THEN
  531.         BEGIN einstr[pos]:=chr(0);
  532.           WriteC('Error: ');
  533.           WriteC(einstr);
  534.           WriteC(LF)
  535.          END;
  536.       c:=chr(0); err:=true
  537.     END;
  538.  
  539.   PROCEDURE Summe(Var s:p);
  540.     VAR t:p;
  541.  
  542.     PROCEDURE Term(Var h: p);
  543.       VAR z, hlp:atyp; g:p; c1:char; num:integer;
  544.  
  545.       PROCEDURE Parameter;
  546.         BEGIN
  547.           iF c='(' THEN
  548.             BEGIN
  549.               get;
  550.               Summe(h^.op1);
  551.               IF c<>')' THEN Fehler;
  552.               get
  553.             END
  554.           ELSE
  555.             term(h^.op1)
  556.         END;
  557.  
  558.       PROCEDURE Fun(n:char);
  559.         BEGIN
  560.           h:=Neu(funktion);
  561.           h^.name:=n;
  562.           get;
  563.           Parameter
  564.         END;
  565.  
  566.       BEGIN   { Term }
  567.         h:=NIL;
  568.         IF c='x' THEN
  569.           BEGIN h:=Neu(variable); h^.name:='x'; get END
  570.         ELSE
  571.         IF ((c>='0') AND (c<='9')) or (c='.') THEN
  572.           BEGIN
  573.             z:=0;
  574.             WHILE (c>='0') And (c<='9') DO
  575.               BEGIN
  576.                 z:=round(10*z+ord(c)-ord('0'));
  577.                 gts
  578.               End;
  579.             h:=Neu(literal);
  580.             IF c='.' THEN
  581.               BEGIN gts; hlp:=1;
  582.                 WHILE (c>='0') AND (c<='9') DO
  583.                   BEGIN
  584.                     hlp:=hlp/10;
  585.                     z:=z+hlp*round(ord(c)-ord('0'));
  586.                     gts
  587.                   END
  588.               END;
  589.             IF c='e' THEN
  590.               BEGIN gts;
  591.                 IF c='-' THEN
  592.                   BEGIN gts; num:=getnum(tx,c); z:=z*pwr10(-num) END
  593.                 ELSE
  594.                   BEGIN
  595.                     IF c='+' THEN gts;
  596.                     num:=getnum(tx,c); z:=z*dbpwr10(num)
  597.                   END
  598.               END;
  599.             IF c=' ' THEN get;
  600.             h^.value:=z
  601.           END
  602.         ELSE
  603.         If c='(' Then
  604.           Begin get;
  605.             Summe(h);
  606.             If c<>')' Then Fehler;
  607.             get
  608.           End
  609.         ELSE
  610.         IF c='|' THEN
  611.           BEGIN
  612.             get;
  613.             Summe(g);
  614.             IF c<>'|' THEN Fehler;
  615.             get;
  616.             h := Neu( Funktion );
  617.             h^.name := '+';
  618.             h^.op1 := g
  619.           END
  620.         Else
  621.         If c='-' Then Fun('-')
  622.         Else
  623.         If c='a' Then
  624.           Begin gts;
  625.             If c='r' Then
  626.               Begin gts;
  627.                 If c='c' Then
  628.                   Begin gts;
  629.                     If c='c' Then
  630.                       Begin gts;
  631.                         If c='o' Then
  632.                           Begin gts;
  633.                             If c='s' Then Fun('C')        { arccos }
  634.                             Else
  635.                             If c='t' Then Fun('O')        { arccot }
  636.                             Else Fehler
  637.                           End
  638.                         Else Fehler
  639.                       End
  640.                     Else
  641.                     If c='s' Then
  642.                       Begin gts;
  643.                         If c='i' Then
  644.                           Begin gts;
  645.                             If c='n' Then Fun('S') Else Fehler { arcsin }
  646.                           End
  647.                         Else Fehler
  648.                       End
  649.                     Else
  650.                     If c='t' Then
  651.                       Begin gts;
  652.                         If c='a' Then
  653.                           Begin gts;
  654.                             If c='n' Then Fun('T') Else Fehler { arctan }
  655.                           End
  656.                         Else Fehler
  657.                       End
  658.                     Else Fehler
  659.                   End
  660.                 Else Fehler
  661.               End
  662.             Else
  663.             If c='b' Then
  664.               Begin gts;
  665.                 If c='s' Then Fun('+') Else Fehler         { abs }
  666.               End
  667.             Else                                           { a }
  668.               BEGIN
  669.                 num:=getnum(tx,c);
  670.                 h:=Neu(literal);
  671.                 h^.value:=v['a',num]
  672.               END
  673.           End
  674.         Else
  675.         IF c='b' THEN                                      { b }
  676.           BEGIN
  677.             get; num:=getnum(tx,c);
  678.             h:=neu(literal);
  679.             h^.value:=v['b',num]
  680.           END
  681.         ELSE
  682.         If c='c' Then
  683.           Begin gts;
  684.             If c='o' Then
  685.               Begin gts;
  686.                 If c='s' Then Fun('c')              { cos }
  687.                 ELSE
  688.                   IF c='t' THEN Fun('o')            { cot }
  689.                   Else Fehler
  690.               End
  691.             ELSE
  692.               BEGIN                                  { c }
  693.                 num:=getnum(tx,c);
  694.                 h:=Neu(literal);
  695.                 h^.value:=v['c',num]
  696.               END
  697.           END
  698.         ELSE
  699.         IF c='d' THEN
  700.           BEGIN
  701.             get;
  702.             num:=getnum(tx,c);
  703.             h:=Neu(literal);
  704.             h^.value:=v['d',num]
  705.           END
  706.         ELSE
  707.         If c='e' Then
  708.           Begin gts;
  709.             If c='x' Then
  710.               Begin gts;
  711.                 If c='p' Then Fun('e') Else Fehler   { exp }
  712.               End
  713.             Else
  714.               Begin                                  {  e  }
  715.                 h:=Neu(variable);
  716.                 h^.name:='e';
  717.                 If c=' ' Then get
  718.               End
  719.           End
  720.         ELSE
  721.         IF (c>='f') AND (c<='h') THEN       { f, g, h }
  722.           BEGIN
  723.             c1:=c; gts; num:=Getnum(tx,c);
  724.             IF f[c1,num]=NIL THEN Fehler
  725.             ELSE
  726.               BEGIN
  727.                 h:=copy(f[c1,num]);
  728.                 WHILE c='''' DO
  729.                   BEGIN
  730.                     get;
  731.                     g:=h;
  732.                     h:=diff(g);
  733.                     Forget(g)
  734.                   END;
  735.                 IF c=' ' THEN get;
  736.                 IF c='(' THEN
  737.                   BEGIN get;
  738.                     Summe(g);
  739.                     Subst(g,h);
  740.                     IF c<>')' THEN Fehler;
  741.                     get;
  742.                     Forget(g)
  743.                   END
  744.               END
  745.           END
  746.         ELSE
  747.         IF c='l' THEN
  748.           BEGIN gts;
  749.             IF c='n' THEN Fun('l')
  750.             ELSE
  751.             IF c='g' THEN Fun('g')
  752.             ELSE Fehler
  753.           END
  754.         ELSE
  755.         IF c='p' THEN
  756.           BEGIN gts;
  757.             IF c='i' THEN
  758.               BEGIN                                   { pi }
  759.                 h:=Neu(variable);
  760.                 h^.name:='p';
  761.                 get
  762.               End
  763.             Else Fehler
  764.           End
  765.         Else
  766.         If c='s' Then
  767.           Begin gts;
  768.             If c='i' Then
  769.               Begin gts;
  770.                 If c='n' Then Fun('s') Else Fehler   { sin }
  771.               End
  772.             Else
  773.             If c='g' Then
  774.               Begin gts;
  775.                 If c='n' Then Fun('v') Else Fehler    { sgn }
  776.               End
  777.             Else
  778.             If c='q' Then
  779.               Begin gts;
  780.                 If c='r' Then
  781.                   Begin get;
  782.                     If c='t' Then Fun('r')         { sqrt }
  783.                      Else
  784.                       Begin
  785.                         h:=Neu(funktion);          { sqr }
  786.                         h^.name:='q';
  787.                         Parameter
  788.                       End
  789.                   End
  790.                 Else Fehler
  791.               End
  792.             Else Fehler
  793.           End
  794.         ELSE
  795.         IF c='t' THEN
  796.           BEGIN gts;
  797.             IF c='a' THEN
  798.               BEGIN gts;
  799.                 IF c='n' THEN Fun('t')
  800.                 ELSE Fehler
  801.               END
  802.             ELSE Fehler
  803.           END
  804.  
  805.         ELSE Fehler;
  806.         IF c='^' THEN
  807.           BEGIN
  808.             get;
  809.             g:=neu(operator);
  810.             g^.name:='^';
  811.             g^.op1:=h;
  812.             h:=g;
  813.             Term(h^.op2)
  814.           End;
  815.         If (c>='a') and (c<='z') Or (c='(') Then
  816.           Begin
  817.             g:=Neu(operator);
  818.             g^.op1:=h;
  819.             h:=g;
  820.             h^.name:='*';
  821.             Term(h^.op2)
  822.           End
  823.       End;
  824.  
  825.     Procedure Produkt(Var h:p);
  826.       Var hp:p;
  827.       Begin
  828.         Term(h);
  829.         While (c='*') Or (c='/') Do
  830.           Begin
  831.             hp:=Neu(operator);
  832.             hp^.name:=c;
  833.             hp^.op1:=h;
  834.             get;
  835.             Term(hp^.op2);
  836.             h:=hp
  837.           End
  838.       End;
  839.  
  840.     BEGIN { Summe }
  841.       Produkt(s);
  842.       WHILE (c='+') OR (c='-') DO
  843.         BEGIN
  844.           t:=Neu(operator);
  845.           t^.name:=c;
  846.           t^.op1:=s;
  847.           get;
  848.           Produkt(t^.op2);
  849.           s:=t
  850.         END
  851.     END;
  852.  
  853.   BEGIN { Inp }
  854.     i:=Nil; err:=false; pos:=1;
  855.     get;
  856.     Summe(i);
  857.     IF err THEN Forget(i)
  858.   END;
  859.  
  860. PROCEDURE ReadKonst; { globale Funktion: (VAR r:atyp; Var err:boolean); EXPORT }
  861.   VAR f:p;
  862.       t:Buffer;
  863.   BEGIN
  864.     ReadEin(t);
  865.     Inp(t,f);
  866.     IF not konstant(f) Then
  867.       Begin
  868.         writeC('not konstant.'\n);
  869.         forget(f)
  870.       End;
  871.     err:=f=Nil;
  872.     If not err then
  873.       BEGIN
  874.         everr:=false;
  875.         r:=eval(f,0);
  876.         err:=everr
  877.       END
  878.   END;
  879.  
  880. PROCEDURE GetC; { globale Funktion }
  881.   BEGIN REPEAT c:=Ein.s[Ein.p]; Ein.p := Ein.p+1 UNTIL c<>' ' END;
  882.  
  883.  
  884.