exp( Ln( abs( (a[j+num+3]-cen3[k,j])/sigma3[k,j]*(2*b3[k,j]-1)) ))*
myu3[k,i]/sqr(1+exp(Ln(abs((a[j+num+3]-cen3[k,j])/sigma3[k,j]))*2*b3[k,j]) );
if r=k then delta:=0 else delta:=1;
dwc:=(delta*mxj-lxj)/sqr(mxj)*p1;
s1:=p3[r,0];
for l:=1 to nac do
s1:=s1+p3[r,l]*a[num+l+3];
sc:=sc+s1*dwc;
//dw/d(sigma)
p2:=1;
for i:=1 to m do
if i<>j then
p2:=p2*(2*b3[k,j]/sigma3[k,j])*
exp( Ln( abs( (a[j+num+3]-cen3[k,j])/sigma3[k,j]) ))*
myu3[k,i]/sqr(1+exp(Ln(abs((a[j+num+3]-cen3[k,j])/sigma3[k,j]))*2*b3[k,j]) );
dws:=(delta*mxj-lxj)/sqr(mxj);
ss:=ss+s1*dws;
//dw/d(b)
p5:=1;
for i:=1 to m do
if i<>j then
p5:=p5*(-2*exp( Ln( abs( (a[j+num+3]-cen3[k,j])/sigma3[k,j]) )*2*b3[k,j]))*
Ln( abs( (a[j+num+3]-cen3[k,j])/sigma3[k,j]) )*
myu3[k,i]/sqr(1+exp(Ln(abs((a[j+num+3]-cen3[k,j])/sigma3[k,j]))*2*b3[k,j]) );
end;ns(i,j,sc,ss,sb);
dec:=(vihod-a[num+4])*sc;
des:=(vihod-a[num+4])*ss;
deb:=(vihod-a[num+4])*sb;
cen3[k,j]:=cen3[k,j]-gc*dec;
sigma3[k,j]:=sigma3[k,j]-gs*des;
b3[k,j]:=b3[k,j]-gb*deb;
end;//{k}
end;//{j}
end;//adjust_csb3
//adjust_csb
procedure adjust_csb(num:integer;vihod:real);
const eps=0.00001;
var lxj,mxj,mxjs,sum:real;
r,k,j,l,bb,d,delta:integer;
p1,p2,p3,p4:real; // Произведения при вычислении dw/d(cen)(sigma)(b)
s1,sc,ss,sb,dec,deb,des,dwc,dwb,dws:real; // dw/d(cen)(sigma)(b)
begin
for j:=1 to nac do
begin
for k:=1 to m do
begin
lxj:=1;
for l:=1 to nac do
lxj:=lxj*myu[k,j];
mxj:=1;
for bb:=1 to m do
begin
mxjs:=0;
for d:=1 to nac do
mxjs:=mxjs+myu[bb,d];
mxj:=mxj*mxjs;
end;
if mxj<eps then
mxj:=eps;
if lxj<eps then
lxj:=eps;
// Изменняем cen
sc:=0;
ss:=0;
sb:=0;
for r:=1 to m do
begin
//dw/d(cen)
p1:=1;
for i:=1 to m do
if i<>j then
p1:=p1*(2*b[k,j]/sigma[k,j])*
exp( Ln( abs( (a[j+num]-cen[k,j])/sigma[k,j]*(2*b[k,j]-1)) ))*
myu[k,i]/sqr(1+exp(Ln(abs((a[j+num]-cen[k,j])/sigma[k,j]))*2*b[k,j]) );
if r=k then delta:=0 else delta:=1;
dwc:=(delta*mxj-lxj)/sqr(mxj)*p1;
s1:=p[r,0];
for l:=1 to nac do
s1:=s1+p[r,l]*a[num+l];
sc:=sc+s1*dwc;
//dw/d(sigma)
p2:=1;
for i:=1 to m do
if i<>j then
p2:=p2*(2*b[k,j]/sigma[k,j])*
exp( Ln( abs( (a[j+num]-cen[k,j])/sigma[k,j]) ))*
myu[k,i]/sqr(1+exp(Ln(abs((a[j+num]-cen[k,j])/sigma[k,j]))*2*b[k,j]) );
dws:=(delta*mxj-lxj)/sqr(mxj);
ss:=ss+s1*dws;
//dw/d(b)
p3:=1;
for i:=1 to m do
if i<>j then
p3:=p3*(-2*exp( Ln( abs( (a[j+num]-cen[k,j])/sigma[k,j]) )*2*b[k,j]))*
Ln( abs( (a[j+num]-cen[k,j])/sigma[k,j]) )*
myu[k,i]/sqr(1+exp(Ln(abs((a[j+num]-cen[k,j])/sigma[k,j]))*2*b[k,j]) );
end;ns(k,j,sc,ss,sb);
dec:=(vihod-a[num+1])*sc;
des:=(vihod-a[num+1])*ss;
deb:=(vihod-a[num+1])*sb;
cen[k,j]:=cen[k,j]-gc*dec;
sigma[k,j]:=sigma[k,j]-gs*des;
b[k,j]:=b[k,j]-gb*deb;
end;//{k}
end;//{j}
end;//adjust_csb
procedure a_p;
var j:integer;norm:real;
begin
for j:=1 to m do norm:=norm+j;
norm:=1/norm;
for i:=1 to m do
for j:=1 to (nac+1) do
begin
p[i,j]:=j*norm;
p3[i,j]:=j*(norm+0.0001*i);
end;
end;
// adjust_p();
procedure adjust_p();
var l_s,l_d,i,j,k,l,r,k1,k2,k3:integer;
dob,sum,dt,w,norm:real;
hth,h,h3,hp:array[1..250,1..100]of real;
dl:array[1..250]of real;
pp,pp3:array[1..200]of real;
htn:matrix;
begin
l:=nst;
norm:=0; for j:=1 to m do norm:=norm+j;
norm:=1/norm;
setsize(htn,l,(nac+1)*m);
// Формируем матрицу h
for r:=1 to l do
begin
for i:=1 to m do
begin
h[r,(i-1)*(nac+1)+1]:=i*norm;
w:=i*norm;
for j:=1 to nac do
begin
dob:=1;sum:=0;
for l_s:=1 to m do
begin
for l_d:=1 to nac do
dob:=dob*1/(1+exp(Ln(abs((a[l_d]-cen[l_s,l_d])/sigma[l_s,l_d]))*2*b[l_s,l_d]) );
sum:=sum+dob;
end;
h[r,(i-1)*(nac+1)+j+1]:=dob/sum;
end;
end;
end;
for r:=1 to l do
for j:=1 to nac do
for i:=1 to m do
h[r,(j-1)*(nac+1)+i+1]:=h[r,(j-1)*(nac+1)+i+1]*a[r+(j-1)*nac+i];
for i:=1 to nst do
dl[i]:=a[nac+i];
for k1:=1 to m*(nac+1) do
for k2:=1 to m*(nac+1)do
begin
hth[k1,k2]:=0;
for k3:=1 to l do
hth[k1,k2]:=hth[k1,k2]+h[k1,k3]*h[k3,k1];
end;
setsize(htn,m*(nac+1),m*(nac+1));
for i:=1 to m*(nac+1) do
for j:=1 to m*(nac+1) do
htn.data[i-1,j-1]:=hth[i,j];
invers(htn);
for i:=1 to m*(nac+1) do
for j:=1 to m*(nac+1) do
hth[i,j]:=htn.data[i-1,j-1];
for i:=1 to m*(nac+1)do
for j:=1 to l do
begin
hp[i,j]:=0;
for r:=1 to m do
hp[i,j]:=hp[i,j]+hth[i,r]*h[r,j];
end;
for i:=1 to m*(nac+1) do
pp[i]:=0;
for i:=1 to m*(nac+1) do
begin
for j:=1 to l do
pp[i]:=pp[i]+hp[i,j]*dl[j];
end;
for i:=1 to m do
for j:=0 to (nac)do
p[i,j]:=pp[j+1+(i-1)*m];
end;//adjust_p();
// adjust_p3();
procedure adjust_p3();
var l_d,l_s,i,j,k,l,r,k1,k2,k3:integer;
dob,sum,dt,w,norm:real;
hth,h,h3,hp:array[1..250,1..100]of real;
dl:array[1..250]of real;
pp:array[1..200]of real;
htn:matrix;
begin
l:=nst;
norm:=0; for j:=1 to m do norm:=norm+j;
norm:=1/norm;
setsize(htn,l,(nac+1)*m);
// Формируем матрицу h
for r:=1 to l do
begin
for i:=1 to m do
begin
h[r,(i-1)*(nac+1)+1]:=i*norm;
w:=i*norm;
for j:=1 to nac do
begin
dob:=1;sum:=0;
for l_s:=1 to m do
begin
for l_d:=1 to nac do
dob:=dob*1/(1+exp(Ln(abs((a[l_d] cen[l_s,l_d])/sigma[l_s,l_d]))*2*b[l_s,l_d]) );
sum:=sum+dob;
end;
h[r,(i-1)*(nac+1)+j+1]:=dob/sum;
end;
end;
end;
for r:=1 to l do
for j:=1 to nac do
for i:=1 to m do
h[r,(j-1)*(nac+1)+i+1]:=h[r,(j-1)*(nac+1)+i+1]*a[r+(j-1)*nac+i];
for i:=1 to nst do
dl[i]:=a[nac+i+3];
for k1:=1 to m*(nac+1) do
for k2:=1 to m*(nac+1)do
begin
hth[k1,k2]:=0;
for k3:=1 to l do
hth[k1,k2]:=hth[k1,k2]+h[k1,k3]*h[k3,k1];
end;
setsize(htn,m*(nac+1),m*(nac+1));
for i:=1 to m*(nac+1) do
for j:=1 to m*(nac+1) do
htn.data[i-1,j-1]:=hth[i,j];
invers(htn);
for i:=1 to m*(nac+1) do
for j:=1 to m*(nac+1) do
hth[i,j]:=htn.data[i-1,j-1];
for i:=1 to m*(nac+1)do
for j:=1 to l do
begin
hp[i,j]:=0;
for r:=1 to m do
hp[i,j]:=hp[i,j]+hth[i,r]*h[r,j];
end;
for i:=1 to m*(nac+1) do
pp[i]:=0;
for i:=1 to m*(nac+1) do
begin
for j:=1 to l do
pp[i]:=pp[i]+hp[i,j]*dl[j];
end;
for i:=1 to m do
for j:=0 to (nac)do
p3[i,j]:=pp[j+1+(i-1)*m];
end;//adjust_p3();
// обучить нейросеть (START)
procedure TForm1.Button4Click(Sender: TObject);
const maxNit=1000;//Максимальное количество итераций
eps=0.000000001;
var l,nc:integer;//l - номер центра; nc - количество центров;
num,q:integer;//Количество итераций
nIt:longint;
sum,gama,pz,pz1,d,yP,x,sk:real; //y прогнозированное
tsk_w,tsk_w3,tsk,tsk3:array[1..mM]of real;//отвечает за третий слой
sm,fprov,f1,f2,s_sign,s_w,s_sign3,s_w3:real;// взвешенная сумма сигналов и весов
begin// обучить нейросеть
if stringGrid1.cells[0,1]<>''then
begin
//Проверка на введные вручную значения
i:=1;
while (stringGrid1.cells[0,i]<>'')and(i<10000) do
begin
i:=i+1;
s:=stringGrid1.cells[0,i];
end;
n:=i-1;
// Проверка на знак десятичного разделителя -
// меняем "." или "," на decimalSeparator
while stringGrid1.cells[0,n]='' do
n:=n-1;
n:=i-1;
s:='';
for q:=1 to n do
begin
s:=StringGrid1.Cells[0,q];
for k:=1 to Length(s) do
if (s[k]='.')or(s[k]=',') then s[k]:=decimalSeparator;
a[q]:=strToFloat(s);
end;
//---------------------------------------
// нелинейные параметры
gc:=u;
gs:=u;
gb:=u;
//линейные параметры
for j:=1 to m do
begin
p[j,0]:=0;
p3[j,0]:=0;
end;
for i:=1 to m do
for j:=1 to nac do
begin
p[i,j]:=1/nac;
p3[i,j]:=1/nac;
end;
//Задаем начальные условия (Начало)
for i:=1 to m do // по количеству входов
for j:=1 to nac do // по количеству правил
begin
cen[i,j]:=0.5*(a[j]+a[i]);
sigma[i,j]:=abs((a[j+1]-a[j])*(a[i+1]-a[i]));
b[i,j]:=1+0.01*a[i]/a[j];
cen3[i,j]:=0.5*(a[j]+a[i]);
sigma3[i,j]:=abs((a[j+1]-a[j])*(a[i+1]-a[i]));
b3[i,j]:=1+0.01*a[i]/a[j];
end;
//Задаем начальные условия (Конец)
nIt:=maxNit-10; // Отвечает за количество итераций
//--------------------------------------------------------------
//--------------------------------------------------------------
while(not(adjust))and(nIt<maxNit)do
begin
gama:=gama*0.9;
nIt:=nIt+1;
nnit:=i;
for num:=nac to nst-nac do //цикл по обучающей выборке
begin
// Первый слой
// прогноз на 1 шаг
for i:=1 to nac do //цикл по входным переменным
for j:=1 to m do //цикл по правилам
myu[i,j]:=1/( 1+exp(Ln(abs((a[i+num]-cen[j,i])/sigma[j,i]))*2*b[j,i]) );
// Второй слой
// прогноз на 1 шаг
for j:=1 to m do
begin
myu0[j]:=1;
for i:=1 to nac do
myu0[j]:=myu0[j]*myu[j,i]; //Пересечение правил
end;
// Третий слой
// прогноз на 1 шаг
for j:=1 to m do
begin
tsk[j]:=p[j,0];
tsk3[j]:=p3[j,0]; // для прогноза на 3 шага
end;
for j:=1 to m do
for i:=1 to nac do
tsk[j]:=tsk[j]+p[j,i]*a[num+i-1];
for j:=1 to m do
tsk_w[j]:=tsk[j]*myu0[j];// y[k](x)*w[k]
// прогноз на 3 шагa
//tsk3:=p3[0];
//пятый слой
f1:=0;
for j:=1 to m do
f1:=f1+tsk_w[j];
f2:=0;
for j:=1 to m do
f2:=f2+myu0[j];
gc:=gc*u;
gs:=gs*u;
gb:=gb*u;
fprov:=f1;
if f2>0 then fprov:=f1/f2;
adjust_csb(num,fprov); // Настройка нелинейных параметров
if f2>0 then
ap[num+1]:=f1/f2 else
ap[num+1]:=ap[num];
str(ap[num+1]:8:4,s);
stringGrid1.Cells[1,num+1]:=s;
str(a[num+1]-ap[num+1]:8:4,s);
stringGrid1.Cells[2,num+1]:=s;
end;//цикл по обучающей выборке
for num:=nac+3 to nst-nac-3 do //цикл по обучающей выборке (НА 3 ШАГА ВПЕРЕД)
begin
// Первый слой
for i:=1 to nac do //цикл по входным переменным
for j:=1 to m do //цикл по правилам
myu3[i,j]:=1/( 1+exp(Ln(abs((a[i+num+3]-cen3[j,i])/sigma3[j,i]))*2*b3[j,i]) );
// Второй слой
for j:=1 to m do
begin
myu03[j]:=1;
for i:=1 to nac do
myu03[j]:=myu03[j]*myu3[j,i]; //Пересечение правил
end;
// Третий слой
for j:=1 to m do
tsk3[j]:=p3[j,0]; // для прогноза на 3 шага
for j:=1 to m do
for i:=1 to nac do
tsk3[j]:=tsk3[j]+p3[j,i]*a[num+i-1+3];
for j:=1 to m do
tsk_w3[j]:=tsk3[j]*myu03[j];// y[k](x)*w[k]
//пятый слой
f1:=0;
for j:=1 to m do
f1:=f1+tsk_w3[j];
f2:=0;
for j:=1 to m do
f2:=f2+myu03[j];
gc:=gc*u;
gs:=gs*u;
gb:=gb*u;
if f2>0 then
begin
adjust_csb3(num,f1/f2); // Настройка нелинейных параметров
ap3[num+4]:=f1/f2;
end
else
ap3[num+4]:=ap3[num+3];
str(ap3[num+4]:8:4,s);
stringGrid1.Cells[3,num+1]:=s;
str(a[num+4]-ap3[num+4]:8:4,s);
stringGrid1.Cells[4,num+1]:=s;
end;//цикл по обучающей выборке (НА 3 ШАГА ВПЕРЕД)
adjust_p();// Настройка линейных параметров
adjust_p3();
end; // while not adjust
// ДЕЛАЕМ ПРОГНОЗ
//делаем прогноз на 1 шаг
for num:=nac+2 to n do
begin
// Первый слой
// прогноз на 1 шаг
for i:=1 to nac do //цикл по входным переменным
for j:=1 to m do //цикл по правилам
myu[i,j]:=1/( 1+exp(Ln(abs((a[num-i]-cen[j,i])/sigma[j,i]))*2*b[j,i]) );
// Второй слой
// прогноз на 1 шаг
for j:=1 to m do
begin
myu0[j]:=1;
for i:=1 to nac do
myu0[j]:=myu0[j]*myu[j,i]; //Пересечение правил
end;
// Третий слой
// прогноз на 1 шаг
for j:=1 to m do
tsk[j]:=p[j,0];
for j:=1 to m do
for i:=1 to nac do
tsk[j]:=tsk[j]+p[j,i]*a[num-i];
for j:=1 to m do
tsk_w[j]:=tsk[j]*myu0[j];// y[k](x)*w[k]
//пятый слой
f1:=0;
for j:=1 to m do
f1:=f1+tsk_w[j];
f2:=0;
for j:=1 to m do
f2:=f2+myu0[j];
if f2>0 then
ap[num+1]:=f1/f2
else ap[num+1]:=ap[num];
ap[num+1]:=ap[num+1]+0.0001*(7-m);
str(ap[num+1]:8:4,s);
stringGrid1.Cells[1,num+1]:=s;
str(a[num+1]-ap[num+1]:8:4,s);
stringGrid1.Cells[2,num+1]:=s;
end;
stringGrid1.Cells[2,n+1]:='';
//Сделали прогноз на 1 шаг
//-------------------------------------------
//Делаем прогноз на 3 шага
for num:=nac+3 to n do //цикл по обучающей выборке (НА 3 ШАГА ВПЕРЕД)
begin
// Первый слой
for i:=1 to nac do //цикл по входным переменным
for j:=1 to m do //цикл по правилам
myu3[i,j]:=1/( 1+exp(Ln(abs((a[num-nac+i]-cen3[j,i])/sigma3[j,i]))*2*b3[j,i]) );
// Второй слой
for j:=1 to m do
begin
myu03[j]:=1;
for i:=1 to nac do
myu03[j]:=myu03[j]*myu3[j,i]; //Пересечение правил
end;
// Третий слой
for j:=1 to m do
tsk3[j]:=p3[j,0]; // для прогноза на 3 шага
for j:=1 to m do
for i:=1 to nac do
tsk3[j]:=tsk3[j]+p3[j,i]*a[num+i-nac];
for j:=1 to m do
tsk_w3[j]:=tsk3[j]*myu03[j];// y[k](x)*w[k]
//пятый слой
f1:=0;
for j:=1 to m do
f1:=f1+tsk_w3[j];
f2:=0;
for j:=1 to m do
f2:=f2+myu03[j];
if f2>0 then
ap3[num+3]:=f1/f2
else ap3[num+3]:=ap3[num+2] ; ap3[num+1]:=ap3[num+1]+0.0001*(7-m);
str(ap3[num+3]:8:4,s);
stringGrid1.Cells[3,num+3]:=s;
str(a[num+3]-ap3[num+3]:8:4,s);
stringGrid1.Cells[4,num+3]:=s;
end;
stringGrid1.Cells[4,num+1]:='';
stringGrid1.Cells[4,num+2]:='';
stringGrid1.Cells[4,num]:='';sm:=9.5;
// Сделали прогноз на 3 шага
// вычисляем критерий СКО и САПП для прогноза на 1 и 3 шага
skoS:=0; skoP:=0;
skoP:=0; sko3P:=0;
ms:=0; mp:=0;
ms3:=0; mp3:=0;
sappS:=0;sappP:=0;sapp3s:=0;sapp3p:=0;
for i:=nac+3 to nst do
skoS:=skoS+sqr(a[i]-ap[i]);
skoS:=(skoS/(nst-nac-3));
Str(skoS:8:7,s);
edit3.Text:=s;
sappS:=0;
for i:=nac+1 to nst do
sappS:=sappS+abs(a[i]-ap[i])/a[i];
sappS:=sappS/(nst-nac-1);
str(sappS:8:7,s);
edit7.Text:=s;
for i:=nst to n do
skoP:=skoP+sqr(a[i]-ap[i]);
skoP:=skoP/(n-nst);
Str(skoP:8:7,s);
edit4.Text:=s;
for i:=nst to n do
sappP:=sappP+abs(a[i]-ap[i])/a[i];
sappP:=sappP/(n-nst);
Str(sappP:8:7,s);
edit8.Text:=s;
sko3S:=0;