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

На днях ребёнку в школе задали задание по графикам функций, при отсутствии под рукой готовых программ нацарапал своё приложение, причём приложение написано "двумя пальцами", т.е. без каких-либо украшательств, не очень красивым кодом и без комментариев - простая програмка, написанная за 15 минут.
Вот исходники:
== Main.pas ==
unit Main;
interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls;
type
 TForm1 = class(TForm)
 Panel1: TPanel;
 Button1: TButton;
 Edit1: TEdit;
 Label1: TLabel;
 Button2: TButton;
 Edit2: TEdit;
 Label2: TLabel;
 Button3: TButton;
 Edit3: TEdit;
 Label3: TLabel;
 Panel2: TPanel;
 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
 { Private declarations }
 procedure DrawFunction(FormulaText: string; Cl: TColor);
 function GetValue(FormulaText: string; x: Real): Real;
 procedure SetupAxes;
 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);
 { Draw axis Y }
 Point.X := Width div 2;
 Point.Y := 0;
 Canvas.PenPos := Point;
 Canvas.LineTo(Width div 2, Height);
 for i := 1 to (Width div 40) do
 begin
 Canvas.Pen.Width := 1;
 Canvas.Pen.Style := psDot;
 Point.X := (Width div 2) + (i * 20);
 Point.Y := 0;
 Canvas.PenPos := Point;
 Canvas.LineTo((Width div 2) + (i * 20), Height);
 end;
 for i := -1 downto (Width div 40) * (-1) do
 begin
 Canvas.Pen.Width := 1;
 Canvas.Pen.Style := psDot;
 Point.X := (Width div 2) + (i * 20);
 Point.Y := 0;
 Canvas.PenPos := Point;
 Canvas.LineTo((Width div 2) + (i * 20), Height);
 end;
 for i := 1 to (Height div 40) do
 begin
 Canvas.Pen.Width := 1;
 Canvas.Pen.Style := psDot;
 Point.Y := (Height div 2) + (i * 20);
 Point.X := 0;
 Canvas.PenPos := Point;
 Canvas.LineTo(Width, (Height div 2) + (i * 20));
 end;
 for I := -1 downto (Height div 40) * (-1) do
 begin
 Canvas.Pen.Width := 1;
 Canvas.Pen.Style := psDot;
 Point.Y := (Height div 2) + (i * 20);
 Point.X := 0;
 Canvas.PenPos := Point;
 Canvas.LineTo(Width, (Height div 2) + (i * 20));
 end;
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
 p := GetValue(FormulaText, Width div -40);
 Point.X := 0;
 Point.Y := Round(p * 20);
 Canvas.PenPos := Point;
 prev := Point.Y;
 error := False;
 except
 error := True;
 end;
 for I := 0 to width do
 begin
 try
 if error then
 begin
 Point.X := i;
 Point.Y := (Height div 2) - Round(GetValue(FormulaText, (i - Width / 2) / 20) * 20);
 prev := Point.Y;
 Canvas.PenPos := Point;
 end
 else
 begin
 value := (Height div 2) - Round(GetValue(FormulaText, (i - Width / 2) / 20) * 20);
 if Abs(value) < Height then
 Canvas.LineTo(i, value)
 else
 raise Exception.Create();
 end;
 error := False;
 except
 error := True;
 end;
 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(Edit2.Text, clGreen);
 DrawFunction(Edit3.Text, clMaroon);
end;
end.
== Main.dfm ==
object Form1: TForm1
 Left = 357
 Top = 465
 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 = 48
 Top = 8
 Width = 281
 Height = 121
 TabOrder = 0
 object Label1: TLabel
 Left = 9
 Top = 27
 Width = 16
 Height = 16
 Caption = 'Y='
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = 'Fixedsys'
 Font.Style = []
 ParentFont = False
 end
 object Label2: TLabel
 Left = 9
 Top = 58
 Width = 16
 Height = 16
 Caption = 'Y='
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = 'Fixedsys'
 Font.Style = []
 ParentFont = False
 end
 object Label3: TLabel
 Left = 9
 Top = 89
 Width = 16
 Height = 16
 Caption = 'Y='
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = 'Fixedsys'
 Font.Style = []
 ParentFont = False
 end
 object Button1: TButton
 Left = 232
 Top = 23
 Width = 41
 Height = 25
 Caption = 'Draw'
 TabOrder = 1
 OnClick = Button1Click
 end
 object Edit1: TEdit
 Left = 31
 Top = 24
 Width = 195
 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 Button2: TButton
 Left = 232
 Top = 54
 Width = 41
 Height = 25
 Caption = 'Draw'
 TabOrder = 3
 OnClick = Button2Click
 end
 object Edit2: TEdit
 Left = 31
 Top = 55
 Width = 195
 Height = 24
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clGreen
 Font.Height = -11
 Font.Name = 'Fixedsys'
 Font.Style = []
 ParentFont = False
 TabOrder = 2
 OnKeyPress = Edit2KeyPress
 end
 object Button3: TButton
 Left = 232
 Top = 85
 Width = 41
 Height = 25
 Caption = 'Draw'
 TabOrder = 5
 OnClick = Button3Click
 end
 object Edit3: TEdit
 Left = 31
 Top = 86
 Width = 195
 Height = 24
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clMaroon
 Font.Height = -11
 Font.Name = 'Fixedsys'
 Font.Style = []
 ParentFont = False
 TabOrder = 4
 OnKeyPress = Edit3KeyPress
 end
 object Panel2: TPanel
 Left = 1
 Top = 1
 Width = 279
 Height = 16
 Align = alTop
 Color = clNavy
 TabOrder = 6
 OnMouseDown = Panel2MouseDown
 end
 end
end
== Parsing.pas ==
Для разбора математических выражений использовался модуль 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 NextChar;
 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.NextChar;
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;
 NextChar;
 C := GetChar;
 while C in ['0'..'9', 'A'..'F', 'a'..'f'] do begin
 TmpStr := TmpStr + C;
 NextChar;
 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;
 NextChar;
 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));
 NextChar;
 C := GetChar;
 if (C in ['+', '-']) then begin
 TmpStr := TmpStr + C;
 NextChar;
 end;
 end
 else NextChar;
 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.
Author: Vit
ID: 04221
== См. также ==
* Программа выводящая график функции в полярных координатах
* Программа выводящая график параметрической функции в декартовых координатах
Category:Алгоритмы
Category:Графика
Category:Рисование