unit NNunit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Dialogs, Math, ComCtrls, Forms;

type
  TExtendedArray = Array of Extended;
  TLongintArray = Array of Longint;
  TTrainingsset = Array of Array[Boolean] of TExtendedArray;

  PTEbene = ^TEbene;

  TNeuron = class(TObject)
    Gewichte,altGew:                 TExtendedArray;
    Nummer:                          Longint;
    Schwelle,altSch,Wert,rohWert,
      dPhi,ddPhi,Schranke,
      Fehler,Ableitung,Kruemmung:    Extended;
    constructor create(vorherGroesze, Nr: Longint); overload;
    constructor create(Neu: TNeuron); overload;
    destructor destroy; override;
    procedure berechnen(Elter: PTEbene);
    procedure FehlerRueckPropagation(Kind: PTEbene);
    procedure KruemmungVorPropagation(Elter: PTEbene);
    procedure Ausgabeschichtfehler(Op: TExtendedArray);
    procedure FehlerEinarbeiten(Elter: PTEbene; Lernrate: Extended);
    procedure rueckgaengig;
    function Gradientquadrat(Elter: PTEbene): Extended;
    function toString: String; override;
  end;

  TEbene = class(TObject)
    Neuronen: array of TNeuron;
    constructor create(Groesze,vorherGroesze: Longint); overload;
    constructor create(Eb: TEbene; WerteZufaellig: Boolean); overload;
    destructor destroy; override;
    procedure berechnen(Elter: PTEbene);
    procedure FehlerRueckPropagation(Kind: PTEbene);
    procedure KruemmungVorPropagation(Elter: PTEbene);
    procedure Ausgabeschichtfehler(Op: TExtendedArray);
    procedure FehlerEinarbeiten(Elter: PTEbene; Lernrate: Extended);
    procedure rueckgaengig;
    function Gradientquadrat(Elter: PTEbene): Extended;
    function Kruemmung(Op: TExtendedArray): Extended;
    function toString: String; override;
  end;

  TNeuronalesNetz = class(TObject)
    Ebenen: array of TEbene;
    constructor create(Tiefe,Groesze: Longint); overload;
    constructor create(Groesze: TLongintArray); overload;
    constructor create(NN: TNeuronalesNetz; WerteZufaellig: Boolean); overload;
    constructor create(NN: TNeuronalesNetz); overload;
    destructor destroy; override;
    function Output(Input: TExtendedArray): TExtendedArray;
    function Lerne(Ip,Op: TExtendedArray; Lernrate: Extended; Meldungen: Boolean): Extended;
    procedure Trainieren(LR: Extended; TS: TTrainingsset; PB: TProgressBar; AP: TApplication; Sortierung: Longint; Nachrichten: Boolean; out Ausgabe: String);
    function Pruefen(Anz: Longint; TS: TTrainingsset; PB: TProgressBar; AP: TApplication; out Ausgabe: String): Extended;
    function toString: String; override;
  end;

implementation

const Sf = 5;

constructor TNeuron.create(vorherGroesze, Nr: Longint);
var I: Longint;
begin
  inherited create;
  Nummer:=Nr;
  Setlength(Gewichte,vorherGroesze);
  Setlength(altGew,vorherGroesze);
  for I:=0 to length(Gewichte)-1 do begin
    Gewichte[I]:=max(-Schranke,min(Schranke,(random-0.5)/vorherGroesze));
    altGew[I]:=0;
  end;
  Schwelle:=max(-Schranke,min(Schranke,0.2*random-0.1));
  altSch:=0;
  rohWert:=0;
  Wert:=1/2;
  dPhi:=Sf/4;
  ddPhi:=0;
  Schranke:=100;
  Fehler:=0;
  Ableitung:=0;
  Kruemmung:=0;
end;

constructor TNeuron.create(Neu: TNeuron);
var I: Longint;
begin
  inherited create;
  Nummer:=Neu.Nummer;
  Setlength(Gewichte,length(Neu.Gewichte));
  for I:=0 to length(Gewichte)-1 do
    Gewichte[I]:=Neu.Gewichte[I];
  Setlength(altGew,length(Neu.altGew));
  for I:=0 to length(altGew)-1 do
    altGew[I]:=Neu.altGew[I];
  Schwelle:=neu.Schwelle;
  altSch:=neu.altSch;
  rohWert:=neu.rohWert;
  Wert:=neu.Wert;
  dPhi:=neu.dPhi;
  ddPhi:=neu.ddPhi;
  Fehler:=neu.Fehler;
  Ableitung:=neu.Ableitung;
  Kruemmung:=neu.Kruemmung;
end;

destructor TNeuron.destroy;
begin
  Setlength(Gewichte,0);
  Setlength(altGew,0);
  inherited destroy;
end;

procedure TNeuron.berechnen(Elter: PTEbene);
var I: Longint;
begin
  rohWert:=-Schwelle;
  for I:=0 to length(Gewichte)-1 do
    rohWert:=rohWert + Elter^.Neuronen[I].Wert*Gewichte[I];
  if rohWert>10/Sf then Wert:=1
  else begin
    if rohWert<-10/Sf then Wert:=0
    else Wert:=1/(1+Exp(-Sf*rohWert));
  end;
  dPhi:=-Sf*Wert*(Wert-1);
  ddPhi:=-Sf*dPhi*(2*Wert-1);
end;

procedure TNeuron.FehlerRueckPropagation(Kind: PTEbene);
var I: Longint;
begin
  Fehler:=0;
  for I:=0 to length(Kind^.Neuronen)-1 do
    Fehler:=Fehler+Kind^.Neuronen[I].Fehler*Kind^.Neuronen[I].Gewichte[Nummer];
  Fehler:=Fehler*dPhi;
end;

procedure TNeuron.KruemmungVorPropagation(Elter: PTEbene);
var I:           Longint;
    Teil1,Teil2: Extended;
begin
  Teil1:=Fehler; // d Schwelle
  Teil2:=0;
  for I:=0 to length(Elter^.Neuronen)-1 do begin
    Teil1:=Teil1
      + Gewichte[I]*Elter^.Neuronen[I].Ableitung                         // w_ij * d n_i
      + Fehler*sqr(Elter^.Neuronen[I].Wert);                             // n_i * d w_ij
    Teil2:=Teil2
      + Gewichte[I]*Elter^.Neuronen[I].Kruemmung                         // w_ij * d2 n_i
      + 2*Fehler*Elter^.Neuronen[I].Wert * Elter^.Neuronen[I].Ableitung; // 2 * d w_ij * d n_i
  end;
  Kruemmung:=Teil2 * dPhi  // Teil2 * phi'
    + sqr(Teil1) * ddPhi;  // Teil1^2 * phi''
  Ableitung:=Teil1 * dPhi; // Teil1 * phi'
end;

procedure TNeuron.Ausgabeschichtfehler(Op: TExtendedArray);
begin
  Fehler:=Wert-Op[Nummer];
  Fehler:=Fehler*dPhi;
end;

procedure TNeuron.FehlerEinarbeiten(Elter: PTEbene; Lernrate: Extended);
var I:   Longint;
begin
  for I:=0 to length(Gewichte)-1 do begin
    altGew[I]:=Gewichte[I];
    Gewichte[I]:=max(-Schranke,min(Schranke,Gewichte[I]-Lernrate*Fehler*Elter^.Neuronen[I].Wert));
  end;
  altSch:=Schwelle;
  Schwelle:=max(-Schranke,min(Schranke,Schwelle-Lernrate*Fehler));
end;

procedure TNeuron.rueckgaengig;
var I:   Longint;
begin
  for I:=0 to length(Gewichte)-1 do
    Gewichte[I]:=altGew[I];
  Schwelle:=altSch;
end;

function TNeuron.Gradientquadrat(Elter: PTEbene): Extended;
var I: Longint;
begin
  result:=0;
  for I:=0 to length(Elter^.Neuronen)-1 do
    result:=result+sqr(Elter^.Neuronen[I].Wert*Gewichte[I]*Fehler);
end;

function TNeuron.toString: String;
var I: Longint;
begin
  result:=floattostr(Schwelle);
  for I:=0 to length(Gewichte)-1 do
    result:=result+' '+floattostr(Gewichte[I]);
end;

constructor TEbene.create(Groesze,vorherGroesze: Longint);
var I: Longint;
begin
  inherited create;
  Setlength(Neuronen,Groesze);
  for I:=0 to length(Neuronen)-1 do
    Neuronen[I]:=TNeuron.create(vorherGroesze,I);
end;

constructor TEbene.create(Eb: TEbene; WerteZufaellig: Boolean);
var I: Longint;
begin
  inherited create;
  Setlength(Neuronen,length(Eb.Neuronen));
  for I:=0 to length(Neuronen)-1 do
    if WerteZufaellig then
      Neuronen[I]:=TNeuron.create(length(Eb.Neuronen[0].Gewichte),I)
    else Neuronen[I]:=TNeuron.create(Eb.Neuronen[I]);
end;

destructor TEbene.destroy;
var I: Longint;
begin
  for I:=0 to length(Neuronen)-1 do
    Neuronen[I].Free;
  Setlength(Neuronen,0);
  inherited destroy;
end;

procedure TEbene.berechnen(Elter: PTEbene);
var I: Longint;
begin
  for I:=0 to length(Neuronen)-1 do
    Neuronen[I].berechnen(Elter);
end;

procedure TEbene.FehlerRueckPropagation(Kind: PTEbene);
var I: Longint;
begin
  for I:=0 to length(Neuronen)-1 do
    Neuronen[I].FehlerRueckPropagation(Kind);
end;

procedure TEbene.KruemmungVorPropagation(Elter: PTEbene);
var I: Longint;
begin
  for I:=0 to length(Neuronen)-1 do
    Neuronen[I].KruemmungVorPropagation(Elter);
end;

procedure TEbene.Ausgabeschichtfehler(Op: TExtendedArray);
var I: Longint;
begin
  for I:=0 to length(Neuronen)-1 do
    Neuronen[I].Ausgabeschichtfehler(Op);
end;

procedure TEbene.FehlerEinarbeiten(Elter: PTEbene; Lernrate: Extended);
var I: Longint;
begin
  for I:=0 to length(Neuronen)-1 do
    Neuronen[I].FehlerEinarbeiten(Elter,Lernrate);
end;

procedure TEbene.rueckgaengig;
var I: Longint;
begin
  for I:=0 to length(Neuronen)-1 do
    Neuronen[I].rueckgaengig;
end;

function TEbene.Gradientquadrat(Elter: PTEbene): Extended;
var I: Longint;
begin
  result:=0;
  for I:=0 to length(Neuronen)-1 do
    result:=result + Neuronen[I].Gradientquadrat(Elter);
end;

function TEbene.Kruemmung(Op: TExtendedArray): Extended;
var I: Longint;
begin
  result:=0;
  for I:=0 to length(Neuronen)-1 do
    result:=result
      + sqr(Neuronen[I].Ableitung)
      + (Neuronen[I].Wert-Op[I])*Neuronen[I].Kruemmung;
end;

function TEbene.toString: String;
var I: Longint;
begin
  result:='';
  for I:=0 to length(Neuronen)-1 do begin
    result:=result+Neuronen[I].toString;
    if I<length(Neuronen)-1 then result:=result+#13;
  end;
end;

constructor TNeuronalesNetz.create(Tiefe,Groesze: Longint);
var G: TLongintArray;
    I: Longint;
begin
  setlength(G,Tiefe);
  for I:=0 to length(G)-1 do
    G[I]:=Groesze;
  create(G);
end;

constructor TNeuronalesNetz.create(Groesze: TLongintArray);
var I: Longint;
begin
  inherited create;
  Setlength(Ebenen,length(Groesze));
  for I:=0 to length(Ebenen)-1 do
    Ebenen[I]:=TEbene.create(Groesze[I],Groesze[I-Byte(I>0)]*Byte(I>0));
end;

constructor TNeuronalesNetz.create(NN: TNeuronalesNetz);
begin
  create(NN,false);
end;

constructor TNeuronalesNetz.create(NN: TNeuronalesNetz; WerteZufaellig: Boolean);
var I: Longint;
begin
  inherited create;
  setlength(Ebenen,length(NN.Ebenen));
  for I:=0 to length(Ebenen)-1 do
    Ebenen[I]:=TEbene.Create(NN.Ebenen[I],WerteZufaellig);
end;

destructor TNeuronalesNetz.destroy;
var I: Longint;
begin
  for I:=0 to length(Ebenen)-1 do
    Ebenen[I].Free;
  Setlength(Ebenen,0);
  inherited destroy;
end;

function TNeuronalesNetz.Output(Input: TExtendedArray): TExtendedArray;
var I: Longint;
begin
  if length(Input)<>length(Ebenen[0].Neuronen) then begin
    MessageDlg('Eingabelänge ('+inttostr(length(Input))+') ist ungleich der Anzahl Neuronen in der ersten Ebene ('+inttostr(length(Ebenen[0].Neuronen))+')!',mtError,[mbOk],0);
    exit;
  end;
  for I:=0 to length(Input)-1 do
    Ebenen[0].Neuronen[I].Wert:=Input[I];
  for I:=1 to length(Ebenen)-1 do
    Ebenen[I].berechnen(@(Ebenen[I-1]));
  Setlength(result,length(Ebenen[length(Ebenen)-1].Neuronen));
  for I:=0 to length(result)-1 do
    result[I]:=Ebenen[length(Ebenen)-1].Neuronen[I].Wert;
end;

function TNeuronalesNetz.Lerne(Ip,Op: TExtendedArray; Lernrate: Extended; Meldungen: Boolean): Extended;
var I,Ausdauer: Longint;
    iO:         TExtendedArray;
    Fehler0,
      lFehler,
      aFehler,
      LR:       Extended;
begin
  iO:=Output(Ip);
  Fehler0:=0;
  for I:=0 to length(iO)-1 do
    Fehler0:=Fehler0+sqr(iO[I]-Op[I]);

  lFehler:=Fehler0;
  Ausdauer:=100;

  repeat
    Ebenen[length(Ebenen)-1].Ausgabeschichtfehler(Op);
    for I:=length(Ebenen)-2 downto 1 do
      Ebenen[I].FehlerRueckPropagation(@(Ebenen[I+1]));
    LR:=0;
    for I:=1 to length(Ebenen)-1 do begin
      Ebenen[I].KruemmungVorPropagation(@(Ebenen[I-1]));
      LR:=LR+Ebenen[I].Gradientquadrat(@(Ebenen[I-1]));
    end;
    LR:=LR/Ebenen[length(Ebenen)-1].Kruemmung(Op);
    if LR<0 then
      LR:=Lernrate;
    For I:=length(Ebenen)-1 downto 1 do
      Ebenen[I].FehlerEinarbeiten(@(Ebenen[I-1]),LR);
    iO:=Output(Ip);
    aFehler:=0;
    for I:=0 to length(iO)-1 do
      aFehler:=aFehler+sqr(iO[I]-Op[I]);
    if aFehler>lFehler then begin
      For I:=1 to length(Ebenen)-1 do
        Ebenen[I].rueckgaengig;
      if Meldungen and (aFehler-lFehler >= 0.1 * Fehler0) then
        MessageDlg('Keine Verbesserung erreicht! '+floattostr(aFehler-lFehler)+'/'+floattostr(lFehler),mtError,[mbOk],0);
      LR:=LR/2;
    end;
    if aFehler-lFehler >= -0.01 * Fehler0 then dec(Ausdauer);
    lFehler:=aFehler;
  until true; //(aFehler<0.01*Fehler0) or (Ausdauer<0);

(*  lFehler:=Fehler0;

  LR:=Lernrate;

  repeat
    Ebenen[length(Ebenen)-1].Ausgabeschichtfehler(Op);
    For I:=length(Ebenen)-2 downto 1 do
      Ebenen[I].FehlerRueckPropagation(@(Ebenen[I+1]));
    For I:=length(Ebenen)-1 downto 1 do
      Ebenen[I].FehlerEinarbeiten(@(Ebenen[I-1]),LR);
    iO:=Output(Ip);
    aFehler:=0;
    for I:=0 to length(iO)-1 do
      aFehler:=aFehler+sqr(iO[I]-Op[I]);
    if aFehler-lFehler >= 0 then LR:=LR*0.2;
    if lFehler-aFehler > 0 then LR:=LR*1.2;
    lFehler:=aFehler;
  until (LR>100*Lernrate) or (LR<0.01*Lernrate) or (aFehler<0.1*Fehler0); *)
  result:=Fehler0-aFehler;
end;

procedure TNeuronalesNetz.Trainieren(LR: Extended; TS: TTrainingsset; PB: TProgressBar; AP: TApplication; Sortierung: Longint; Nachrichten: Boolean; out Ausgabe: String);
var I,J,K:          Longint;
    Erfolg,
      Fortschritt,
      Rueckschritt: Extended;
    Perm:           TLongintArray;
begin
  Setlength(Perm,length(TS));
  case Sortierung of
    0: begin
      for I:=0 to length(Perm)-1 do
        Perm[I]:=-1;
      for I:=0 to length(Perm)-1 do begin
        J:=Random(length(Perm)-I);
        K:=-1;
        repeat
          inc(K);
          if Perm[K]<>-1 then inc(J);
        until K>=J;
        Perm[J]:=I;
      end;
    end;
    1:
      for I:=0 to length(Perm)-1 do
        Perm[I]:=I;
    -1:
      for I:=0 to length(Perm)-1 do
        Perm[I]:=length(Perm)-1-I;
  end{of case};
  PB.Min:=1;
  PB.Max:=Min(100,length(TS));
  PB.Position:=1;
  PB.Visible:=True;
  Fortschritt:=0;
  Rueckschritt:=0;
  for I:=0 to length(TS)-1 do begin
    Erfolg:=Lerne(TS[Perm[I],false],TS[Perm[I],true],LR,Nachrichten);
    Rueckschritt:=Max(Rueckschritt,-Erfolg);
    Fortschritt:=Max(Fortschritt,Erfolg);
    if ((100*I) div length(TS) > (100*(I-1)) div length(TS)) then begin
      PB.StepIt;
      AP.ProcessMessages;
    end;
  end;
  PB.Visible:=False;
  Ausgabe:='Fortschritt: '+floattostr(Fortschritt)+' Rückschritt: '+floattostr(Rueckschritt);
end;

function TNeuronalesNetz.Pruefen(Anz: Longint; TS: TTrainingsset; PB: TProgressBar; AP: TApplication; out Ausgabe: String): Extended;
var I,J,K,L,gut,StGut: Longint;
    dasistgut:         Boolean;
    Fehler:            Extended;
    Op:                TExtendedArray;
    Vari:              TLongintArray;
begin
  Anz:=min(Anz,length(TS));
  Setlength(Vari,Anz);
  if Anz>=length(TS) then begin
    for I:=0 to length(Vari)-1 do
      Vari[I]:=I;
  end
  else begin
    for I:=0 to length(Vari)-1 do begin
      J:=Random(length(TS)-I);
      K:=0;
      while K<=J do begin
        for L:=0 to I-1 do
          if Vari[L]=K then begin
            inc(J);
            break;
          end;
        inc(K);
      end;
      Vari[I]:=J;
    end;
  end;
  gut:=0;
  StGut:=0;
  PB.Min:=1;
  PB.Max:=Min(100,Anz);
  PB.Position:=1;
  PB.Visible:=True;
  Fehler:=0;
  for I:=0 to length(Vari)-1 do begin
    Op:=Output(TS[Vari[I],false]);
    dasistgut:=true;
    for J:=0 to 9 do begin
      Fehler:=Fehler + Sqr(Op[J] - TS[Vari[I],true,J]);
      dasistgut:=dasistgut and ((Op[J]<0.5) xor (TS[Vari[I],true,J]>=0.5));
      StGut:=StGut + Byte((Op[J]<0.5) xor (TS[Vari[I],true,J]>=0.5));
    end;
    gut:=gut+byte(dasistgut);
    if ((100*I) div Anz > (100*(I-1)) div Anz) then begin
      PB.StepIt;
      AP.ProcessMessages;
    end;
  end;
  PB.Visible:=False;
  Ausgabe:=inttostr(gut)+'/'+inttostr(Anz)+' -> '+floattostr(100*gut/Anz)+'%, '+floattostr(100*Stgut/Anz/10)+'% Fehler: '+floattostr(Fehler/Anz);
  result:=(gut+0.01)/Anz;
end;

function TNeuronalesNetz.toString: String;
var I: Longint;
begin
  result:='';
  for I:=1 to length(Ebenen)-1 do begin
    result:=result+Ebenen[I].toString;
    if I<length(Ebenen)-1 then
      result:=result+#13#13;
  end;
end;


end.