home *** CD-ROM | disk | FTP | other *** search
/ Chip 1998 March / Chip_1998-03_cd.bin / zkuste / matemat / Vyssi / MATH2.ZIP / exmpl-3 / pas / frmcfit.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-05-27  |  10.2 KB  |  348 lines
  1. unit Frmcfit;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, Buttons, StdCtrls, ExtCtrls, RChart, DCommon,
  8.   Math1, Math2, NumLab;
  9.  
  10. {===========================================================
  11.  Please note, that the program CURVEFIT uses the units RChart
  12.  and NumLab, which are not supplied with the MATH2 package. If
  13.  you don't have them, you can download them from the following
  14.  WWW site:  http://qspr03.tuwien.ac.at/lo/
  15.  ===========================================================}
  16.  
  17. type
  18.   TFrmMain = class(TForm)
  19.     RChart1: TRChart;
  20.     Panel1: TPanel;
  21.     SBNewPnts: TSpeedButton;
  22.     NLabFitQual: TNumLab;
  23.     Panel2: TPanel;
  24.     BButParabolFit: TBitBtn;
  25.     BButCalcReciprLine: TBitBtn;
  26.     BButHyper: TBitBtn;
  27.     BButLogFit: TBitBtn;
  28.     BButGaussFit: TBitBtn;
  29.     BButLinFit: TBitBtn;
  30.     BButExit: TBitBtn;
  31.     SBClear: TSpeedButton;
  32.     LblFormula: TLabel;
  33.     Label1: TLabel;
  34.     NLabRXY: TNumLab;
  35.     LblParams: TLabel;
  36.     procedure BButExitClick(Sender: TObject);
  37.     procedure FormCreate(Sender: TObject);
  38.     procedure RChart1MouseDown(Sender: TObject; Button: TMouseButton;
  39.       Shift: TShiftState; X, Y: Integer);
  40.     procedure SBNewPntsClick(Sender: TObject);
  41.     procedure BButParabolFitClick(Sender: TObject);
  42.     procedure BButCalcReciprLineClick(Sender: TObject);
  43.     procedure BButHyperClick(Sender: TObject);
  44.     procedure BButLogFitClick(Sender: TObject);
  45.     procedure BButGaussFitClick(Sender: TObject);
  46.     procedure BButLinFitClick(Sender: TObject);
  47.     procedure SBClearClick(Sender: TObject);
  48.     procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  49.       Y: Integer);
  50.   private
  51.     Stats1 : TCurveFit;
  52.   public
  53.     { Public declarations }
  54.   end;
  55.  
  56. var
  57.   FrmMain: TFrmMain;
  58.  
  59. implementation
  60.  
  61. {$R *.DFM}
  62.  
  63. const
  64.   ChartXRes = 200;
  65.  
  66. (*****************************************************************)
  67. procedure TFrmMain.BButExitClick(Sender: TObject);
  68. (*****************************************************************)
  69.  
  70. begin
  71. close;
  72. end;
  73.  
  74. (*****************************************************************)
  75. procedure TFrmMain.FormCreate(Sender: TObject);
  76. (*****************************************************************)
  77.  
  78. begin
  79. Stats1 := TCurveFit.Create;
  80. end;
  81.  
  82. (*****************************************************************)
  83. procedure TFrmMain.SBClearClick(Sender: TObject);
  84. (*****************************************************************)
  85.  
  86. begin
  87. Stats1.Init;
  88. RChart1.ClearGraf;
  89. RChart1.ShowGraf;
  90. SbNewPnts.Down := false;
  91. LblFormula.Visible := false;
  92. LblParams.Visible := true;
  93. LblParams.Caption := '<---- click here to enter data';
  94. end;
  95.  
  96.  
  97. (*****************************************************************)
  98. procedure TFrmMain.RChart1MouseDown(Sender: TObject; Button: TMouseButton;
  99.   Shift: TShiftState; X, Y: Integer);
  100. (*****************************************************************)
  101.  
  102. var
  103.   rx, ry : double;
  104.  
  105. begin
  106. if SBNewPnts.Down then
  107.   begin
  108.   RChart1.M2R (x,y, rx, ry);
  109.   RChart1.MarkAt (rx,ry,4);
  110.   Stats1.EnterStatValue (rx, ry);
  111.   NLabRXY.Value := Stats1.CorrCoeff;
  112.   RChart1.ShowGraf;
  113.   end;
  114. end;
  115.  
  116. (*****************************************************************)
  117. procedure TFrmMain.SBNewPntsClick(Sender: TObject);
  118. (*****************************************************************)
  119.  
  120. begin
  121. while (RChart1.TypeOfLastItem <> tkMarkAt) and
  122.       (RChart1.TypeOfLastItem <> tkNone) do { remove any curve from graph }
  123.   RChart1.RemoveLastItem;
  124. RChart1.ShowGraf;
  125. LblFormula.Visible := false;
  126. if not SBNewPnts.Down
  127.   then LblParams.Caption := '<---- click here to enter data'
  128.   else LblParams.Caption := 'click into chart to enter new data points';
  129. LblParams.Visible := true;
  130. end;
  131.  
  132. (*****************************************************************)
  133. procedure TFrmMain.BButParabolFitClick(Sender: TObject);
  134. (*****************************************************************)
  135.  
  136. var
  137.   k0, k1, k2 : double;
  138.   FitQUal    : double;
  139.   xstep      : double;
  140.   i          : integer;
  141.   x          : double;
  142.  
  143. begin
  144. while (RChart1.TypeOfLastItem <> tkMarkAt) and
  145.       (RChart1.TypeOfLastItem <> tkNone) do { remove any curve from graph }
  146.   RChart1.RemoveLastItem;
  147. SbNewPnts.Down := false;
  148. Stats1.CalcParabolFit (k0, k1, k2, FitQual);
  149. NLabFitQual.Value := FitQual;
  150. RChart1.MoveTo (RChart1.RangeLoX,k0+k1*RChart1.RangeLoX+k2*sqr(RChart1.RangeLoX));
  151. xstep := (RChart1.RangeHiX-RChart1.RangeLoX) / ChartXRes;
  152. for i:=1 to ChartXRes do
  153.   begin
  154.   x := RChart1.RangeLoX+i*xstep;
  155.   RChart1.DrawTo (x,k0+k1*x+k2*sqr(x));
  156.   end;
  157. RChart1.ShowGraf;
  158. LblFormula.Caption := 'y = k0 + k1*x + k2*sqr(x)';
  159. LblParams.Caption := 'k0 = '+strf(k0,1,3)+'    k1 = '+strf(k1,1,3)+'    k2 = '+strf(k2,1,3);
  160. LblFormula.Visible := True;
  161. LblParams.Visible := true;
  162. end;
  163.  
  164.  
  165.  
  166. (*****************************************************************)
  167. procedure TFrmMain.BButCalcReciprLineClick(Sender: TObject);
  168. (*****************************************************************)
  169.  
  170. var
  171.   k0, k1     : double;
  172.   FitQUal    : double;
  173.   xstep      : double;
  174.   i          : integer;
  175.   x          : double;
  176.   denom      : double;
  177.  
  178. begin
  179. while (RChart1.TypeOfLastItem <> tkMarkAt) and
  180.       (RChart1.TypeOfLastItem <> tkNone) do { remove any curve from graph }
  181.   RChart1.RemoveLastItem;
  182. SbNewPnts.Down := false;
  183. Stats1.CalcReciLinFit (k0, k1, FitQual);
  184. NLabFitQual.Value := FitQUal;
  185. denom := k0+k1*RChart1.RangeLoX;
  186. if denom <> 0 then
  187.   RChart1.MoveTo (RChart1.RangeLoX,1/denom);
  188. xstep := (RChart1.RangeHiX-RChart1.RangeLoX) / ChartXRes;
  189. for i:=1 to ChartXRes do
  190.   begin
  191.   x := RChart1.RangeLoX+i*xstep;
  192.   denom := k0+k1*x;
  193.   if denom <> 0 then
  194.     RChart1.DrawTo (x,1/denom);
  195.   end;
  196. RChart1.ShowGraf;
  197. LblFormula.Caption := 'y = 1/(k0 + k1*x)';
  198. LblParams.Caption := 'k0 = '+strf(k0,1,3)+'     k1 = '+strf(k1,1,3);
  199. LblFormula.Visible := True;
  200. LblParams.Visible := true;
  201. end;
  202.  
  203.  
  204.  
  205. (*****************************************************************)
  206. procedure TFrmMain.BButHyperClick(Sender: TObject);
  207. (*****************************************************************)
  208.  
  209. var
  210.   k0, k1     : double;
  211.   FitQUal    : double;
  212.   xstep      : double;
  213.   i          : integer;
  214.   x          : double;
  215.  
  216. begin
  217. while (RChart1.TypeOfLastItem <> tkMarkAt) and
  218.       (RChart1.TypeOfLastItem <> tkNone) do { remove any curve from graph }
  219.   RChart1.RemoveLastItem;
  220. SbNewPnts.Down := false;
  221. Stats1.CalcHyperbolFit (k0, k1, FitQual);
  222. NLabFitQual.Value := FitQUal;
  223. if RChart1.RangeLoX <> 0
  224.   then RChart1.MoveTo (RChart1.RangeLoX,k0+k1/RChart1.RangeLoX)
  225.   else RChart1.MoveTo (RChart1.RangeLoX,MaxReal);
  226. xstep := (RChart1.RangeHiX-RChart1.RangeLoX) / ChartXRes;
  227. for i:=1 to ChartXRes do
  228.   begin
  229.   x := RChart1.RangeLoX+i*xstep;
  230.   if x <> 0
  231.     then RChart1.DrawTo (x,k0+k1/x)
  232.     else RChart1.DrawTo (x,MaxReal);
  233.   end;
  234. RChart1.ShowGraf;
  235. LblFormula.Caption := 'y = k0 + k1/x';
  236. LblParams.Caption := 'k0 = '+strf(k0,1,3)+'    k1 = '+strf(k1,1,3);
  237. LblFormula.Visible := True;
  238. LblParams.Visible := true;
  239. end;
  240.  
  241.  
  242. (*****************************************************************)
  243. procedure TFrmMain.BButLogFitClick(Sender: TObject);
  244. (*****************************************************************)
  245.  
  246. var
  247.   k0, k1     : double;
  248.   FitQUal    : double;
  249.   xstep      : double;
  250.   i          : integer;
  251.   x          : double;
  252.  
  253. begin
  254. while (RChart1.TypeOfLastItem <> tkMarkAt) and
  255.       (RChart1.TypeOfLastItem <> tkNone) do { remove any curve from graph }
  256.   RChart1.RemoveLastItem;
  257. SbNewPnts.Down := false;
  258. Stats1.CalcLogFit (k0, k1, FitQual);
  259. NLabFitQual.Value := FitQUal;
  260. if RChart1.RangeLoX > 0
  261.   then RChart1.MoveTo (RChart1.RangeLoX,k0+k1*ln(RChart1.RangeLoX))
  262.   else RChart1.MoveTo (0, -MaxReal);
  263. xstep := (RChart1.RangeHiX-RChart1.RangeLoX) / ChartXRes;
  264. for i:=1 to ChartXRes do
  265.   begin
  266.   x := RChart1.RangeLoX+i*xstep;
  267.   if x > 0 then
  268.     RChart1.DrawTo (x,k0+k1*ln(x));
  269.   end;
  270. RChart1.ShowGraf;
  271. LblFormula.Caption := 'y = k0 + k1*ln(x)';
  272. LblParams.Caption := 'k0 = '+strf(k0,1,3)+'    k1 = '+strf(k1,1,3);
  273. LblFormula.Visible := True;
  274. LblParams.Visible := true;
  275. end;
  276.  
  277.  
  278.  
  279. (*****************************************************************)
  280. procedure TFrmMain.BButGaussFitClick(Sender: TObject);
  281. (*****************************************************************)
  282.  
  283. var
  284.   k0, k1, k2 : double;
  285.   FitQUal    : double;
  286.   xstep      : double;
  287.   i          : integer;
  288.   x          : double;
  289.  
  290. begin
  291. while (RChart1.TypeOfLastItem <> tkMarkAt) and
  292.       (RChart1.TypeOfLastItem <> tkNone) do { remove any curve from graph }
  293.   RChart1.RemoveLastItem;
  294. SbNewPnts.Down := false;
  295. Stats1.CalcGaussFit (k0, k1, k2, FitQual);
  296. NLabFitQual.Value := FitQUal;
  297. x := RChart1.RangeLoX;
  298. RChart1.MoveTo (x,k0*exp(-sqr(x-k1)/k2));
  299. xstep := (RChart1.RangeHiX-RChart1.RangeLoX) / ChartXRes;
  300. for i:=1 to ChartXRes do
  301.   begin
  302.   x := RChart1.RangeLoX+i*xstep;
  303.   RChart1.DrawTo (x,k0*exp(-sqr(x-k1)/k2));
  304.   end;
  305. RChart1.ShowGraf;
  306. LblFormula.Caption := 'y = k0*exp(-sqr(x-k1)/k2)';
  307. LblParams.Caption := 'k0 = '+strf(k0,1,3)+'    k1 = '+strf(k1,1,3)+'    k2 = '+strf(k2,1,3);
  308. LblFormula.Visible := True;
  309. LblParams.Visible := true;
  310. end;
  311.  
  312. (*****************************************************************)
  313. procedure TFrmMain.BButLinFitClick(Sender: TObject);
  314. (*****************************************************************)
  315.  
  316. var
  317.   k,d    : double;
  318.   FitQUal: double;
  319.  
  320. begin
  321. while (RChart1.TypeOfLastItem <> tkMarkAt) and
  322.       (RChart1.TypeOfLastItem <> tkNone) do { remove any curve from graph }
  323.   RChart1.RemoveLastItem;
  324. SbNewPnts.Down := false;
  325. Stats1.CalcLinFit (k, d, FitQual);
  326. NLabFitQual.Value := FitQUal;
  327. RChart1.MoveTo (RChart1.RangeLoX,k*RChart1.RangeLoX+d);
  328. RChart1.DrawTo (RChart1.RangeHiX,k*RChart1.RangeHiX+d);
  329. RChart1.ShowGraf;
  330. LblFormula.Caption := 'y = k*x + d';
  331. LblParams.Caption := 'k = '+strf(k,1,3)+'    d = '+strf(d,1,3);
  332. LblFormula.Visible := True;
  333. LblParams.Visible := true;
  334. end;
  335.  
  336.  
  337. (*****************************************************************)
  338. procedure TFrmMain.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  339.   Y: Integer);
  340. (*****************************************************************)
  341.  
  342. begin
  343. Screen.cursor := crDefault;
  344. end;
  345.  
  346.  
  347. end.
  348.