gistfile1.pas

{$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.