unit1.pas

感知机分类算法用于文献分类,基于BP神经网络的基本算法

//*           该过程用于初始化权值及阈值           *
//*                                                *
//**************************************************
procedure TForm1.InitialWeight;
var
    i: integer;
    j: integer;
    Fname: TextFile;
begin
    if Mode = 0 then
    begin
       Randomize;
       For i := 0 To N - 1 Do
           For j := 0 To Q - 1 Do
               V[i][j] := (Random - 0.5)*0.1;

       For i := 0 To Q - 1 Do
           G[i] := (Random - 0.5)*0.1;
    end;

    if Mode = 1 then
    begin
       AssignFile(Fname, Path2);
       Reset(Fname);
       For i := 0 To N - 1 Do
           For j := 0 To Q - 1 Do
               Readln(Fname, V[i][j]);

       For i := 0 To Q - 1 Do
           Readln(Fname, G[i]);
       CloseFile(Fname);
    end;
end;

//**************************************************
//*                                                *
//*         该过程用于计算输出层各单元输出         *
//*                                                *
//**************************************************
procedure TForm1.CalRealout(i: integer);
var
   j: integer;
   k: integer;
   temp: Real;
begin
   For j := 0 To Q - 1 Do
   begin
       temp := 0;
       For k := 0 To N - 1 Do
           temp := temp + V[k][j]*X[i][k];
       temp := temp - G[j];
       if temp >  0 then temp :=  1;
       if temp <= 0 then temp := -1;
       Y[i][j] := temp;
   end;
end;

//**************************************************
//*                                                *
//*        该过程用于修正隐层至输出层连接权        *
//*                                                *
//**************************************************
procedure TForm1.ModifyV(i: integer);
var
   j,k: integer;
begin
   For j := 0 To N - 1 Do
       For k := 0 To Q - 1 Do
           V[j][k] := V[j][k] + WRadio*X[i][j]*(C[i][k]-Y[i][k]);
end;

//**************************************************
//*                                                *
//*             该过程用于修正输出层阈值           *
//*                                                *
//**************************************************
procedure TForm1.ModifyG(i: integer);
var
   j: integer;
begin
   For j := 0 To Q - 1 Do
       G[j] := G[j] + GRadio*(-1)*(C[i][j]-Y[i][j]);
end;

//**************************************************
//*                                                *
//*               该过程用于计算误差               *
//*                                                *
//**************************************************
function TForm1.GetError( ): real;
var
   i,j: integer;
   temp: real;
begin
   temp := 0;
   For i := 0 To Sample - 1 Do
       For j := 0 To Q - 1 do
           temp := temp + Power(C[i][j]-Y[i][j],2);
   temp := temp/(Sample*Q);
   temp := Power(temp,0.5);
   GetError := temp;
end;

//**************************************************
//*                                                *
//*               该过程用于保存权值               *
//*                                                *
//**************************************************
procedure TForm1.SaveWeight;
var
  i: integer;
  j: integer;
  Fname: TextFile;
begin
  Path2 := StringReplace(Path1, 'txt', 'wgt', [rfReplaceAll]);
  AssignFile(Fname, Path2);
  Rewrite(Fname);
  For i := 0 To N - 1 Do
      For j := 0 To Q - 1 Do
          Writeln(Fname, V[i][j]);

  For i := 0 To Q - 1 Do
      Writeln(Fname, G[i]);

  CloseFile(Fname);
end;

//**************************************************
//*                                                *
//*              该过程用于输出结果                *
//*                                                *
//**************************************************
procedure TForm1.OutputResult;
var
    i: integer;
    j: integer;
    Fname: TextFile;
begin
    Path3 := StringReplace(Path1, 'txt', 'out', [rfReplaceAll]);
    AssignFile(Fname, Path3);
    Rewrite(Fname);

    If Mode = 0 Then
    begin
       Writeln(Fname, '');
       Writeln(Fname, chr(9) + chr(9) + chr(9)
                    + '基本感知机识别算法学习结果显示');
       Writeln(Fname, chr(9) + chr(9) + chr(9)
                    + '==============================');
       Writeln(Fname, '');
       Writeln(Fname, chr(9) + chr(9) + '-----------------------------------------');
       Writeln(Fname, chr(9)
                             + chr(9) + '实际输出:' + chr(9) + '希望输出:' + chr(9) + '绝对偏差:');
       Writeln(Fname, chr(9) + chr(9) + '-----------------------------------------');
       For i := 0 To Sample - 1 Do
       begin
           For j := 0 To Q - 1 Do
               Writeln(Fname, chr(9) + chr(9) + Format('%4.0f',[Y[i][j]])
                             + chr(9) + chr(9) + Format('%4.0f',[C[i][j]])
                             + chr(9) + chr(9) + Format('%4.0f',[Abs(C[i][j] - Y[i][j])]));
           if i <> Sample - 1 then Writeln(Fname, '');
       end;
       Writeln(Fname, chr(9) + chr(9) + '-----------------------------------------');
       Writeln(Fname, chr(9) + chr(9) + '学习次数:' + IntToStr(Count));
       Writeln(Fname, chr(9) + chr(9) + '平均偏差:' + FloatToStr(Error));
       Writeln(Fname, chr(9) + chr(9) + '-----------------------------------------');
       Writeln(Fname, chr(9) + chr(9) + chr(9) + '日期：' + DateToStr(Date) + chr(32) + chr(32) + '时间：' + TimeToStr(Time));
    end
    Else
    begin
       Writeln(Fname, '');
       Writeln(Fname, chr(9) + chr(9) + chr(9)
                    + '基本感知机识别算法识别结果显示');
       Writeln(Fname, chr(9) + chr(9) + chr(9)
                    + '==============================');
       Writeln(Fname, '');
       Writeln(Fname, chr(9) + chr(9) + '-----------------------------------------');
       Writeln(Fname, chr(9)
                             + chr(9) + '实际输出:' + chr(9) + '希望输出:' + chr(9) + '绝对偏差:');
       Writeln(Fname, chr(9) + chr(9) + '-----------------------------------------');
       For i := 0 To Sample - 1 Do
       begin
           For j := 0 To Q - 1 Do
               Writeln(Fname, chr(9) + chr(9) + Format('%4.0f',[C[i][j]])
                             + chr(9) + chr(9) + Format('%4.0f',[Y[i][j]])
                             + chr(9) + chr(9) + Format('%4.0f',[Abs(C[i][j] - Y[i][j])]));
           if i <> Sample - 1 then Writeln(Fname, '');
       end;
       Writeln(Fname, chr(9) + chr(9) + '-----------------------------------------');
       Writeln(Fname, chr(9) + chr(9) + '平均偏差:' + FloatToStr(Error));
       Writeln(Fname, chr(9) + chr(9) + '-----------------------------------------');
       Writeln(Fname, chr(9) + chr(9) + chr(9) + '日期：' + DateToStr(Date) + chr(32) + chr(32) + '时间：' + TimeToStr(Time));
    end;
    CloseFile(Fname);
    Memo1.Lines.LoadFromFile(Path3);
end;

//**************************************************
//*                                                *
//*          该过程的功能为绘画坐标系              *
//*                                                *
//**************************************************
procedure TForm1.DrawZbx;
var
  i:integer;
begin
  Form1.Image1.Canvas.pen.color:=clRed;
  Form1.Image1.canvas.pen.width:=1;
  Form1.Image1.canvas.font.name:='宋体';
  Form1.Image1.canvas.font.size:=9;
  with Form1.Image1.Canvas do
  begin
  //画坐标轴及箭头
    MoveTo(40,317);
    LineTo(40,63);
    MoveTo(40,317);
    LineTo(410,317);
    MoveTo(410,317);
    LineTo(405,315);
    MoveTo(410,317);
    LineTo(405,319);
    MoveTo(40,63);
    LineTo(38,68);
    MoveTo(40,63);
    LineTo(42,68);
  //画横轴刻度
    for i:=1 to 10 do
    begin
        MoveTo(40+i*35,317);
        LineTo(40+i*35,312);
    end;
  //画纵轴刻度
    for i:=1 to 5 do
    begin
        MoveTo(40,317-i*40);
        LineTo(45,317-i*40);
    end;
  //写横轴刻度
    for i:=0 to 10 do
    begin
        font.color := clBlue;
        TextOut(28+i*35,319,InttoStr(round(i*Maxgen/10)));
    end;
   //写纵轴刻度
    for i:=1 to 5 do
    begin
        font.color := clBlue;
        TextOut(18,317-i*40-5,Format('%0.1f',[0.2*i]));
    end;
  //写横轴名称
    font.color := clRed;
    TextOut(350,342,'X:训练次数');
  //写纵轴名称
    font.color := clRed;
    TextOut(12,40,'Y:误差精度');
  //写坐标系名称
    font.color := clRed;
    font.size := 16;
    font.name:='幼圆';
    TextOut(140,15,'算法动态收敛过程');
    font.name:='宋体';
    font.size := 10;
  //写网络运行信息
    font.color := clFuchsia;
    TextOut(80,80,'感知机识别网络正在对给定样本进行训练，请稍候...');
  end;
end;

//**************************************************
//*                                                *
//*          该过程的功能为取得连线前端点          *
//*                                                *
//**************************************************
procedure TForm1.GetFirstPoint;
begin
    Firstx:=round(Count*(10*35)/Maxgen)+40;
    Firsty:=round(317-Error*((1*200)/1));
end;

//**************************************************
//*                                                *
//*          该过程的功能为取得连线后端点          *
//*                                                *
//**************************************************
procedure TForm1.GetSecondPoint;
begin
    Secondx:=round(Count*(10*35)/Maxgen)+40;
    Secondy:=round(317-Error*((1*200)/1));
end;

//**************************************************
//*                                                *
//*           该过程的功能为连接前后端点           *
//*                                                *
//**************************************************
procedure TForm1.DrawLine;
begin
    Form1.Image1.Canvas.pen.color:=clBlue;
    Form1.Image1.canvas.pen.width:=1;
    with Form1.Image1.canvas do
    begin
         MoveTo(Firstx,Firsty);
         LineTo(Secondx,Secondy);
         //写当前训练信息
         font.color := clRed;
         TextOut(120,100,'当前次数：'+inttostr(Count)+chr(9)+'当前误差：'+Format('%0.5f',[Error]));
    end;
    Form1.Image1.Refresh;
end;

//**************************************************
//*                                                *
//*           该过程的功能为删除提示信息           *
//*                                                *
//**************************************************
procedure TForm1.Deletehint;
begin
    Form1.Image1.Canvas.pen.color:=clBlue;
    Form1.Image1.canvas.pen.width:=1;
    with Form1.Image1.canvas do
    begin
       //删除提示信息（用背景色重写就看不出来了）
       font.color := clInfoBk;
       TextOut(80,80,'感知机识别网络正在对给定样本进行训练，请稍候...');
       font.color := clFuchsia;
       TextOut(150,80,'感知机识别网络训练结束!!');
    end;
    Form1.Image1.Refresh;
end;

//**************************************************
//*                                                *
//*           该过程的功能为显示收敛曲线           *
//*                                                *
//**************************************************
procedure TForm1.Memo1Click(Sender: TObject);
begin
    If AlreadyDrawZbx = True Then
    begin
       Memo1.Hide;
       Image1.Show;
    end;
end;

//**************************************************
//*                                                *
//*           该过程的功能为隐藏收敛曲线           *
//*                                                *
//**************************************************
procedure TForm1.Image1Click(Sender: TObject);
begin
    Image1.Hide;
    Memo1.Show;
end;

//**************************************************
//*                                                *
//*          该过程的功能为清除坐标系内容          *
//*                                                *
//**************************************************
procedure TForm1.Image1Clear;
var
   ARect:TRect;
begin
   with Image1.Canvas do begin
        CopyMode:=cmWhiteness;
        ARect:=Rect(0,0,Image1.Width,Image1.Height);
        CopyRect(ARect,Image1.Canvas,ARect);
        CopyMode:=cmSrcCopy;
        Brush.Color:=clInfoBk;
        Brush.Style:=bsSolid;
        pen.color:=clRed;
        pen.width:=1;
        Rectangle(0,0,Image1.Width,Image1.Height);
   end;
end;

end.