Программа выводящая график функции в полярных координатах

Программа выводящая график функции в полярных координатах На днях ребёнку в школе задали задание по графикам функций, при отсутствии под рукой готовых програм нацарапал своё приложение, причём приложение написано "двумя пальцами", т.е. без каких-либо украшательств, не очень красивым кодом и без комментариев - простая програмка, написаннная за 15 минут. clip0087 Вот исходники:

unit PMain;
{©Drkb v.3(2007): <a href="http://www.drkb.ru" title="www.drkb.ru">www.drkb.ru</a>,
 ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}

interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls, CustomizeDlg, ExtCtrls, Tabs, Menus;
type
 TForm1 = class(TForm)
  Panel1: TPanel;
  Button1: TButton;
  Edit1: TEdit;
  Label1: TLabel;
  Panel2: TPanel;
  Label3: TLabel;
  Edit2: TEdit;
  Label4: TLabel;
  Edit3: TEdit;
  Label5: TLabel;
  Edit4: TEdit;
  Label6: TLabel;
  Edit5: TEdit;
  Edit6: TEdit;
  Label7: TLabel;
  Edit7: TEdit;
  Label8: TLabel;
  Edit8: TEdit;
  Label9: TLabel;
  Edit9: TEdit;
  Label10: TLabel;
  Edit10: TEdit;
  Label11: TLabel;
  Edit11: TEdit;
  Label12: TLabel;
  Edit12: TEdit;
  Label13: TLabel;
  Label14: TLabel;
  Edit13: TEdit;
  procedure FormPaint(Sender: TObject);
  procedure Panel2MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
  procedure Edit3KeyPress(Sender: TObject; var Key: Char);
  procedure Edit2KeyPress(Sender: TObject; var Key: Char);
  procedure Edit1KeyPress(Sender: TObject; var Key: Char);
  procedure Button3Click(Sender: TObject);
  procedure Button2Click(Sender: TObject);
  procedure Button1Click(Sender: TObject);
 private
  procedure DrawFunction(FormulaText:string; Cl:TColor);
  function GetValue(FormulaText:string; x: real): real;
  procedure SetupAxes;
  { Private declarations }
 public
  { Public declarations }
 end;
var
 Form1: TForm1;
implementation
uses math, parsing;
{$R *.dfm}
Function TForm1.GetValue(FormulaText:string; x:real):real;
begin
 Result:=GetFormulaValue(StringReplace(FormulaText, 'x', floattostr(x),[rfReplaceAll, rfIgnoreCase]));
end;
procedure TForm1.Panel2MouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 ReleaseCapture;
 Panel1.perform(WM_SysCommand, $F012, 0);
end;
procedure TForm1.SetupAxes;
 var point:TPoint;
  i:integer;
begin
 {Draw axis X}
 Canvas.Pen.Width:=2;
 Canvas.Pen.Color:=clBlue;
 Point.X:=0;
 Point.Y:=(height div 2);
 canvas.PenPos:=Point;
 Canvas.LineTo(width, height div 2);
 Point.X:=width div 2;
 Point.Y:=0;
 canvas.PenPos:=Point;
 Canvas.LineTo(width div 2, height);

end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 Invalidate;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
 Invalidate;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
 Invalidate;
end;
Procedure TForm1.DrawFunction(FormulaText:string; Cl:TColor);
 var i:integer;
  j:real;
  P:real;
  x1, x2, x0:real;
  W:integer;
  k:real;
  point:TPoint;
  error:boolean;
  prev, value:integer;
begin
 if FormulaText='' then exit;
 SetupAxes;
 Canvas.Pen.Color:=cl;
 Canvas.Pen.Style:= psSolid;
 Canvas.Pen.Width:=2;
 {setup first point}
 try
  Point.X:=round(GetValue(FormulaText,degtorad(strtointdef(Edit2.text,0)))*cos(degtorad(strtointdef(Edit2.text,0)))*strtointdef(Edit13.Text, 20));
  Point.Y:=round(GetValue(FormulaText,degtorad(strtointdef(Edit2.text,0)))*sin(degtorad(strtointdef(Edit2.text,0)))*strtointdef(Edit13.Text, 20));
  Point.X:=Point.X+(width div 2);
  Point.Y:=(height div 2)-Point.Y;
  Canvas.PenPos:=Point;
 except
 end;
 for I := strtointdef(Edit2.text,0) to strtointdef(Edit3.text,3600) do
  try
  Point.X:=round(GetValue(FormulaText,degtorad(i))*cos(degtorad(i))*strtointdef(Edit13.Text, 20));
  Point.Y:=round(GetValue(FormulaText,degtorad(i))*sin(degtorad(i))*strtointdef(Edit13.Text, 20));
  Point.X:=Point.X+(width div 2);
  Point.Y:=(height div 2)-Point.Y;
  Canvas.LineTo(Point.X,Point.Y);
  Canvas.PenPos:=Point;
  application.ProcessMessages;
  except
  end;
end;

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
 if key=#13 then Invalidate;
end;
procedure TForm1.Edit2KeyPress(Sender: TObject; var Key: Char);
begin
 if key=#13 then Invalidate;
end;
procedure TForm1.Edit3KeyPress(Sender: TObject; var Key: Char);
begin
 if key=#13 then Invalidate;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
 DrawFunction(Edit1.Text, clRed);
 DrawFunction(Edit4.Text, clGreen);
 DrawFunction(Edit5.Text, clFuchsia);
 DrawFunction(Edit6.Text, cllime);
 DrawFunction(Edit7.Text, claqua);
 DrawFunction(Edit8.Text, clnavy);
 DrawFunction(Edit9.Text, clyellow);
 DrawFunction(Edit10.Text, clolive);
 DrawFunction(Edit11.Text, clmaroon);
 DrawFunction(Edit12.Text, clblack);
end;
end.
object Form1: TForm1
 Left = 380
  = 200
 BorderIcons = [biSystemMenu, biMinimize]
 BorderStyle = bsSingle
 Caption = 'Formula Grapher (c) Vit, 2006'
 ClientHeight = 494
 ClientWidth = 771
 Color = clBtnFace
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = 'Tahoma'
 Font.Style = []
 OldCreateOrder = False
 Position = poScreenCenter
 OnPaint = FormPaint
 PixelsPerInch = 96
 TextHeight = 13
 object Panel1: TPanel
  Left = 24
   = 8
  Width = 185
  Height = 353
  TabOrder = 0
  object Label1: TLabel
  Left = 9
   = 27
  Width = 16
  Height = 16
  Caption = 'R='
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  end
  object Label3: TLabel
  Left = 9
   = 272
  Width = 51
  Height = 13
  Caption = 'min angle='
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  ParentFont = False
  end
  object Label4: TLabel
  Left = 9
   = 296
  Width = 54
  Height = 13
  Caption = 'max angle='
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  ParentFont = False
  end
  object Label5: TLabel
  Left = 9
   = 51
  Width = 16
  Height = 16
  Caption = 'R='
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  end
  object Label6: TLabel
  Left = 9
   = 75
  Width = 16
  Height = 16
  Caption = 'R='
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  end
  object Label7: TLabel
  Left = 9
   = 99
  Width = 16
  Height = 16
  Caption = 'R='
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  end
  object Label8: TLabel
  Left = 9
   = 123
  Width = 16
  Height = 16
  Caption = 'R='
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  end
  object Label9: TLabel
  Left = 9
   = 147
  Width = 16
  Height = 16
  Caption = 'R='
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  end
  object Label10: TLabel
  Left = 9
   = 171
  Width = 16
  Height = 16
  Caption = 'R='
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  end
  object Label11: TLabel
  Left = 9
   = 195
  Width = 16
  Height = 16
  Caption = 'R='
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  end
  object Label12: TLabel
  Left = 9
   = 219
  Width = 16
  Height = 16
  Caption = 'R='
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  end
  object Label13: TLabel
  Left = 9
   = 243
  Width = 16
  Height = 16
  Caption = 'R='
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  end
  object Label14: TLabel
  Left = 9
   = 320
  Width = 31
  Height = 13
  Caption = 'scale='
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  ParentFont = False
  end
  object Button1: TButton
  Left = 141
   = 317
  Width = 41
  Height = 25
  Caption = 'Draw'
  TabOrder = 13
  OnClick = Button1Click
  end
  object Edit1: TEdit
  Left = 31
   = 24
  Width = 148
  Height = 24
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clRed
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  TabOrder = 0
  OnKeyPress = Edit1KeyPress
  end
  object Panel2: TPanel
  Left = 1
   = 1
  Width = 183
  Height = 16
  Align = al
  Color = clNavy
  TabOrder = 14
  OnMouseDown = Panel2MouseDown
  end
  object Edit2: TEdit
  Left = 65
   = 269
  Width = 72
  Height = 24
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clRed
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  TabOrder = 10
  Text = '0'
  OnKeyPress = Edit1KeyPress
  end
  object Edit3: TEdit
  Left = 66
   = 293
  Width = 72
  Height = 24
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clRed
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  TabOrder = 11
  Text = '3600'
  OnKeyPress = Edit1KeyPress
  end
  object Edit4: TEdit
  Left = 31
   = 48
  Width = 148
  Height = 24
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clGreen
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  TabOrder = 1
  OnKeyPress = Edit1KeyPress
  end
  object Edit5: TEdit
  Left = 31
   = 72
  Width = 148
  Height = 24
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clFuchsia
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  TabOrder = 2
  OnKeyPress = Edit1KeyPress
  end
  object Edit6: TEdit
  Left = 31
   = 96
  Width = 148
  Height = 24
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clLime
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  TabOrder = 3
  OnKeyPress = Edit1KeyPress
  end
  object Edit7: TEdit
  Left = 31
   = 120
  Width = 148
  Height = 24
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clAqua
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  TabOrder = 4
  OnKeyPress = Edit1KeyPress
  end
  object Edit8: TEdit
  Left = 31
   = 144
  Width = 148
  Height = 24
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clNavy
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  TabOrder = 5
  OnKeyPress = Edit1KeyPress
  end
  object Edit9: TEdit
  Left = 31
   = 168
  Width = 148
  Height = 24
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clYellow
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  TabOrder = 6
  OnKeyPress = Edit1KeyPress
  end
  object Edit10: TEdit
  Left = 31
   = 192
  Width = 148
  Height = 24
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clOlive
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  TabOrder = 7
  OnKeyPress = Edit1KeyPress
  end
  object Edit11: TEdit
  Left = 31
   = 216
  Width = 148
  Height = 24
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clMaroon
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  TabOrder = 8
  OnKeyPress = Edit1KeyPress
  end
  object Edit12: TEdit
  Left = 31
   = 240
  Width = 148
  Height = 24
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clBlack
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  TabOrder = 9
  OnKeyPress = Edit1KeyPress
  end
  object Edit13: TEdit
  Left = 66
   = 317
  Width = 72
  Height = 24
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clRed
  Font.Height = -11
  Font.Name = 'Fixedsys'
  Font.Style = []
  ParentFont = False
  TabOrder = 12
  Text = '20'
  OnKeyPress = Edit1KeyPress
  end
 end
end

Для разбора математических выражений использовался модуль Parsing из RxLib:

{*******************************************************}

{ }

{ Delphi VCL Extensions (RX) }

{ }

{ Copyright (c) 1995, 1996 AO ROSNO }

{ Copyright (c) 1997, 1998 Master-Bank }

{ }

{*******************************************************}

unit Parsing;

interface

{ $I RX.INC}

uses SysUtils, Classes;

type

 TParserFunc = (pfArcTan, pfCos, pfSin, pfTan, pfAbs, pfExp, pfLn, pfLog,

  pfSqrt, pfSqr, pfInt, pfFrac, pfTrunc, pfRound, pfArcSin, pfArcCos,

  pfSign, pfNot);

 ERxParserError = class(Exception);

{$IFDEF WIN32}

 TUserFunction = function(Value: Extended): Extended;

{$ELSE}

 TUserFunction = Pointer;

{$ENDIF}

 TRxMathParser = class(TObject)

 private

  FCurPos: Cardinal;

  FParseText: string;

  function GetChar: Char;

  procedure Char;

  function GetNumber(var AValue: Extended): Boolean;

  function GetConst(var AValue: Extended): Boolean;

  function GetFunction(var AValue: TParserFunc): Boolean;

  function GetUserFunction(var Index: Integer): Boolean;

  function Term: Extended;

  function SubTerm: Extended;

  function Calculate: Extended;

 public

  function Exec(const AFormula: string): Extended;

  class procedure RegisterUserFunction(const Name: string; Proc: TUserFunction);

  class procedure UnregisterUserFunction(const Name: string);

 end;

function GetFormulaValue(const Formula: string): Extended;

{$IFNDEF WIN32}

function Power(Base, Exponent: Extended): Extended;

{$ENDIF}

implementation

//uses RxTConst;

uses dialogs;

const

 SpecialChars = [#0..' ', '+', '-', '/', '*', ')', '^'];

 FuncNames: array[TParserFunc] of PChar =

  ('ARCTAN', 'COS', 'SIN', 'TAN', 'ABS', 'EXP', 'LN', 'LOG',

  'SQRT', 'SQR', 'INT', 'FRAC', 'TRUNC', 'ROUND', 'ARCSIN', 'ARCCOS',

  'SIGN', 'NOT');

{ Parser errors }

procedure InvalidCondition(Str: String);

begin

 raise Exception.Create(Str);

end;

{ IntPower and Power functions are copied from Borland's MATH.PAS unit }

function IntPower(Base: Extended; Exponent: Integer): Extended;

{$IFDEF WIN32}

asm

  mov ecx, eax

  cdq

  fld1 { Result := 1 }

  xor  eax, edx

  sub eax, edx { eax := Abs(Exponent) }

  jz @@3

  fld Base

  jmp @@2

@@1: fmul ST, ST { X := Base * Base }

@@2: shr  eax,1

  jnc @@1

  fmul ST(1),ST { Result := Result * X }

  jnz @@1

  fstp st { pop X from FPU stack }

  cmp ecx, 0

  jge @@3

  fld1

  fdivrp { Result := 1 / Result }

@@3:

  fwait

end;

{$ELSE}

var

 Y: Longint;

begin

 Y := Abs(Exponent);

 Result := 1.0;

 while Y > 0 do begin

  while not Odd(Y) do begin

  Y := Y shr 1;

  Base := Base * Base;

  end;

  Dec(Y);

  Result := Result * Base;

 end;

 if Exponent < 0 then Result := 1.0 / Result;

end;

{$ENDIF WIN32}

function Power(Base, Exponent: Extended): Extended;

begin

 if Exponent = 0.0 then Result := 1.0

 else if (Base = 0.0) and (Exponent > 0.0) then Result := 0.0

 else if (Frac(Exponent) = 0.0) and (Abs(Exponent) <= MaxInt) then

  Result := IntPower(Base, Trunc(Exponent))

 else Result := Exp(Exponent * Ln(Base))

end;

{ User defined functions }

type

{$IFDEF WIN32}

 TFarUserFunction = TUserFunction;

{$ELSE}

 TFarUserFunction = function(Value: Extended): Extended;

{$ENDIF}

var

 UserFuncList: TStrings;

function GetUserFuncList: TStrings;

begin

 if not Assigned(UserFuncList) then begin

  UserFuncList := TStringList.Create;

  with TStringList(UserFuncList) do begin

  Sorted := True;

  Duplicates := dupIgnore;

  end;

 end;

 Result := UserFuncList;

end;

procedure FreeUserFunc; far;

begin

 UserFuncList.Free;

 UserFuncList := nil;

end;

{ Parsing routines }

function GetFormulaValue(const Formula: string): Extended;

begin

 with TRxMathParser.Create do

 try

  Result := Exec(Formula);

 finally

  Free;

 end;

end;

{ TRxMathParser }

function TRxMathParser.GetChar: Char;

begin

 Result := FParseText[FCurPos];

end;

procedure TRxMathParser.Char;

begin

 Inc(FCurPos);

end;

function TRxMathParser.GetNumber(var AValue: Extended): Boolean;

var

 C: Char;

 SavePos: Cardinal;

 Code: Integer;

 IsHex: Boolean;

 TmpStr: string;

begin

 Result := False;

 C := GetChar;

 SavePos := FCurPos;

 TmpStr := '';

 IsHex := False;

 if C = '$' then begin

  TmpStr := C;

  Char;

  C := GetChar;

  while C in ['0'..'9', 'A'..'F', 'a'..'f'] do begin

  TmpStr := TmpStr + C;

  Char;

  C := GetChar;

  end;

  IsHex := True;

  Result := (Length(TmpStr) > 1) and (Length(TmpStr) <= 9);

 end

 else if C in ['+', '-', '0'..'9', '.', DecimalSeparator] then begin

  if (C in ['.', DecimalSeparator]) then TmpStr := '0' + '.'

  else TmpStr := C;

  Char;

  C := GetChar;

  if (Length(TmpStr) = 1) and (TmpStr[1] in ['+', '-']) and

  (C in ['.', DecimalSeparator]) then TmpStr := TmpStr + '0';

  while C in ['0'..'9', '.', 'E', 'e', DecimalSeparator] do begin

  if C = DecimalSeparator then TmpStr := TmpStr + '.'

  else TmpStr := TmpStr + C;

  if (C = 'E') then begin

  if (Length(TmpStr) > 1) and (TmpStr[Length(TmpStr) - 1] = '.') then

  Insert('0', TmpStr, Length(TmpStr));

  Char;

  C := GetChar;

  if (C in ['+', '-']) then begin

  TmpStr := TmpStr + C;

  Char;

  end;

  end

  else Char;

  C := GetChar;

  end;

  if (TmpStr[Length(TmpStr)] = '.') and (Pos('E', TmpStr) = 0) then

  TmpStr := TmpStr + '0';

  Val(TmpStr, AValue, Code);

  Result := (Code = 0);

 end;

 Result := Result and (FParseText[FCurPos] in SpecialChars);

 if Result then begin

  if IsHex then AValue := StrToInt(TmpStr)

  { else AValue := StrToFloat(TmpStr) };

 end

 else begin

  AValue := 0;

  FCurPos := SavePos;

 end;

end;

function TRxMathParser.GetConst(var AValue: Extended): Boolean;

begin

 Result := False;

 case FParseText[FCurPos] of

  'E':

  if FParseText[FCurPos + 1] in SpecialChars then

  begin

  AValue := Exp(1);

  Inc(FCurPos);

  Result := True;

  end;

  'P':

  if (FParseText[FCurPos + 1] = 'I') and

  (FParseText[FCurPos + 2] in SpecialChars) then

  begin

  AValue := Pi;

  Inc(FCurPos, 2);

  Result := True;

  end;

 end

end;

function TRxMathParser.GetUserFunction(var Index: Integer): Boolean;

var

 TmpStr: string;

 I: Integer;

begin

 Result := False;

 if (FParseText[FCurPos] in ['A'..'Z', 'a'..'z', '_']) and

  Assigned(UserFuncList) then

 begin

  with UserFuncList do

  for I := 0 to Count - 1 do begin

  TmpStr := Copy(FParseText, FCurPos, Length(Strings[I]));

  if (CompareText(TmpStr, Strings[I]) = 0) and

  (Objects[I] <> nil) then

  begin

  if FParseText[FCurPos + Cardinal(Length(TmpStr))] = '(' then

  begin

  Result := True;

  Inc(FCurPos, Length(TmpStr));

  Index := I;

  Exit;

  end;

  end;

  end;

 end;

 Index := -1;

end;

function TRxMathParser.GetFunction(var AValue: TParserFunc): Boolean;

var

 I: TParserFunc;

 TmpStr: string;

begin

 Result := False;

 AValue := Low(TParserFunc);

 if FParseText[FCurPos] in ['A'..'Z', 'a'..'z', '_'] then begin

  for I := Low(TParserFunc) to High(TParserFunc) do begin

  TmpStr := Copy(FParseText, FCurPos, StrLen(FuncNames[I]));

  if CompareText(TmpStr, StrPas(FuncNames[I])) = 0 then begin

  AValue := I;

  if FParseText[FCurPos + Cardinal(Length(TmpStr))] = '(' then begin

  Result := True;

  Inc(FCurPos, Length(TmpStr));

  Break;

  end;

  end;

  end;

 end;

end;

function TRxMathParser.Term: Extended;

var

 Value: Extended;

 NoFunc: TParserFunc;

 UserFunc: Integer;

 Func: Pointer;

begin

 if FParseText[FCurPos] = '(' then begin

  Inc(FCurPos);

  Value := Calculate;

  if FParseText[FCurPos] <> ')' then InvalidCondition('SParseNotCramp');

  Inc(FCurPos);

 end

 else begin

  if not GetNumber(Value) then

  if not GetConst(Value) then

  if GetUserFunction(UserFunc) then begin

  Inc(FCurPos);

  Func := UserFuncList.Objects[UserFunc];

  Value := TFarUserFunction(Func)(Calculate);

  if FParseText[FCurPos] <> ')' then InvalidCondition('SParseNotCramp');

  Inc(FCurPos);

  end

  else if GetFunction(NoFunc) then begin

  Inc(FCurPos);

  Value := Calculate;

  try

  case NoFunc of

  pfArcTan: Value := ArcTan(Value);

  pfCos: Value := Cos(Value);

  pfSin: Value := Sin(Value);

  pfTan:

  if Cos(Value) = 0 then InvalidCondition('SParseDivideByZero')

  else Value := Sin(Value) / Cos(Value);

  pfAbs: Value := Abs(Value);

  pfExp: Value := Exp(Value);

  pfLn:

  if Value <= 0 then InvalidCondition('SParseLogError')

  else Value := Ln(Value);

  pfLog:

  if Value <= 0 then InvalidCondition('SParseLogError')

  else Value := Ln(Value) / Ln(10);

  pfSqrt:

  if Value < 0 then InvalidCondition('SParseSqrError')

  else Value := Sqrt(Value);

  pfSqr: Value := Sqr(Value);

  pfInt: Value := Round(Value);

  pfFrac: Value := Frac(Value);

  pfTrunc: Value := Trunc(Value);

  pfRound: Value := Round(Value);

  pfArcSin:

  if Value = 1 then Value := Pi / 2

  else Value := ArcTan(Value / Sqrt(1 - Sqr(Value)));

  pfArcCos:

  if Value = 1 then Value := 0

  else Value := Pi / 2 - ArcTan(Value / Sqrt(1 - Sqr(Value)));

  pfSign:

  if Value > 0 then Value := 1

  else if Value < 0 then Value := -1;

  pfNot: Value := not Trunc(Value);

  end;

  except

  on E: ERxParserError do raise

  else InvalidCondition('SParseInvalidFloatOperation');

  end;

  if FParseText[FCurPos] <> ')' then InvalidCondition('SParseNotCramp');

  Inc(FCurPos);

  end

  else InvalidCondition('SParseSyntaxError');

 end;

 Result := Value;

end;

function TRxMathParser.SubTerm: Extended;

var

 Value: Extended;

begin

 Value := Term;

 while FParseText[FCurPos] in ['*', '^', '/'] do begin

  Inc(FCurPos);

  if FParseText[FCurPos - 1] = '*' then

  Value := Value * Term

  else if FParseText[FCurPos - 1] = '^' then

  Value := Power(Value, Term)

  else if FParseText[FCurPos - 1] = '/' then

  try

  Value := Value / Term;

  except

  InvalidCondition('SParseDivideByZero');

  end;

 end;

 Result := Value;

end;

function TRxMathParser.Calculate: Extended;

var

 Value: Extended;

begin

 Value := SubTerm;

 while FParseText[FCurPos] in ['+', '-'] do begin

  Inc(FCurPos);

  if FParseText[FCurPos - 1] = '+' then Value := Value + SubTerm

  else Value := Value - SubTerm;

 end;

 if not (FParseText[FCurPos] in [#0, ')', '>', '<', '=', ',']) then

  InvalidCondition('SParseSyntaxError');

 Result := Value;

end;

function TRxMathParser.Exec(const AFormula: string): Extended;

var

 I, J: Integer;

begin

 J := 0;

 Result := 0;

 FParseText := '';

 for I := 1 to Length(AFormula) do begin

  case AFormula[I] of

  '(': Inc(J);

  ')': Dec(J);

  end;

  if AFormula[I] > ' ' then FParseText := FParseText + UpCase(AFormula[I]);

 end;

 if J = 0 then begin

  FCurPos := 1;

  FParseText := FParseText + #0;

  if (FParseText[1] in ['-', '+']) then FParseText := '0' + FParseText;

  Result := Calculate;

 end

 else InvalidCondition('SParseNotCramp');

end;

class procedure TRxMathParser.RegisterUserFunction(const Name: string;

 Proc: TUserFunction);

var

 I: Integer;

begin

 if (Length(Name) > 0) and (Name[1] in ['A'..'Z', 'a'..'z', '_']) then

 begin

  if not Assigned(Proc) then UnregisterUserFunction(Name)

  else begin

  with GetUserFuncList do begin

  I := IndexOf(Name);

  if I < 0 then I := Add(Name);

{$IFDEF WIN32}

  Objects[I] := @Proc;

{$ELSE}

  Objects[I] := Proc;

{$ENDIF}

  end;

  end;

 end

 else InvalidCondition('SParseSyntaxError');

end;

class procedure TRxMathParser.UnregisterUserFunction(const Name: string);

var

 I: Integer;

begin

 if Assigned(UserFuncList) then

  with UserFuncList do begin

  I := IndexOf(Name);

  if I >= 0 then Delete(I);

  if Count = 0 then FreeUserFunc;

  end;

end;

initialization

 UserFuncList := nil;

{$IFDEF WIN32}

finalization

 FreeUserFunc;

{$ELSE}

 AddExitProc(FreeUserFunc);

{$ENDIF}

end.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)

Отправить комментарий

Проверка
Антиспам проверка
Image CAPTCHA
...