diffexpress.pas

delphi 計算用第三方 控件

//==============================================================================
// Product name: DiffExpress
// Copyright 2000-2001 AidAim Software.
// Description:
//  DiffExpress provides an easy way to use symbolic differentiation
//  of mathematical expressions in your applications.
//  Supports 5 operators, parenthesis, 18 mathematical functions and
//  user-defined variables.
// Version: 1.4
// Date: 11/24/2000
//==============================================================================
unit DiffExpress;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, math;

const 
  MaxIndex = 5000;

type


  TTree = record
    num: integer;
    con: string;
    l, r: integer;
  end;

  PTree = integer;

  TDiffExpress = class(TComponent)
  private
    t: array[1..MaxIndex] of TTree;
    index: integer;
    FFormula: string;

    DVar: string;
    Err: boolean;
    Bc: integer;
    PrevLex, Curlex: integer;
    Pos: integer;
    Tree, Tree2: integer;
    function gettree(s: string): integer;
    procedure deltree;
    function getformula(_t: integer): string;
    function getformula2(_t: integer): string;
    function simplify(_t: integer): integer;
    procedure Error(s: string);
  public
    constructor Create(o: TComponent); override;
    destructor Destroy; override;
    function diff(v: string): string;
  published
    property Formula: string read FFormula write FFormula;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TDiffExpress]);
end;

//*********************************************************************
procedure TDiffExpress.Error(s: string);
begin
  Err := True;
  raise Exception.Create(s);
end;
//*********************************************************************
constructor TDiffExpress.Create(o: TComponent);
begin
  inherited;
  index := 0;
  Tree := 0;
  Tree2 := 0;
  Dvar := 't';
  Formula := '0';
end;
//*********************************************************************
destructor TDiffExpress.Destroy;
begin
  DelTree;
  //DelTree(Tree2);
  inherited;
end;

//***************************************************************

function TDiffExpress.GetTree(s: string): integer;
  //Get number from string
  function getnumber(s: string): string;
  begin
    Result := '';
    try
      //Beginning
      while (pos <= length(s)) and (s[pos] in ['0'..'9']) do
      begin
        Result := Result + s[pos];
        inc(pos);
      end;
      if pos > length(s) then exit;
      if s[pos] = '.' then
      begin
        //Fraction part
        Result := Result + '.';
        inc(pos);
        if (pos > length(s)) or not (s[pos] in ['0'..'9']) then Error('Wrong number.');
        while (pos <= length(s)) and
          (s[pos] in ['0'..'9']) do
        begin
          Result := Result + s[pos];
          inc(pos);
        end;
      end;
      if pos > length(s) then exit;
      //Power
      if (s[pos] <> 'e') and (s[pos] <> 'E') then exit;
      Result := Result + s[pos];
      inc(pos);
      if pos > length(s) then Error('Wrong number.');
      if s[pos] in ['-', '+'] then
      begin
        Result := Result + s[pos];
        inc(pos);
      end;
      if (pos > length(s)) or not (s[pos] in ['0'..'9']) then Error('Wrong number.');
      while (pos <= length(s)) and
        (s[pos] in ['0'..'9']) do
      begin
        Result := Result + s[pos];
        inc(pos);
      end;
    except
    end;
  end;
  //Read lexem from string
  procedure getlex(s: string; var num: integer; var con: string);
  begin
    con := '';
    //Skip spaces
    while (pos <= length(s)) and (s[pos] = ' ') do inc(pos);
    if pos > length(s) then 
    begin 
      num := 0;  
      exit; 
    end;

    case s[pos] of
      '(': num := 1;
      ')': num := 2;
      '+': num := 3;
      '-': 
      begin
        num := 4;
        if (pos < length(s)) and (s[pos + 1] in ['1'..'9', '0']) and (curlex in [0,1]) then
        begin
          inc(pos);
          con := '-' + getnumber(s);
          dec(pos);
          num := 7;
        end;
      end;
      '*': num := 5;
      '/': num := 6;
      '^': num := 31;
      'a'..'z', 'A'..'Z', '_':
      begin
        while (pos <= length(s)) and
          (s[pos] in ['a'..'z', 'A'..'Z', '_', '1'..'9', '0']) do
        begin
          con := con + s[pos];
          inc(pos);
        end;
        dec(pos);
        num := 8;
        if con = 'cos' then num := 10;
        if con = 'sin' then num := 11;
        if con = 'tg' then num := 12;
        if con = 'ctg' then num := 13;
        if con = 'abs' then num := 14;
        if (con = 'sgn') or (con = 'sign') then num := 15;
        if con = 'sqrt' then num := 16;
        if con = 'ln' then num := 17;
        if con = 'exp' then num := 18;
        if con = 'arcsin' then num := 19;
        if con = 'arccos' then num := 20;
        if con = 'arctg' then num := 21;
        if con = 'arcctg' then num := 22;
        if con = 'sh' then num := 23;
        if con = 'ch' then num := 24;
        if con = 'th' then num := 25;
        if con = 'cth' then num := 26;
        if (con = 'heaviside') or (con = 'h') then num := 27;
      end;
      '1'..'9', '0':
      begin
        con := getnumber(s);
        dec(pos);
        num := 7;
      end;
    end;
    inc(pos);
    PrevLex := CurLex;
    CurLex := num;
  end;

  //****************************************************************
var 
  neg: boolean;
  l, r, res: integer;
  n, op: integer;
  c: string;
  //****************************************************************
  function newnode: integer;
  begin
    Index := Index +1;
    if Index > MaxIndex then
    begin
      index := 0;
      Error('Too long formula');
    end;
    Result := Index;
    t[index].l := 0;
    t[index].r := 0;
  end;

  function getsingleop: integer;
  var 
    op, bracket: integer;
    opc: string;
    l, r, res: integer;
  begin
    //l:=0;
    try
      if n = 1 then 
      begin 
        inc(bc); 
        l := gettree(s); 
      end
      else
      begin
        // First operand
        if not (n in [7,8,10..30]) then Error('');
        op := n;
        opc := c;
        if n in [7,8] then
        begin
          // Number or variable
          l := newnode; 
          t[l].num := op; 
          t[l].con := opc;
        end 
        else
        begin
          //Function
          getlex(s, n, c);
          if n <> 1 then Error('');
          inc(bc);
          l := newnode;
          t[l].l := gettree(s); 
          t[l].num := op; 
          t[l].con := opc;
        end;
      end;
      //Operation symbol
      getlex(s, n, c);
      //Power symbol
      while n = 31 do
        begin
          getlex(s, n, c);
        bracket := 0;
        if n = 1 then  
        begin   
          bracket := 1;   
          getlex(s, n, c);   
        end;
        if n <> 7 then Error('');
        r := newnode; 
        t[r].num := n; 
        t[r].con := c;
        res := newnode; 
        t[res].l := l; 
        t[res].r := r; 
        t[res].num := 31; 
        l := res;
        if bracket = 1 then
        begin
          getlex(s, n, c);
          if n <> 2 then Error('');
        end;
        getlex(s, n, c);
      end;
      Result := l;
    except
      //DelTree(l);
      Result := 0;
    end;
  end;
  //****************************************************************
  function getop: integer;
  var 
    op: integer;
    l, r, res: integer;
  begin
    neg := False;
    getlex(s, n, c);
    // Unary - or +
    if prevlex in [0,1] then
    begin
      if n = 4 then  
      begin  
        neg := True; 
        getlex(s, n, c);  
      end;
      if n = 3 then getlex(s, n, c);
    end;
    l := getsingleop;
    // 2nd operand **************
    while n in [5,6] do
    begin
      op := n;
      getlex(s, n, c);
      r := getsingleop;
      res := newnode; 
      t[res].l := l; 
      t[res].r := r; 
      t[res].num := op;
      l := res;
    end;
    // Unary minus
    if neg then
    begin
      res := newnode; 
      t[res].l := l; 
      t[res].r := 0; 
      t[res].num := 9;
      l := res;
    end;
    Result := l;
  end;

  //****************************************************************
begin
  //l:=0;
  try
    l := getop;
    while True do
    begin
      if n in [0,2] then
      begin
        if n = 2 then dec(bc);
        Result := l; 
        exit;
      end;
      if not (n in [3,4]) then Error('');
      op := n;
      r := getop;
      res := newnode; 
      t[res].l := l; 
      t[res].r := r; 
      t[res].num := op;
      l := res;
    end;
    Result := l;
  except
    //DelTree(l);
    Result := 0;
  end;
end;


//Deletion tree

procedure TDiffExpress.deltree;
begin
  Index := 0;
end;

//****************************************************************

// Tree simplification