Skip to content

Instantly share code, notes, and snippets.

/gist:3037153
Created Jul 3, 2012

Embed
What would you like to do?
{$APPTYPE CONSOLE}
Uses SysUtils, IniFiles;
type
vector = array of double;
matrix = array of array of double;
var
n: array of integer;
rez: array of vector;
w: array of matrix;
delta: array of vector;
layer: integer;
maxiter: integer;
min, max, eta0, eta1, h, eps: double;
function f(x: double): double;
begin
f := 1/(1+exp(-h*x));
end;
function df(x: double): double;
begin
df := h*x*(1-x);
end;
procedure ReadParams;
var
ini: TIniFile;
i: integer;
begin
ini := TIniFile.Create('.\nnet.ini');
layer := ini.ReadInteger('Parametri', 'Skaits', 1);
SetLength(n, layer+1);
for i := 0 to layer do
n[i] := ini.ReadInteger('Parametri', 'Slanis' + IntToStr(i), 1);
h := ini.ReadFloat('Parametri', 'h', 5.0);
eps := ini.ReadFloat('Parametri', 'eps', 1e-5);
eta0 := ini.ReadFloat('Parametri', 'eta0', 0.01);
eta1 := ini.ReadFloat('Parametri', 'eta1', 0.001);
maxiter := ini.ReadInteger('Parametri', 'maxiter', 1000000);
ini.Free;
end;
procedure GetMemory(d: boolean);
var
i: integer;
begin
SetLength(rez, layer+1);
SetLength(w, layer+1);
if d then
SetLength(delta, layer+1);
SetLength(rez[0], n[0]+1);
rez[0,n[0]] := 1;
for i := 1 to layer do
begin
SetLength(rez[i], n[i]+1);
rez[i,n[i]] := 1;
SetLength(w[i], n[i], n[i-1]+1);
if d then
SetLength(delta[i], n[i]);
end;
end;
procedure FreeMemory(d: boolean);
begin
Finalize(n);
Finalize(rez);
Finalize(w);
if d then
Finalize(delta);
end;
procedure Process;
var
l, i, j: integer;
tmp: double;
begin
for l := 1 to layer do
begin
for i := 0 to n[l]-1 do
begin
tmp := 0;
for j := 0 to n[l-1] do
tmp := tmp + rez[l-1,j]*w[l,i,j];
rez[l,i] := f(tmp);
end;
end;
end;
function CalcErr(const dst: vector): double;
var
i: integer;
e: double;
begin
e := 0;
for i := 0 to n[layer]-1 do
e := e + sqr(dst[i] - rez[layer,i]);
CalcErr := 0.5*e;
end;
procedure BackPropogate(eta: double; const dst: vector);
var
l, i, j: integer;
t: double;
begin
for i := 0 to n[layer]-1 do
delta[layer,i] := df(rez[layer,i])*(dst[i]-rez[layer,i]);
for l := layer-1 downto 1 do
begin
for i := 0 to n[l]-1 do
begin
t := 0;
for j := 0 to n[l+1]-1 do
t := t + delta[l+1,j] * w[l+1,j,i];
delta[l,i] := df(rez[l,i])*t;
end;
end;
for l := 1 to layer do
for i := 0 to n[l]-1 do
for j := 0 to n[l-1] do
w[l,i,j] := w[l,i,j] + delta[l,i]*eta*rez[l-1,j];
end;
procedure SaveNet;
var
inf: text;
l, i, j: integer;
begin
AssignFile(inf, 'nnet.net');
Rewrite(inf);
WriteLn(inf, layer);
for i := 0 to layer do
Write(inf, n[i], ' ');
WriteLn(inf);
WriteLn(inf, h);
WriteLn(inf, min, ' ', max);
for l := 1 to layer do
begin
WriteLn(inf);
for i := 0 to n[l-1] do
begin
for j := 0 to n[l]-1 do
Write(inf, w[l, j, i], ' ');
WriteLn(inf);
end;
end;
CloseFile(inf);
end;
procedure LoadNet;
var
l, i, j: integer;
inf: text;
begin
AssignFile(inf, 'nnet.net');
Reset(inf);
ReadLn(inf, layer);
SetLength(n, layer+1);
for i := 0 to layer do
Read(inf, n[i]);
ReadLn(inf);
GetMemory(false);
ReadLn(inf, h);
ReadLn(inf, min, max);
for l := 1 to layer do
begin
ReadLn(inf);
for i := 0 to n[l-1] do
begin
for j := 0 to n[l]-1 do
Read(inf, w[l, j, i]);
ReadLn(inf);
end;
end;
CloseFile(inf);
end;
procedure Learning;
var
samples: array of vector;
dst: array of vector;
inf: text;
cnt: integer;
perc, iter, l, i, j: integer;
t, eta, err: double;
begin
WriteLn('Apmaaciiba:');
ReadParams;
GetMemory(true);
WriteLn(' Ielasu paraugus.');
AssignFile(inf, 'nnet.learn');
Reset(inf);
ReadLn(inf, cnt);
SetLength(samples, cnt, n[0]);
SetLength(dst, cnt, n[layer]);
ReadLn(inf, min, max);
for i := 0 to cnt-1 do
begin
ReadLn(inf);
for j := 0 to n[0]-1 do
begin
if eoln(inf) then ReadLn(inf);
Read(inf, t);
samples[i, j] := (t-min)/(max-min);
end;
ReadLn(inf);
for j := 0 to n[layer]-1 do
begin
if eoln(inf) then ReadLn(inf);
Read(inf, t);
dst[i,j] := (t-min)/(max-min);
end;
end;
CloseFile(inf);
Randomize;
for l := 1 to layer do
for i := 0 to n[l-1] do
for j := 0 to n[l]-1 do
w[l, j, i] := 0.6*random-0.3;
iter := 0;
err := 1000;
perc := 5;
WriteLn(' Apmaacu tiiklu.');
while (iter<maxiter) and (err>eps) do
begin
if (iter*100) div maxiter >= perc then
begin
WriteLn(' Iteraacija=',iter,' (',iter*100 div maxiter,'%) Kljuuda=',err:1:10);
perc := perc + 5;
end;
err := 0;
eta := eta0 + iter*(eta1-eta0)/maxiter;
for i := 0 to cnt-1 do // viena epoha
begin
for j := 0 to n[0]-1 do
rez[0,j] := samples[i, j];
{
l := random(n[0]);
rez[0, l] := rez[0, l] + 0.2*random-0.1;
if rez[0, l]<0 then
rez[0, l] := 0
else if rez[0, l]>1 then
rez[0, l] := 1;
}
Process;
err := err + CalcErr(dst[i]);
BackPropogate(eta, dst[i]);
end;
iter := iter + 1;
end;
WriteLn(' Iteraacijas=',iter,' Kljuuda=',err:1:10);
WriteLn(' Saglabaaju tiikla datus!');
SaveNet;
FreeMemory(true);
WriteLn(' Pabeigts');
end;
procedure Using;
var
inf, outf: text;
i: integer;
t: double;
begin
WriteLn(' Ielaadeeju tiikla datus!');
LoadNet;
AssignFile(inf, 'nnet.use');
Reset(inf);
AssignFile(outf, 'nnet.rez');
Rewrite(outf);
WriteLn(' Laizhu cauri paraugus...');
while not eof(inf) do
begin
for i := 0 to n[0]-1 do
begin
if eoln(inf) then ReadLn(inf);
Read(inf, t);
rez[0,i] := (t-min)/(max-min);
end;
ReadLn(inf);
Process;
for i := 0 to n[layer]-1 do
Write(outf, rez[layer,i]*(max-min)+min:1:5, ' ');
WriteLn(outf);
end;
CloseFile(inf);
CloseFile(outf);
FreeMemory(false);
WriteLn(' Pabeigts');
end;
begin
if ParamStr(1) = 'learn' then
Learning
else if ParamStr(1) = 'use' then
Using
else
begin
WriteLn('Lietojums: nnet.exe {learn|use}');
WriteLn;
WriteLn(' learn - maaciities');
WriteLn(' use - straadaat');
ReadLn;
end;
end.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.