Листинг программного комплекса «Прогнозирование»

unit Unitl;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, ComCtrls, StdCtrls, ExtCtrls, TeeProcs, TeEngine,

Chart, Series,

Vcl.Grids;

const

Maxin =100;

Maxh = 50;

maxout =12;

e = 0.000000001;

MaximumN = 200;

multiply_coef = 1000000;

tech_pairs = 4;

prognoz_pairs = 1;

target_mistake_count = 6;

type

Tinput = array [1 .. Maxin] of extended;

Tslice = array [1 .. Maxh] of extended;

Tout = array [1 .. maxout] of extended;

Tweightsl = array [1 .. Maxin, 1 .. Maxh] of extended;

Tweights2 = array [1 .. Maxh, 1 .. maxout] of extended;

T weights = record

masn, masm, masp: integer;

mask Tweightsl;

mas2: Tweights2;

koef: extended;

end;

TForml = class(TForm)

PageControl 1: TPageControl;

TabSheetl: TTabSheet;

TabSheet3: TTabSheet;

NumberEdit: TEdit;

ChangeEdit: TEdit;

Label4: TLabel;

Label5: TLabel;

Label6: TLabel;

Teach: TButton;

MonthChart: TChart;

Count: TButton;

LabellO: TLabel;

Label9: TLabel;

СотЬоВохЗ: TComboBox;

Labell7: TLabel;

Series 1: TAreaSeries;

Labell9: TLabel;

lbl_cur_line: TLabel;

nEdit: TEdit;

Label 1: TLabel;

mEdit: TEdit;

Label2: TLabel;

aEdit: TEdit;

Label3: TLabel;

Label20: TLabel;

lbl_shag: TLabel;

Label21: TLabel;

lbl_err: TLabel;

StringGrid2: TStringGrid;

TeachEdit: TEdit;

StringGridl: TStringGrid;

lbl_test_line: TLabel;

function func(x: extended): extended;

procedure Correct Weights;

function Mistake: extended;

procedure NewMassiv;

procedure Answer;

procedure FormCreate(Sender: TObject);

procedure ArrayInitClick(Sender: TObject);

procedure CountClick(Sender: TObject);

procedure TeachClick(Sender: TObject);

private f: text;

in_count, hiden_count, p, pairs: integer;

vesa: file of Tweights;

Inp: Tinput;

ExitVal, Corr: Tout;

Hidden: Tslice;

w: Tweights 1;

v: Tweights2;

number: integer;

a, abegin: extended;

change: extended;

leaming_massiv: array [1 .. 2, 1 .. Maxin, 1 .. Maxin] of extended;

{ Private declarations }

public

{ Public declarations } end;

var

Forml: TForml;

implementation

{$R*.dfm}

functionTForml.func(x: extended): extended;

begin

func := 1 / (1 + exp(-x)) end;

procedure TForml.CorrectWeights;

var

I, j, к: integer;

s: extended;

begin

for j := 1 to hiden_count do

for к := 1 to p do

v[j, k] := v[j, k] - a * Hidden[j] * (ExitVal[k] - Corr[k]) * Ex-itVal[k] * (1 - ExitVal[k]);

for I := 1 to in_count do

for j := 1 to hiden_count do

begin

s:=0;

for к := 1 to p do

  • s := s + s + v[j, k] * (ExitVal[k] - Corr[k]) * ExitVal[k] *
  • (1 - ExitVal[k]);

w[I, j] := w[I, j] — a * s * Hiddenfj] * (1 -Hidden[j]) * Inp [I];

end;

end;

function TForml.Mistake: extended;

var

I: integer;

s: extended;

begin

s := 0;

for I := 1 to p do

s := s + (ExitVal[I] - Corr[I]) * (ExitVal[I] - Corr[I]);

Mistake := 0.5 * s

end;

procedure TForml. NewMassiv;

var

Sender: TObject;

Q: Tweights;

wl: Tweights 1;

w2: Tweights2;

I, j: integer;

begin

Q.masn := StrToInt(nEdit.text);

Q.masm := StrToInt(mEdit.text);

pairs := StrToInt(TeachEdit.text);

Q.masp := 12;

in_count := Q.masn;

hiden_count := Q.masm;

p := Q.masp;

assignfile(vesa, 'weight.dat');

RandSeed := 0;

// randomize;

for I := 1 to in_count do

for j := 1 to hiden_count do

wl[I, j] := -0.3 + 0.6 * RANDOM;

for I := 1 to hiden_count do

for j := 1 to p do

w2[I, j] := -0.3 + 0.6 * RANDOM;

rewrite(vesa);

Q.masl := wl;

Q.mas2 := w2;

Q.koef := StrToFloat(aEdit.text);

write(vesa, Q);

closefile(vesa);

w := wl;

v := w2;

a := Q.koef;

end;

procedure TForml. Answer;

var

I, j: integer;

s: extended;

begin

for j := 1 to hiden_count do

begin

s := 0;

for I := 1 to in_count do

s := s + Inp[I] * w[I, j];

Hidden[j] := func(s);

end;

for I := 1 to p do

begin

s := 0;

for j := 1 to hiden_count do

s := s + Hidden[j] * v[j, I];

ExitVal[I] := func(s);

end;

end;

procedure TForml.FormCreate(Sender: TObject);

var

Q: Tweights;

I: integer;

begin

assignfile(vesa, 'weight.dat');

reset(vesa);

if eof(vesa) then

// showmessagefMaccHBu весов не инициализированы') else

begin

read(vesa, Q);

w := Q.masl;

v ;= Q.mas2;

a := Q.koef;

in_count := Q.masn;

hiden_count ;= Q.masm;

p ;= Q.masp;

end;

closefile(vesa);

abegin := StrToFloat(aEdit.text);

end;

procedureTForml.ArrayInitClick(Sender: TObject);

begin

NewMassiv;

end;

procedure TForml.CountClick(Sender: TObject);

VAR

0: integer;

I, per: integer;

begin

StringGrid2.RowCount := 2;

StringGrid2.ColCount := 13;

for I := 1 to in_count do

Inp[I] := learning_massiv[2, tech_pairs + 1,1];

Answer;

StringGrid2.Cells[0, 1] := '2012';

for per := 1 to p do

begin

StringGrid2.Cells[per, 0] := IntToStr(per);

О := TRUNC(multiply_coef * ExitVal[per]);

MonthChart.Series[0].AddXY(in_count * (tech_pairs + 1) + per, O, ", 3333333);

StringGrid2.Cells[per, 1] := IntToStr(O);

end;

END;

procedure TForml.TeachClick(Sender: TObject);

var

pair, I, j, t, y, m, b, mist_c: integer;

k, mist: extended;

test_try, current_try: integer;

Q: Tweights;

begin

number := StrToInt(NumberEdit.text);

change := StrToFloat(ChangeEdit.text);

b := ComboBox3.ItemIndex;

case b of

0:

assignfile(f, '46.txt');

1:

assignfile(f, '53.txt');

2:

assignfile(f, '58.txt')

else

begin

showmessage(’Oaiui для записи не определен.');

Exit;

end;

end;

reset(f);

NewMassiv;

StringGridl .RowCount := pairs + prognoz_pairs + 1;

StringGridl .ColCount := in_count + 1;

for I := 1 to 12 do

StringGridl.Cells [I, 0] := IntToStr(I);

for I := 1 to pairs + prognoz_pairs do

for j := 1 to in_count do

begin

read(f, y);

read(f, m);

readln(f, k);

StringGridl.Cells[0,1] := IntToStr(y);

StringGridl.Cells[j, I] := FloatToStr(k);

learning_massiv[l, I, j] := k;

learning_massiv[2,1, j] := к / multiply_coef;

if (I > 1) then

begin

leaming_massiv[l, I - 1, j + in_count] := k;

leaming_massiv[2,1 - 1, j + in_count] := к / multiply_coef; end;

end;

// сразу график

MonthChart.Series[0].Clear;

t := 1;

for I := 1 to pairs + 1 do

for j := 1 to in_count do

begin

MonthChart.Series[0].AddXY(t, learning_massiv[l, I, j]);

t ;=t + 1;

end;

t:= 1;

mist_c := 0;

repeat

lbl_shag.Caption := IntToStr(t);

current_try := RANDOM(tech_pairs) + 1;

lbl_cur_line.Caption := IntToStr(current_try);

for I := 1 to maxout do

begin

Corrfl] := learning_massiv[2, current_try, in_count +1];

Inp[I] := leaming_massiv[2, current_try, I];

end;

Answer;

CorrectWeights;

mist := Mistake;

if mist < e then

mist_c := mist_c + 1;

lbl_err.Caption := FloatToStr(mist);

Application.ProcessMessages;

t :=t+ 1;

a := a * change;

until (mist_c >= target_mistake_count) or (t = number + 1);;

closefile(f);

rewrite(vesa);

Q.masl := w;

Q.mas2 := v;

Q.koef := a;

Q.masn ;= in_count;

Q.masm := hiden_count;

Q.masp := 1;

write(vesa, Q);

closefile(vesa);

end;

end.

 
Посмотреть оригинал
< Пред   СОДЕРЖАНИЕ ОРИГИНАЛ