Turbo Toolbox/Turbo_Toolbox.iso/spezial/04/quellen/calcderi.pas

Pascal/Delphi Source File | 1979-12-31 | 16.6 KB | 463 lines

(*****************************************************************************)
(*                               CACLDERI.PAS                                *)
(*                                                                           *)
(*                     Symbolisches Differenzieren mit Calc                  *)
(*****************************************************************************)


FUNCTION calcderivation(pptr : calc_prog; vartab : calc_vartab; nach :
                          calc_idstr) : calc_prog;

CONST pi_durch_180 = 1.745329252e-2;

VAR pptrstart,pptr1 : calc_prog;
    ok : boolean;

  PROCEDURE uppercase(VAR varid : calc_idstr);

  VAR i : INTEGER;

  BEGIN
    FOR i := 1 TO Length(varid) DO
      varid[i] := Upcase(varid[i])
  END;

  PROCEDURE newconst(x : calc_operand);

  VAR pptr : calc_prog;

  BEGIN
    IF heapavail > 160
      THEN
        BEGIN
          New(pptr);
          pptr^.instruct := calc_const;
          pptr^.operand := x;
          pptr^.nextinst := pptrstart^.nextinst;
          pptrstart^.nextinst := pptr
        END
      ELSE
        calcresult := FALSE
  END;

  PROCEDURE newop(id : calc_symbols);

  VAR pptr : calc_prog;

  BEGIN
    IF heapavail > 160
      THEN
        BEGIN
          New(pptr);
          pptr^.instruct := id;
          pptr^.nextinst := pptrstart^.nextinst;
          pptrstart^.nextinst := pptr;
        END
      ELSE
        calcresult := FALSE
  END;

  PROCEDURE push(pptr : calc_prog);

  VAR pptr1 : calc_prog;
      op : INTEGER;

  BEGIN
    op := 1;
    REPEAT
      IF heapavail > 160
        THEN
          BEGIN
            IF pptr^.instruct IN [calc_add..calc_pow]
              THEN
                op := op + 1
              ELSE
                IF NOT (pptr^.instruct IN [calc_neg,calc_sqr..calc_fak])
                  THEN
                    op := op - 1;
            New(pptr1);
            pptr1^ := pptr^;
            pptr1^.nextinst := pptrstart^.nextinst;
            pptrstart^.nextinst := pptr1;
            pptr := pptr^.nextinst
          END
        ELSE
          calcresult := FALSE
    UNTIL (op = 0) OR NOT calcresult;
  END;
{$a-}

  PROCEDURE derive(pptr : calc_prog);

  VAR pptra,pptrb : calc_prog;

  BEGIN
    IF calcresult
      THEN
        BEGIN
          pptra := pptr^.nextinst;
          IF (pptra <> nil)
            THEN
              BEGIN
                pptrb := endof(pptra);
                pptrb := pptrb^.nextinst
              END;
          CASE pptr^.instruct OF
            calc_neg   : BEGIN
                           newop(calc_neg);
                           derive(pptra)
                         END;
            calc_const,calc_div..calc_kgv,calc_fak : BEGIN
                                                      newconst(0.0);
                                                     END;
            calc_var  : BEGIN
                          IF nach = vartab^[pptr^.varindex].varid
                            THEN
                              newconst(1.0)
                            ELSE
                              newconst(0.0);
                        END;
            calc_add  : BEGIN
                          IF calc_const IN[pptra^.instruct,pptrb^.instruct]
                            THEN
                              IF pptra^.instruct = calc_const
                                THEN
                                  derive(pptrb)
                                ELSE
                                  derive(pptra)
                            ELSE
                              BEGIN
                                newop(calc_add);
                                derive(pptra);
                                derive(pptrb)
                              END
                        END;
            calc_sub  : BEGIN
                          IF calc_const IN [pptra^.instruct,pptrb^.instruct
                              ]
                            THEN
                              IF pptra^.instruct = calc_const
                                THEN
                                  derive(pptrb)
                                ELSE
                                  BEGIN
                                    newop(calc_neg);
                                    derive(pptra)
                                  END
                            ELSE
                              BEGIN
                                newop(calc_sub);
                                derive(pptra);
                                derive(pptrb)
                              END
                        END;
            calc_mul : BEGIN
                         IF calc_const IN [pptra^.instruct,pptrb^.instruct]
                           THEN
                             IF pptra^.instruct = calc_const
                               THEN
                                 BEGIN
                                   newop(calc_mul);
                                   push(pptra);
                                   derive(pptrb)
                                 END
                               ELSE
                                 BEGIN
                                   newop(calc_mul);
                                   push(pptrb);
                                   derive(pptra)
                                 END
                           ELSE
                             BEGIN
                               newop(calc_add);
                               newop(calc_mul);
                               derive(pptra);
                               push(pptrb);
                               newop(calc_mul);
                               push(pptra);
                               derive(pptrb);
                             END
                       END;
            calc_dvd : BEGIN
                         IF pptra^.instruct = calc_const
                           THEN
                             BEGIN
                               newop(calc_dvd);
                               push(pptra);
                               derive(pptrb)
                             END
                           ELSE
                             BEGIN
                               newop(calc_dvd);
                               newop(calc_sqr);
                               push(pptra);
                               newop(calc_sub);
                               newop(calc_mul);
                               derive(pptra);
                               push(pptrb);
                               newop(calc_mul);
                               push(pptra);
                               derive(pptrb)
                             END
                       END;
            calc_pow  : BEGIN
                          if (pptrb^.instruct = calc_const)
                           and (pptrb^.operand < 0.0)
                                  THEN calcresult := false
                              ELSE
                              BEGIN
                          ok := false;
                          case pptra^.instruct of
                            calc_const : ok := true;
                            calc_var   : ok := nach <> vartab^[pptra^.varindex].varid
                          end;
                          IF ok
                            THEN
                              BEGIN
                                newop(calc_mul);
                                newop(calc_mul);
                                newop(calc_pow);
                                newop(calc_sub);
                                newconst(1.0);
                                push(pptra);
                                push(pptrb);
                                push(pptra);
                                derive(pptrb)
                              END
                            ELSE
                              BEGIN
                                newop(calc_mul);
                                newop(calc_pow);
                                push(pptra);
                                push(pptrb);
                                newop(calc_add);
                                newop(calc_dvd);
                                push(pptrb);
                                newop(calc_mul);
                                push(pptra);
                                derive(pptrb);
                                newop(calc_mul);
                                derive(pptra);
                                newop(calc_ln);
                                push(pptrb)
                              END
                              END
                        END;
            calc_abs  : BEGIN
                          newop(calc_mul);
                          newop(calc_sig);
                          push(pptra);
                          derive(pptra)
                        END;
            calc_int,calc_sig  : newconst(0.0);
            calc_sqr  : BEGIN
                          newop(calc_mul);
                          newop(calc_mul);
                          push(pptra);
                          derive(pptra);
                          newconst(2.0);
                        END;
            calc_sqrt : BEGIN
                          newop(calc_dvd);
                          newop(calc_mul);
                          newconst(2.0);
                          newop(calc_sqrt);
                          push(pptra);
                          derive(pptra);
                        END;
            calc_exp  : BEGIN
                          newop(calc_mul);
                          newop(calc_exp);
                          push(pptra);
                          derive(pptra);
                        END;
            calc_ln  : BEGIN
                         newop(calc_dvd);
                         push(pptra);
                         derive(pptra)
                       END;
            calc_lg : BEGIN
                        newop(calc_dvd);
                        newop(calc_mul);
                        newop(calc_ln);
                        newconst(10.0);
                        push(pptra);
                        derive(pptra)
                      END;
            calc_ld : BEGIN
                        newop(calc_dvd);
                        newop(calc_mul);
                        newop(calc_ln);
                        newconst(2.0);
                        push(pptra);
                        derive(pptra)
                      END;
            calc_sin : BEGIN
                         newop(calc_mul);
                         newop(calc_cos);
                         push(pptra);
                         derive(pptra);
                       END;
            calc_cos : BEGIN
                         newop(calc_mul);
                         newop(calc_neg);
                         newop(calc_sin);
                         push(pptra);
                         derive(pptra);
                       END;
            calc_tan : BEGIN
                         newop(calc_dvd);
                         newop(calc_sqr);
                         newop(calc_cos);
                         push(pptra);
                         derive(pptra);
                       END;
            calc_cot : BEGIN
                         newop(calc_neg);
                         newop(calc_dvd);
                         newop(calc_sqr);
                         newop(calc_sin);
                         push(pptra);
                         derive(pptra);
                       END;
            calc_arcsin : BEGIN
                            newop(calc_dvd);
                            newop(calc_sqrt);
                            newop(calc_sub);
                            newop(calc_sqr);
                            push(pptra);
                            newconst(1.0);
                            derive(pptra);
                          END;
            calc_arccos : BEGIN
                            newop(calc_neg);
                            newop(calc_dvd);
                            newop(calc_sqrt);
                            newop(calc_sub);
                            newop(calc_sqr);
                            push(pptra);
                            newconst(1.0);
                            derive(pptra);
                          END;
            calc_arctan : BEGIN
                            newop(calc_dvd);
                            newop(calc_add);
                            newop(calc_sqr);
                            push(pptra);
                            newconst(1.0);
                            derive(pptra);
                          END;
            calc_arccot : BEGIN
                            newop(calc_neg);
                            newop(calc_dvd);
                            newop(calc_add);
                            newop(calc_sqr);
                            push(pptra);
                            newconst(1.0);
                            derive(pptra);
                          END;
            calc_sinh  : BEGIN
                           newop(calc_mul);
                           newop(calc_cosh);
                           push(pptra);
                           derive(pptra)
                         END;
            calc_cosh  : BEGIN
                           newop(calc_mul);
                           newop(calc_sinh);
                           push(pptra);
                           derive(pptra)
                         END;
            calc_tanh  : BEGIN
                           newop(calc_dvd);
                           newop(calc_sqr);
                           newop(calc_cosh);
                           push(pptra);
                           derive(pptra)
                         END;
            calc_coth  : BEGIN
                           newop(calc_neg);
                           newop(calc_dvd);
                           newop(calc_sqr);
                           newop(calc_sinh);
                           push(pptra);
                           derive(pptra)
                         END;
            calc_arcsinh : BEGIN
                             newop(calc_dvd);
                             newop(calc_sqrt);
                             newop(calc_add);
                             newconst(1.0);
                             newop(calc_sqr);
                             push(pptra);
                             derive(pptra)
                           END;
            calc_arccosh : BEGIN
                             newop(calc_dvd);
                             newop(calc_sqrt);
                             newop(calc_sub);
                             newconst(1.0);
                             newop(calc_sqr);
                             push(pptra);
                             derive(pptra)
                           END;
            calc_arctanh,calc_arccoth : BEGIN
                                          newop(calc_dvd);
                                          newop(calc_sub);
                                          newop(calc_sqr);
                                          push(pptra);
                                          newconst(1.0);
                                          derive(pptra)
                                        END;
            calc_deg     : BEGIN
                             newop(calc_dvd);
                             newconst(pi_durch_180);
                             derive(pptra)
                           END;
            calc_rad     : BEGIN
                             newop(calc_mul);
                             newconst(pi_durch_180);
                             derive(pptra)
                           END;
            ELSE
              calcresult := FALSE
          END;
        END
  END;
{$a+}

BEGIN
  IF pptr <> nil
    THEN
      BEGIN
        uppercase(nach);
        invert(pptr);
        pptr1 := pptr;
        New(pptrstart);
        pptrstart^.nextinst := nil;
        pptr := pptr^.nextinst;
        calcresult := TRUE;
        derive(pptr);
        IF calcresult
          THEN
            BEGIN
              calcsimplify(pptrstart);
              calcderivation := pptrstart
            END
          ELSE
            BEGIN
              killexpression(pptrstart);
              calcderivation := nil;
              CalcError(4,'Die Ableitung der Funktion kann'+
                          ' nicht ermittelt werden');
            END;
        invert(pptr1);
      END
    ELSE
      BEGIN
        calcderivation := nil;
        CalcResult := FALSE
      END
END;