Delphi 5 for Professionals/DELPHI5.iso/AddOns/Components/TEECHART/Delphi1_And_Delphi2/EXAMPLES/OTHER/NEURAL/NEURAL.PAS

Pascal/Delphi Source File | 1998-10-24 | 16.3 KB | 654 lines

{**********************************************}
{   TeeChart                                   }
{   Neural Network Component                   }
{   Copyright (c) 1996 by David Berneda        }
{**********************************************}
unit neural;

{ This unit contains a complete set of Native Delphi components
  to implement a Neural Network.

  Hierarchy:

  TNeuralLayer
      ----------------   TInputLayer
      ----------------   TMediumLayer
      ----------------   TOutputLayer

  TNeuralNet

}
interface

Uses Classes,SysUtils;

Type  Float=Single;
      TNeuralNetMode=(nnmLearn,nnmProcess);
      TNeuralNetAction=(nnaContinue,nnaStop);

Const MaxSamples = 250;  { max number of patterns }
      MaxNeurodes= 50;   { max number of Layer neurodes }

      FactorSigmoid:Float=1.0;

type TNeuralSample = Array[1..MaxNeurodes] of Float;

     TNeuralSamples=class
     private
       FSamples:Array[1..MaxSamples] of ^TNeuralSample;
     public
       Constructor Create;
       Destructor Destroy; override;
       Procedure Load(Var f:Text; NumNeurodes,NumSample:Integer);
       Function GetData(t,tt:Integer):Float;
     { }
       property Sample[t,tt:Integer]:Float read GetData;
     end;

     TNeuralWeight= Array[1..MaxSamples] of Float;

     TNeuralWeights=class
     private
       FWeights:Array[1..MaxNeurodes] of ^TNeuralWeight;
     protected
       Function GetWeight(NumSample,NeurodeIndex:Integer):Float;
     public
       Constructor Create;
       Destructor Destroy; override;
       Procedure Randomize;
       Procedure Load(Var f:Text; NumNeurodes,NumSamples:Integer);
       Procedure Save(Var f:Text; NumNeurodes,NumSamples:Integer);
     { }
       property Weight[Neurode,Sample:Integer]:Float read GetWeight;
     end;

     TNeuralLayer=class
     private
       FSize:Integer;
     public
       property Size:Integer read FSize;
     end;

     TInputLayer=class(TNeuralLayer)
     private
       FNumSamples : Integer;
       FSamples    : TNeuralSamples;
     public
       Constructor Create;
       Destructor Destroy; override;
       Procedure ReadData(Var f:Text);
       Function CalcLength(NumSample:Integer):Float;

       property NumSamples:Integer read FNumSamples;
       property Samples:TNeuralSamples read FSamples;
     End;

     TOutputLayer=class;

     TMediumLayer=class(TNeuralLayer)
     private
       FWeights: TNeuralWeights;
       FOutput,
       FError  : TNeuralSample;
     public
       Constructor Create;
       Destructor Destroy; override;
       procedure DoForward(NumSample:Integer; Input:TInputLayer);
       procedure DoError(Output:TOutputLayer);
       procedure AdjustWeights( NumSample :Integer; Const Beta:Float; Input:TInputLayer );
       Function  CalcLength:Float;
       Procedure Randomize;
       Procedure LoadWeights(Var f:Text);
       procedure SaveWeights(Input:TInputLayer);
       { }
       property Weights:TNeuralWeights read FWeights;
     end;

     TOutputLayer=class(TNeuralLayer)
     private
       FStandard,
       FMaxStandard,
       FFinalErr   : Float;
       FWeights    : TNeuralWeights;
       FOutput,
       FError      : TNeuralSample;
       FTotalError : TNeuralWeight;
       FSamples    : TNeuralSamples;
     public
       Constructor Create;
       Destructor Destroy; override;
       Procedure DoForward(Medium:TMediumLayer);
       procedure DoError(NumSample:Integer);
       procedure AdjustWeights(Const Beta:Float; Medium:TMediumLayer);
       Procedure Randomize;
       procedure AppendWeights(Medium:TMediumLayer);
       Procedure LoadWeights(Var f:Text);
       function  CheckOutError( var tmpError : boolean; NumPats:Integer) : boolean;
       Function GetOutput(NeurodeIndex:Longint):Float;
       Function GetOutputSum:Float;
       Procedure Load(Const FileName:String; NumSamples:Integer);
       { }
       property FinalErr:Float read FFinalErr;
       property Samples:TNeuralSamples read FSamples;
       property Weights:TNeuralWeights read FWeights;
     End;

     TNeuralNet=class;

    TNeuralNetOnIteration=procedure (Sender:TNeuralNet; Var Action:TNeuralNetAction) of object;

    TNeuralNet=class(TComponent)
    private
      FAdjustBeta    : Boolean;
      FIterationCount: Longint;
      FLearned       : Boolean;
      FCurrentMode   : TNeuralNetMode;
      FInput  : TInputLayer;
      FMedium : TMediumLayer;
      FOutput : TOutputLayer;
      FBeta   : Float;
      { events }
      FOnIteration:TNeuralNetOnIteration;
    public
      Constructor Create(AOwner:TComponent); override;
      Destructor Destroy; override;
      procedure DoBackPass( NumSample : Integer );
      procedure DoForwardPass( NumSample:Integer);
      procedure RandomizeWeights;
      Procedure LoadWeights;
      Procedure ReadDataFile(Const FileName:String);
      Procedure Initialize;
      Procedure StartLearning;
      Procedure SaveWeights;
      Function CalcGuessedOutput(NumSample:Integer):Float;
      { }
      property IterationCount:Longint read FIterationCount;
      property Input:TInputLayer read FInput;
      property Medium:TMediumLayer read FMedium;
      property Output:TOutputLayer read FOutput;
      property Learned:Boolean read FLearned write FLearned;
      property Beta:Float read FBeta;
    published
      property OnIteration:TNeuralNetOnIteration read FOnIteration
                                                 write FOnIteration;
    End;

implementation

{ Useful Functions }
Function OpenText(Var f:Text; Const Path:String):Boolean;
Begin
  Assign(f,Path);
  {$I-}
  Reset(f);
  {$I+}
  result:=IOResult=0;
End;

Function AppendText(Var f:Text; Const Path:String):Boolean;
Begin
  Assign(f,Path);
  {$I-}
  Append(f);
  {$I+}
  result:=IOResult=0;
End;

Function OpenTextWrite(Var f:Text; Const Path:String):Boolean;
Begin
  Assign(f,Path);
  {$I-}
  Rewrite(f);
  {$I+}
  result:=IOResult=0;
End;

{ TNeuralSamples }
Constructor TNeuralSamples.Create;
var t:Integer;
begin
  inherited Create;
  for t:=1 to MaxSamples do New(FSamples[t]);
end;

Destructor TNeuralSamples.Destroy;
var t:Integer;
begin
  for t:=1 to MaxSamples do Dispose(FSamples[t]);
  inherited Destroy;
end;

Procedure TNeuralSamples.Load(Var f:Text; NumNeurodes,NumSample:Integer);
var i:Integer;
begin
  for i:= 1 to NumNeurodes do
  begin
    Read(f,FSamples[NumSample]^[i]);
    if FSamples[NumSample]^[i]>=1 then FSamples[NumSample]^[i]:=0.999999
    Else
    if FSamples[NumSample]^[i]<=0 then FSamples[NumSample]^[i]:=0.000001;
  end;
end;

Function TNeuralSamples.GetData(t,tt:Integer):Float;
begin
  result:=FSamples[t]^[tt];
end;

{ TNeuralWeights }
Constructor TNeuralWeights.Create;
Var t:Longint;
begin
  inherited Create;
  for t:=1 to MaxNeurodes do New(FWeights[t]);
end;

Destructor TNeuralWeights.Destroy;
Var t:Longint;
begin
  for t:=1 to MaxNeurodes do Dispose(FWeights[t]);
  inherited Destroy;
end;

Function TNeuralWeights.GetWeight(NumSample,NeurodeIndex:Integer):Float;
begin
  result:=FWeights[NeurodeIndex]^[NumSample];
end;

Procedure TNeuralWeights.Randomize;
Var neurode,i:integer;
Begin
  for neurode:=1 to MaxNeurodes do
    for i:=1 to MaxSamples do
        FWeights[neurode]^[i]:=((random(32768)/32767.0)-0.5)/2.0;
End;

Procedure TNeuralWeights.Load(Var f:Text; NumNeurodes,NumSamples:Integer);
Var neurode,i:integer;
Begin
  for neurode:=1 to NumNeurodes do
      for i:=1 to NumSamples do readln(f,FWeights[neurode]^[i]);
end;

Procedure TNeuralWeights.Save(Var f:Text; NumNeurodes,NumSamples:Integer);
Var neurode,i:integer;
Begin
  for Neurode:=1 to NumNeurodes do
    for i:=1 to NumSamples do writeln(f,FWeights[Neurode]^[i]:8:3 );
end;

{ TInputLayer }
Constructor TInputLayer.Create;
begin
  inherited Create;
  FSamples:=TNeuralSamples.Create;
end;

Destructor TInputLayer.Destroy;
begin
  FSamples.Free;
  inherited Destroy;
end;

Procedure TInputLayer.ReadData(Var f:Text);
Begin
  FNumSamples:=0;
  While not eof(f) do
  begin
    Inc(FNumSamples);
    FSamples.Load(f,FSize,FNumSamples);
  end;
  Dec(FNumSamples);
End;

Function TInputLayer.CalcLength(NumSample:Integer):Float;
Var Weight:integer;
Begin
  result:=0;
  for Weight:=1 to FSize do result:=result+sqr(FSamples.FSamples[NumSample]^[Weight]);
  if result<0.1 then result:=0.1;
End;

{ TMediumLayer }
Constructor TMediumLayer.Create;
begin
  inherited Create;
  FWeights:=TNeuralWeights.Create;
end;

Destructor TMediumLayer.Destroy;
begin
  FWeights.Free;
  inherited Destroy;
end;

Procedure TMediumLayer.AdjustWeights( NumSample : Integer; Const Beta:Float; Input:TInputLayer);
var tmpBeta,Length : Float;
    Weight, neurode : integer;
Begin
  Length:=Input.CalcLength(NumSample);
  For Neurode := 1 to FSize do
  Begin
    tmpBeta:=Beta*FError[Neurode]/Length;
    For Weight := 1 to Input.FSize do
        FWeights.FWeights[Neurode]^[Weight]:=
           FWeights.FWeights[Neurode]^[Weight]+
             tmpBeta*Input.FSamples.FSamples[NumSample]^[Weight];
  End;
End;

Procedure TMediumLayer.DoForward(NumSample:Integer; Input:TInputLayer);
var Sum : Float;
    Neurode, i : integer;
begin
  for Neurode := 1 to FSize do
  begin
    Sum := 0.0;
    for i:=1 to Input.FSize do
        Sum:=Sum+(FWeights.FWeights[Neurode]^[i]*
                  Input.FSamples.FSamples[NumSample]^[i]);
    FOutput[Neurode]:=1/(1+exp(-FactorSigmoid*Sum));
  end;
end;

Procedure TMediumLayer.DoError(Output:TOutputLayer);
var Sum : Float;
    Neurode, i : integer;
begin
  for Neurode := 1 to FSize do
  begin
    Sum:=0;
    for i:=1 to Output.FSize do Sum:=Sum+(Output.FWeights.FWeights[i]^[Neurode]*Output.FError[i]);
    FError[Neurode]:=FOutput[Neurode]*(1-FOutput[Neurode])*Sum;
  end;
end;

Function TMediumLayer.CalcLength:Float;
Var Weight:Integer;
Begin
  result:=0;
  For Weight:=1 to FSize do result:=result+sqr(FOutput[Weight]);
  if result<0.1 then result:=0.1;
End;

Procedure TMediumLayer.Randomize;
Begin
  FWeights.Randomize;
End;

Procedure TMediumLayer.LoadWeights(Var f:Text);
var tmpInSize:integer;
Begin
  Readln(f,FSize,tmpInSize);
  FWeights.Load(f,FSize,tmpInSize);
End;

Procedure TMediumLayer.SaveWeights(Input:TInputLayer);
var f:Text;
begin
  OpenTextWrite(f,'NUMBERS.OUT');
  try
    Writeln(f,FSize,' ',Input.FSize);
    FWeights.Save(f,FSize,Input.FSize);
  finally
    Close(f);
  End;
End;

{ TOutputLayer }
Constructor TOutputLayer.Create;
Begin
  inherited Create;
  FWeights:=TNeuralWeights.Create;
  FSamples:=TNeuralSamples.Create;
  FStandard:=0.00001;
  FMaxStandard:=2;
End;

Function TOutputLayer.CheckOutError(var tmpError:Boolean; NumPats:Integer):Boolean;
Var i:integer;
begin
  result:=True;
  tmpError:=False;
  FFinalErr:=0.0;
  for i:=1 to NumPats do
  begin
    FFinalErr:=FFinalErr+FTotalError[i];
    if FTotalError[i]>=FSize*FStandard then result:=False;
    if FTotalError[i]>=FSize*FMaxStandard then
    begin
      tmpError:=True;
      result:=True;
    end;
  end;
End;

Procedure TOutputLayer.AppendWeights(Medium:TMediumLayer);
var f:Text;
begin
  AppendText(f,'NUMBERS.OUT');
  try
    Writeln(f,FSize,' ',Medium.FSize);
    FWeights.Save(f,FSize,Medium.FSize);
  finally
    close(f);
  end;
end;

Procedure TOutputLayer.Randomize;
Begin
  FWeights.Randomize;
end;

Procedure TOutputLayer.DoForward(Medium:TMediumLayer);
var Sum       : Float;
    Neurode,i : integer;
begin
  for Neurode:=1 to FSize do
  begin
    Sum:=0.0;
    for i:=1 to Medium.FSize do Sum:=Sum+(FWeights.FWeights[Neurode]^[i]*Medium.FOutput[i]);
    FOutput[Neurode]:=1.0/(1.0+exp(-FactorSigmoid*Sum));
  end;
end;

Destructor TOutputLayer.Destroy;
Begin
  FSamples.Free;
  FWeights.Free;
  inherited Destroy;
end;

Procedure TOutputLayer.DoError(NumSample:Integer);
var Neurode:integer;
begin
  FTotalError[NumSample]:=0;
  for Neurode:=1 to FSize do
  begin
    FError[Neurode]:=FSamples.FSamples[NumSample]^[Neurode]-FOutput[Neurode];
    FTotalError[NumSample]:=FTotalError[NumSample]+Abs(FError[Neurode]);
  end;
end;

Procedure TOutputLayer.LoadWeights(Var f:Text);
var tmpYSize,tmpMidSize:integer;
Begin
  Readln(f,tmpYSize,tmpMidSize);
  FWeights.Load(f,tmpYSize,tmpMidSize);
End;

Function TOutputLayer.GetOutput(NeurodeIndex:Longint):Float;
begin
  result:=FOutput[NeurodeIndex];
end;

Function TOutputLayer.GetOutputSum:Float;
var t:Integer;
begin
  result:=0;
  for t:=1 to FSize do result:=result+FOutput[t];
end;

Procedure TOutputLayer.AdjustWeights(Const Beta:Float; Medium:TMediumLayer);
var tmpBeta,tmpLength : Float;
    Weight,Neurode    : integer;
Begin
  tmpLength:=Beta/Medium.CalcLength;
  for Neurode:=1 to FSize do
  Begin
    tmpBeta:=FError[Neurode]*tmpLength;
    for Weight:=1 to Medium.FSize do
        FWeights.FWeights[Neurode]^[Weight]:=FWeights.FWeights[Neurode]^[Weight]+TmpBeta*Medium.FOutput[Weight];
  end;
End;

Procedure TOutputLayer.Load(Const FileName:String; NumSamples:Integer);
var f:Text;
    NumSample:Integer;
Begin
  OpenText(f,FileName);
  try
    readln(f,FSize);
    for NumSample:=1 to NumSamples do
        FSamples.Load(f,FSize,NumSample);
  finally
    close(f);
  end;
end;

{ TNeuralNet }
Procedure TNeuralNet.DoForwardPass(NumSample:Integer);
begin
  FMedium.DoForward(NumSample,FInput);
  FOutput.DoForward(FMedium);
end;

Procedure TNeuralNet.DoBackPass(NumSample:Integer);
begin
  FOutput.DoError(NumSample);
  FMedium.DoError(FOutput);
  FOutput.AdjustWeights(FBeta,FMedium);
  FMedium.AdjustWeights(NumSample,FBeta,FInput);
end;

Procedure TNeuralNet.RandomizeWeights;
Begin
  Randomize;
  FMedium.Randomize;
  FOutput.Randomize;
End;

Procedure TNeuralNet.ReadDataFile(Const FileName:String);
Var InFile : text;
    InPath : string;
    i      : integer;
Begin
  InPath := FileName;
  i:=Pos('.',InPath);
  if i=0 then InPath:=''
         else InPath:=Copy(InPath,1,i-1);
  if InPath = '' then raise Exception.Create('No input file specified.');

  OpenText(InFile,InPath+'.NET');
  try
    readln( InFile, FInput.FSize, FMedium.FSize );
    FInput.ReadData(infile);
  finally
    close(InFile);
  end;

  FOutput.Load(InPath+'.OUT',FInput.FNumSamples);
End;

Procedure TNeuralNet.Initialize;
begin
  FIterationCount := 1;
  RandomizeWeights;
end;

Procedure TNeuralNet.StartLearning;
Const MaxFinalErr=100000000;
var NumSample  : Integer;
    LearnError : Boolean;
    OldFinalErr: Float;
    tmpAction  : TNeuralNetAction;
begin
  LearnError    := False;
  FCurrentMode  := nnmLearn;
  Initialize;
  OldfinalErr   :=MaxFinalErr;
  FLearned:= False;
  while not FLearned do
  begin
    for NumSample:=1 to FInput.FNumSamples do
    begin
      DoForwardPass(NumSample);
      DoBackPass(NumSample);
    end;
    Inc(FIterationCount);
    FLearned := FOutput.CheckOutError(LearnError ,FInput.FNumSamples);
    if OldfinalErr=MaxFinalErr then OldfinalErr:=FOutput.FFinalErr;
    if FAdjustBeta then
      FBeta:=FBeta+FBeta*(100.0*(OldFinalErr-FOutput.FFinalErr)/OldFinalErr)/100.0;
    OldFinalErr:=FOutput.FFinalErr;
    if Assigned(FOnIteration) then
    begin
      tmpAction:=nnaContinue;
      FOnIteration(Self,tmpAction);
      Case tmpAction of
        nnaStop: FLearned:=True;
      end;
    end;
  end;
  for NumSample:=1 to FInput.FNumSamples do DoForwardPass(NumSample);
End;

Procedure TNeuralNet.LoadWeights;
Var f:Text;
begin
  OpenText(f,'NUMBERS.OUT');
  try
    FMedium.LoadWeights(f);
    FOutput.LoadWeights(f);
  finally
    close(f);
  End;
End;

Function TNeuralNet.CalcGuessedOutput(NumSample:Integer):Float;
begin
  FCurrentMode:=nnmProcess;
  DoForwardPass(NumSample);
  result:=FOutput.GetOutputSum;
End;

Procedure TNeuralNet.SaveWeights;
Begin
  if FCurrentMode=nnmLearn then
  begin
    FMedium.SaveWeights(FInput);
    FOutput.AppendWeights(FMedium);
  end;
end;

Constructor TNeuralNet.Create(AOwner:TComponent);
Begin
  inherited Create(AOwner);
  FAdjustBeta:=True;
  FBeta:=0.8;
  FOutput:=TOutputLayer.Create;
  FInput:=TInputLayer.Create;
  FMedium:=TMediumLayer.Create;
  Initialize;
End;

Destructor TNeuralNet.Destroy;
begin
  FOutput.Free;
  FInput.Free;
  FMedium.Free;
  inherited Destroy;
end;

end.