ftmocr.pas

Delphi神经网络

{***************************************************************}
{  NeuroCommon Unit                                             }
{  Copyright (c)2001 Alex Cherkasov                             }
{                                                               }
{   This work is based on publications of:                      }
{          -Christopher M. Bishop                               }
{          -Jose C. Principe                                    }
{          -Samuel J. Rogers                                    }
{          -Laurene V. Fausett                                  }
{          -Simon S. Haykin                                     }
{ DISCLAIMER                                                    }
{  It's free for non-comercial use. You cannot remove or change }
{  this header. You can change/modify the code, but if you do so}
{  you cannot distribute changed version of this code by any    }
{  means other than compiled in application.                    }
{  By using this code or parts theirof you are accepting the    }
{  full responsibility of the use. You understand that the      }
{  author cant be made responsible in any way for any problems  }
{  occuring using this code.                                    }
{                                                               }
{  E-Mail: [e-mail]					}
{  Web:    http://xpidea.com/                			}
{***************************************************************}
unit ftmOCR;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, NeuroCommon, NeuroBAM, NeuroPattern, NeuroBP, NeuroCustom, ComCtrls;

const
  aMatrixDim = 10;
  aFirstChar = Ord('0');
  aLastChar = Ord('z');
  aCharsCount = aLastChar - aFirstChar + 1;

type
  TOCRNetwork = class(TBackpropagationNetwork)
  private
    function OutputPatternIndex(aPattern: TNeuroPattern): Integer;
  public
    procedure AddNoiseToInputPattern(aLevelPercent: Byte);
    function BestNodeIndex: Integer;
    procedure Train(aPatterns: TList); override;
  end;




  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    Panel1: TPanel;
    Button2: TButton;
    Panel2: TPanel;
    Button5: TButton;
    TabSheet3: TTabSheet;
    Panel3: TPanel;
    Button6: TButton;
    Button7: TButton;
    Button8: TButton;
    ProgressBar1: TProgressBar;
    TabSheet4: TTabSheet;
    Panel4: TPanel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label6: TLabel;
    TrackBar1: TTrackBar;
    Label7: TLabel;
    Label8: TLabel;
    Label5: TLabel;
    Label9: TLabel;
    Panel5: TPanel;
    Image1: TImage;
    TrackBar2: TTrackBar;
    Label10: TLabel;
    Label11: TLabel;
    TrackBar3: TTrackBar;
    TrackBar4: TTrackBar;
    Label12: TLabel;
    Label13: TLabel;
    Label14: TLabel;
    Label1: TLabel;
    Label15: TLabel;
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button8Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure TrackBar1KeyPress(Sender: TObject; var Key: Char);
    procedure TrackBar1Change(Sender: TObject);
    procedure TrackBar2Change(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormCreate(Sender: TObject);
  protected
    procedure UpdateActions; override;
  private
    { Private declarations }
    fTrainingPatterns: TNeuroPatterns;
    fBackpropNetwork: TOCRNetwork;
    function CreateTrainingPatterns(aFont: TFont): TNeuroPatterns;

    function CharToBitArray(aChar: Char; aFont: TFont; aArrayDim: Byte; aAddNoisePercent: byte = 0): TNeuroValueArray;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation
uses Math;
{$R *.dfm}

procedure AddNoise(aBitMap: TBitMAp; aNoiseLevel: Byte);
var i, j, x, y: Integer;
begin
  j := (aBitMap.Height * aBitMap.Width * aNoiseLevel) div 100;
  for i := 1 to j do
  begin
    x := Round(Random(0, aBitMap.Width));
    y := Round(Random(0, aBitMap.Height));
    if Round(Random(0, 1)) = 1 then
      aBitMap.Canvas.Pixels[x, y] := clWhite
    else
      aBitMap.Canvas.Pixels[x, y] := clBlack;
  end;
end;

function TForm1.CharToBitArray(aChar: Char; aFont: TFont; aArrayDim: Byte; aAddNoisePercent: byte = 0): TNeuroValueArray;
var aSrc, aDest: TBitMap;
    aSize: TSize;
    i, j: Integer;
    aColor: TColor;
begin
  aSrc := TBitMap.Create;
  aSrc.Monochrome := True;
  with aSrc.Canvas do
  begin
    Font.Assign(aFont);
    aSize := TextExtent(aChar);
    aSrc.Height := aSize.cy;
    aSrc.Width := aSize.cx;
    TextOut(0, 0, aChar);
  end;
  if aAddNoisePercent > 0 then
    AddNoise(aSrc, aAddNoisePercent);
  Image1.Picture.Bitmap := aSrc;
  Image1.Repaint;
  Application.ProcessMessages;
  aDest := TBitMap.Create;
  aDest.Monochrome := True;
  aDest.Height := aArrayDim;
  aDest.Width := aArrayDim;
  aDest.Canvas.CopyRect(Rect(0, 0, aDest.Width, aDest.Height), aSrc.Canvas, Rect(0, 0, aSrc.Width, aSrc.Height));
  SetLength(result, aArrayDim * aArrayDim);
  for i := 0 to aDest.Height - 1 do
    for j := 0 to aDest.Width - 1 do
    begin
      aColor := aDest.Canvas.Pixels[j, i];
      if aColor = clWhite then
        result[aArrayDim * i + j] := 0
      else
        result[aArrayDim * i + j] := 1;
    end;
  aDest.Free;
  aSrc.Free;
end;

function TForm1.CreateTrainingPatterns(aFont: TFont): TNeuroPatterns;
var i, j: Integer; aBitMatrix: TNeuroValueArray;
begin
  result := TNeuroPatterns.Create(aCharsCount, aMatrixDim * aMatrixDim, aCharsCount);
  for i := 0 to aCharsCount - 1 do
  begin
    aBitMatrix := CharToBitArray(Chr(aFirstChar + i), aFont, aMatrixDim, 0);
    for j := 0 to aMatrixDim * aMatrixDim - 1 do
      result[i].Input[j] := aBitMatrix[j];
    result[i].Output[i] := 1;
    SetLength(aBitMatrix, 0);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if fTrainingPatterns <> nil then
    fTrainingPatterns.Free;
  fTrainingPatterns := CreateTrainingPatterns(Label2.Font);
  PageControl1.ActivePage := TabSheet2;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  if fTrainingPatterns <> nil then
  begin
    if SaveDialog1.Execute then
      fTrainingPatterns.SaveToFile(SaveDialog1.FileName);
  end
  else
    MessageDlg('Please generate patterns first!', mtError, [mbOK], 0);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    if fTrainingPatterns <> nil then
      fTrainingPatterns.Free;
    fTrainingPatterns := TNeuroPatterns.CreateFromFile(OpenDialog1.FileName);
  end;
end;

procedure TForm1.Button5Click(Sender: TObject);
begin
  if fBackpropNetwork <> nil then
    fBackpropNetwork.Free;
  fBackpropNetwork := TOCRNetwork.Create(TrackBar3.Position / 100, TrackBar4.Position / 100, 3, [aMatrixDim * aMatrixDim, (aMatrixDim * aMatrixDim + aCharsCount) div 2, aCharsCount]);
  PageControl1.ActivePage := TabSheet3;
end;

procedure TForm1.Button6Click(Sender: TObject);
begin
  if fBackpropNetwork = nil then
  begin
    MessageDlg('Please create the network first!', mtInformation, [mbOK], 0);
    Exit;
  end;
  if fTrainingPatterns = nil then
  begin
    MessageDlg('Please create training patterns on STEP 1', mtInformation, [mbOK], 0);
    Exit;
  end;
  ProgressBar1.Max := aCharsCount;
  Label11.Caption := 'While the network is training you can proceed to the STEP 4 and observe a recognition quality is improving with progress of training.';
  fBackpropNetwork.Train(fTrainingPatterns);
  MessageDlg('Network training successfully complete!', mtInformation, [mbOK], 0);
end;

procedure TForm1.Button8Click(Sender: TObject);
begin
  if fBackpropNetwork <> nil then
  begin
    SaveDialog1.DefaultExt := 'net';
    SaveDialog1.Filter := 'Neural Network (*.NET)|*.net';
    if SaveDialog1.Execute then
      fBackpropNetwork.SaveToFile(SaveDialog1.FileName);
  end
  else
    MessageDlg('Please create the network first!', mtInformation, [mbOK], 0);
end;

procedure TForm1.Button7Click(Sender: TObject);
begin
  OpenDialog1.DefaultExt := 'net';
  OpenDialog1.Filter := 'Neural Network (*.NET)|*.net';
  if OpenDialog1.Execute then
  begin
    if fBackpropNetwork <> nil then
      fBackpropNetwork.Free;
    fBackpropNetwork := TOCRNetwork.CreateFromFile(OpenDialog1.FileName);
  end;

end;

{ TOCRNetwork }


function TOCRNetwork.OutputPatternIndex(aPattern: TNeuroPattern): Integer;
var i: Integer;
begin
  result := -1;
  for i := 0 to aPattern.OutputCount - 1 do
    if aPattern.Output[i] = 1 then
    begin
      result := i;
      exit;
    end;
end;

procedure TOCRNetwork.Train(aPatterns: TList);
var Good, i, j, k, iteration: integer;
  fPatterns: TNeuroPatterns;
  fErr: TNeuroValue;

begin
  //This method implementation is for reference only -
  //You may want to implement your own method by overriding this one.
  fErr := InfiniteLArgeValue;
  fPatterns := TNeuroPatterns(aPatterns);
  if fPatterns <> nil then
  begin
    good := 0;
    iteration := 0;
    while (good < fPatterns.Count) do // Train until all patterns are correct
    begin
      Form1.ProgressBar1.Position := good;
      Form1.Label15.Caption := 'Training progress: ' + IntToStr((Form1.ProgressBar1.Position * 100) div Form1.ProgressBar1.max) + '%';
      good := 0;
      for i := 0 to aPatterns.Count - 1 do
      begin
        fErr := 0;
        for k := 0 to NodesInLayer[0] - 1 do
          fNode[k].NodeValue := TNeuroPattern(aPatterns[i]).Input[k];
        AddNoiseToInputPattern(Form1.TrackBar2.Position);
        for j := aFirstMiddleNode to NodesCount - 1 do
          fNode[j].Run;
        for k := aFirstOutputNode to NodesCount - 1 do
        begin
          fErr := fErr + Abs(fNode[k].NodeError);
          fNode[k].NodeError := TNeuroPattern(fPatterns[i]).Output[k - aFirstOutputNode];
        end;
        for j := NodesCount - 1 downto aFirstMiddleNode do
          fNode[j].Learn;
        if BestNodeIndex = OutputPatternIndex(TNeuroPattern(fPatterns[i])) then
          inc(Good);
        Inc(iteration);
        if
          Application.Terminated then Exit
        else
          Application.ProcessMessages;
      end;
{For EpochBackProp  uncomment this lines:    for i:=0 to LinksCount-1 do
         TEpochBackpropagationLink(fLink[i]).Epoch(aPAtterns.Count);}
      if (iteration mod 10) = 0 then
        Form1.Label9.Caption := 'AVG Error: ' + FloatToStr(fErr / OutputNodesCount) + '  Iteration: ' + IntToStr(Iteration);
    end;
    Form1.Label9.Caption := 'AVG Error: ' + FloatToStr(fErr / OutputNodesCount) + '  Iteration: ' + IntToStr(Iteration);
  end;
end;


function TOCRNetwork.BestNodeIndex: Integer;
var i: Integer; aMAxNodeValue, aMinError, nv, ne: TNeuroValue;
begin
  result := -1;
  aMaxNodeValue := 0;
  aMinError := InfiniteLargeValue;
  for i := 0 to OutPutNodesCount - 1 do
    with OutputNode[i] do
    begin
      nv := NodeValue;
      ne := NodeError; //MAximum value or trade it for less error
      if (nv > aMaxNodeValue) or ((nv >= aMaxNodeValue) and (ne < aMinError)) then
      begin
        aMaxNodeValue := nv;
        aMinError := ne;
        result := i;
      end;
    end;
end;

procedure TForm1.TrackBar1KeyPress(Sender: TObject; var Key: Char);
var aInput: TNeuroValueArray; i: Integer; 
begin
  if fBackpropNetwork = nil then
  begin
    MessageDlg('Please go to STEP 2 and create the network.', mtInformation, [mbOK], 0);
    Exit;
  end;
  Label5.Caption := Key;
  aInput := CharToBitArray(Key, Label2.font, aMatrixDim, TrackBar1.Position);
  for i := 0 to fBackpropNetwork.InputNodesCount - 1 do
    fBackpropNetwork.InputNode[i].NodeValue := aInput[i];
  fBackpropNetwork.Run;
  Label2.Caption := Chr(aFirstChar + fBackpropNetwork.BestNodeIndex);
  SetLEngth(aInput, 0);
end;

procedure TForm1.TrackBar1Change(Sender: TObject);
begin
  Label7.Caption := 'Noise Level ( ' + IntToStr(TrackBar1.Position) + '%)';
end;

procedure TOCRNetwork.AddNoiseToInputPattern(aLevelPercent: Byte);
var i: Integer;
begin
  i := ((NodesInLayer[0] - 1) * aLevelPercent) div 100;
  while i > 0 do
  begin
    fNode[round(Random(0, NodesInLayer[0] - 1))].NodeValue := Round(Random(0, 1));
    Dec(i);
  end;
end;

procedure TForm1.TrackBar2Change(Sender: TObject);
begin
  Label10.Caption := 'Noise Level in patterns ( ' + IntToStr(TrackBar2.Position) + '%)';
end;

procedure TForm1.UpdateActions;
begin
  inherited;
  Label13.Caption := FloatToStr(TrackBar3.Position / 100);
  Label14.Caption := FloatToStr(TrackBar4.Position / 100);
  Label10.Caption := 'Add noise to patterns (' + IntToStr(TrackBar2.Position) + ' %)';
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  Application.Terminate;
end;

procedure TForm1.FormCreate(Sender: TObject);
var i: Integer;
begin
  Label1.Caption := '';
  for i := 0 to aCharsCount - 1 do
    Label1.Caption := Label1.Caption + Chr(aFirstChar + i) + ' ';
end;

end.