俺写的BP算法源程序(Pascal)

stlxv · 发表于 2005-10-1 09:16:22

<

>delphi 2005下编译通过。支持变学习率。具有通用性，传递函数可自己写（动态调用）。
<

>下面是程序和使用的例子。学习《人工智能与专家系统》时写的。

<

>//////////////////主程序////////////////////////
program BP; { 输入文件：BP.in 第一行：DLL文件名 第二行：layer_count, n(1), n(2), ... , n(layer_count) ;n(i) <--第i层神经元个数 第三行：允许误差ε 学习率η 学习实例个数N 附加测试输入个数M 迭代次数（若0则不计迭代次数）最低学习率min_yita // 若迭代次数为零，则最低学习率可以不用写 // 若迭代次数不为零，则学习率为最高学习率，且必须输入最低学习率 接下来是学习实例，每个学习实例2行： 第一行：输入的n(1)个数 第二行：期望的输出 再接下来是M个测试输入 测试输入 N<=40,M<=100 n(i)<=10 3<=layer_count<=10 0<η<1，推荐0.3<=η<=0.9 输入：[0,1]
 注意：误差E[j,k]=1/2*(y*[j,k]-y[j,k])^2<=ε
 输出文件：BP.out 第一行：总迭代次数 接下来N行：对应每个学习实例的输出和测试输入的输出 接下来为所有权值 }
uses SysUtils, Windows, ClassFunctionsUnit in 'ClassFunctionsUnit.pas';
{ Global Variables }
var yita,epsilon,min_yita,delta_yita:Extended; layer_count,t,k,instance_count,total_time,ExtraCount:integer; // t - 迭代次数，k - 学习实例序号，total_time - 总迭代次数 func:TFunctions; n:array[1..10] of integer; // 每层的神经元个数 instances:array[1..140] of record // 学习实例 X,Y:array[1..10] of Extended; end;
 W:array[1..9] of array[1..10,1..10] of Extended; IO_map:array[1..10,1..10] of record I,Extended; end; E:array[1..10] of Extended; // E - 神经网络输出误差 delta:array[1..10,1..10] of Extended;
{ Global Procedures }
 procedure LoadFromFile; var F:TextFile; FileName:String; i,j:integer; begin AssignFile(F,'BP.in'); Reset(F); Readln(F,FileName);
 func:=TFunctions.Create(FileName);
 Read(F,layer_count);
 for i:=1 to layer_count do read(f,n); Readln(F);
 Read(F,epsilon); read(F,yita); Read(F,instance_count); Read(F,ExtraCount); Read(F,total_time); if total_time>0 then Read(F,min_yita); Readln(F);
 for i:=1 to instance_count do begin for j:=1 to n[1] do read(f,instances.X[j]); Readln(F); for j:=1 to n[layer_count] do read(F,Instances.Y[j]); Readln(F); end; if ExtraCount>0 then for i:=instance_count+1 to ExtraCount+instance_count do begin for j:=1 to n[1] do read(f,instances.X[j]); Readln(F); end;
 CloseFile(F); end;
 procedure MapIO;forward;
 procedure WriteResultToFile; var F:TextFile; i,j,r:integer; begin AssignFile(F,'BP.out'); Rewrite(F); Writeln(F,t-1); //for k:=1 to instance_count do k:=1; while k<=instance_count+ExtraCount do begin MapIO; if n[1]>1 then for i:=1 to n[1]-1 do write(F,Format('%f,',[Instances[k].X])); write(F,Format('%f',[Instances[k].X[n[1]]])); write(F,' --> '); if n[layer_count]>1 then for i:=1 to n[layer_count]-1 do write(F,Format('%f,',[IO_map[layer_count,i].O])); writeln(F,Format('%f',[IO_map[layer_count,n[layer_count]].O])); k:=k+1; end; for i:=1 to layer_count-1 do for j:=1 to n do for r:=1 to n[i+1] do Writeln(F,Format('w(%d,%d->%d,%d): %f',[i,j,i+1,r,W[j,r]])); CloseFile(F); end;
 procedure Init; var i,j,r:integer; begin // init W for i:=1 to layer_count-1 do for j:=1 to n do for r:=1 to n[i+1] do W[j,r]:=Random(100)/1000; //init t,k t:=1; k:=1; // init delta_yita if total_time>0 then delta_yita:=(yita-min_yita)/total_time else delta_yita:=0; end;
 function computeIn(layer,q:integer):Extended; { TEST OK } // 计算layer层第q个神经元的输入 var j:integer; a,b:Extended; begin if layer=1 then begin Result:=Instances[k].X[q]; Exit; end;
 Result:=0; for j:=1 to n[layer-1] do begin a:=IO_map[layer-1,j].O; b:=W[layer-1][j,q]; Result:=Result+a*b; end; end;
 { MapIO 搞定所有神经元的输入输出值 } procedure MapIO; var i,j:integer; begin for i:=1 to layer_count do for j:=1 to n do begin IO_map[i,j].I:=computeIn(i,j); if i=1 then IO_map[i,j].=func.layer1(IO_map[i,j].I) else begin if i=layer_count then IO_map[i,j].=func.last_layer(IO_map[i,j].I) else IO_map[i,j].=func.middle_layer(IO_map[i,j].I); end; end; end;
 { computeE 计算神经网络的输出误差，在 调用该过程前要先MapIO } procedure computeE; var i:integer; begin for i:=1 to n[layer_count] do E:=sqr(Instances[k].Y-IO_map[layer_count,i].O)/2; end;
 procedure computeDelta; { maybe test OK } var i,j,r:integer; x:Extended; begin for i:=1 to n[layer_count] do delta[layer_count,i]:=(IO_map[layer_count,i].O-Instances[k].Y)* func.d_last_layer(IO_map[layer_count,i].I); for i:=layer_count-1 downto 1 do for j:=1 to n do begin x:=0; for r:=1 to n[i+1] do x:=x+delta[i+1,r]*W[j,r]; if i>1 then // middle layer x:=x*func.d_middle_layer(IO_map[i,j].I) else // first layer x:=x*func.d_layer1(IO_map[i,j].I); delta[i,j]:=x; end; end;
 procedure makeWChange; { maybe Test OK } var deltaW:Extended; i,j,r:integer; begin for i:=1 to layer_count-1 do for j:=1 to n do for r:=1 to n[i+1] do begin deltaW:=-yita*delta[i+1,r]*IO_map[i,j].O; W[j,r]:=W[j,r]+deltaW; end; end;
 function isInRange:Boolean; var i:integer; begin Result:=True; for i:=1 to n[layer_count] do if E>epsilon then begin Result:=False; break; end; end;
 function isAllInRange:Boolean; var old_k:integer; begin old_k:=k; k:=1; Result:=True; while (k<=instance_count)and(k<>old_k) do // 增加几行代码，减少了不少不必要的浮点运算 begin MapIO; computeE; if not isInRange then begin Result:=False; Break; end; k:=k+1; end; k:=old_k; MapIO; computeE; if not isInRange then Result:=False; end;
 procedure MainCompute; begin while true do begin if (total_time>0) and (t>total_time) then break; if isAllInRange then Break; // MapIO; <-- included in isAllInRange // computeE; computeDelta; makeWChange; t:=t+1; k:=((k+1) mod instance_count)+1; yita:=yita-delta_yita; end; end;
begin Randomize; LoadFromFile;
Init; MainCompute;
WriteResultToFile;
func.Free; end.

////////////////////file: ClassFunctionsUnit.pas/////////////////////////
unit ClassFunctionsUnit;
interface
type TFunction=function (input:Extended):Extended;stdcall;
 TFunctions=class // 这个类定义了所有的传递函数以及他们的导数 private DLLHandle:Cardinal; public layer1:TFunction; //输入层传递函数 d_layer1:TFunction; //输入层传递函数的导数 middle_layer:TFunction; //隐层传递函数 d_middle_layer:TFunction; //隐层传递函数的导数 last_layer:TFunction; //输出层传递函数 d_last_layer:TFunction; //输出层传递函数的导数 //所有的这些都是在Create的时候从动态连接库导入 //若DLL读入失败，则使用默认 constructor Create(DLLFileName:string); destructor Destroy;override; end;
implementation
uses Windows;
{ Default Functions }
function TDefaultFunctions_d_last_layer(input: Extended): Extended;stdcall; begin Result:=1; end;
function TDefaultFunctions_d_layer1(input: Extended): Extended;stdcall; begin Result:=1; end;
function TDefaultFunctions_d_middle_layer(input: Extended): Extended;stdcall; var ex,ex2:Extended; begin ex:=exp(-input); ex2:=1+ex; Result:=ex/(ex2*ex2); end;
function TDefaultFunctions_last_layer(input: Extended): Extended;stdcall; begin Result:=input; end;
function TDefaultFunctions_layer1(input: Extended): Extended;stdcall; begin Result:=input; end;
function TDefaultFunctions_middle_layer(input: Extended): Extended;stdcall; begin Result:=1/(1+exp(-input)); end;
{ TFuncions }
constructor TFunctions.Create(DLLFileName: string); procedure LoadDefault; begin layer1:=TDefaultFunctions_layer1; d_layer1:=TDefaultFunctions_d_layer1; middle_layer:=TDefaultFunctions_middle_layer; d_middle_layer:=TDefaultFunctions_d_middle_layer; last_layer:=TDefaultFunctions_last_layer; d_last_layer:=TDefaultFunctions_d_last_layer;
 DLLHandle:=0; end; begin DLLHandle:=LoadLibrary(PAnsiChar(DLLFileName));
if DLLHandle=0 then begin LoadDefault; Exit; end;
// load from dll @layer1:=GetProcAddress(DLLHandle,'layer1'); @d_layer1:=GetProcAddress(DLLHandle,'d_layer1'); @middle_layer:=GetProcAddress(DLLHandle,'middle_layer'); @d_middle_layer:=GetProcAddress(DLLHandle,'d_middle_layer'); @last_layer:=GetProcAddress(DLLHandle,'last_layer'); @d_last_layer:=GetProcAddress(DLLHandle,'d_last_layer'); end;
destructor TFunctions.Destroy; begin if DLLHandle=0 then FreeLibrary(DLLHandle); inherited; end;
 end.

//////////////使用例子1 - BP.in//////////////////
 3 1 3 1 0.000000000001 0.3 3 11 100000 1 -5.874 2 -5.994 0.5 -5.469 3 4 -5 6 -7 8 -0.9 0.25 0.75 -1 -1.24 
////////////////////使用例子2 - BP.in/////////////////////
BPTest3.dll 4 2 3 3 2 0.00000001 0.3 20 0 1000000 0.3 0.05 0.02 1 0 0.09 0.11 1 0 0.12 0.20 1 0 0.15 0.22 1 0 0.20 0.25 1 0 0.75 0.75 0 1 0.80 0.83 0 1 0.82 0.80 0 1 0.90 0.89 0 1 0.95 0.89 0 1 0.09 0.04 1 0 0.10 0.10 1 0 0.14 0.21 1 0 0.18 0.24 1 0 0.22 0.28 1 0 0.77 0.78 0 1 0.79 0.81 0 1 0.84 0.82 0 1 0.94 0.93 0 1 0.98 0.99 0 1

///////////////BPTest3.dll 源程序////////////////////
library BPTest3;
function layer1(input: Extended): Extended;stdcall; begin Result:=input; end;
function middle_layer(input: Extended): Extended;stdcall; begin Result:=1/(1+exp(-input)); end;
function last_layer(input: Extended): Extended;stdcall; begin Result:=1/(1+exp(-input)); end;
function d_layer1(input: Extended): Extended;stdcall; begin Result:=1; end;
function d_middle_layer(input: Extended): Extended;stdcall; var ex,ex2:Extended; begin ex:=exp(-input); ex2:=1+ex; Result:=ex/(ex2*ex2); end;
function d_last_layer(input: Extended): Extended;stdcall; var ex,ex2:Extended; begin ex:=exp(-input); ex2:=1+ex; Result:=ex/(ex2*ex2); end;
exports layer1, middle_layer, last_layer, d_layer1, d_middle_layer, d_last_layer;
begin end.

多多指教

stlxv · 发表于 2005-10-17 21:09:27

<

>最近才发现这个程序有点问题，改正和改进了，如下：

<

>{ BP 算法源程序 ** 1. 用BP算法对神经网络进行训练 ** 2. 对额外的神经网络输入计算输出值 2005, by stlxv <a href="mailtstlxv@21cn.com" target="_blank" >stlxv@21cn.com</A>
<

> 输入文件：BP.in 第一行：DLL文件名 第二行：layer_count, n(1), n(2), ... , n(layer_count) ;n(i) <--第i层神经元个数 第三行：允许误差ε 学习率η 学习实例个数N 附加测试输入个数M 迭代次数（若0则不计迭代次数）最低学习率min_yita // 若迭代次数为零，则最低学习率可以不用写 // 若迭代次数不为零，则学习率为最高学习率，且必须输入最低学习率 接下来是学习实例，每个学习实例2行： 第一行：输入的n(1)个数 第二行：期望的输出 再接下来是M个测试输入 测试输入 N<=40,M<=100 n(i)<=MAX_note // 通过修改常量MAX_layer_count来修改 3<=layer_count<=MAX_layer_count // 通过修改常量MAX_note来修改 0<η<1，推荐0.3<=η<=0.9 输入：[0,1]
 注意：误差E[j,k]=1/2*(y*[j,k]-y[j,k])^2<=ε
 输出文件：BP.out 第一行：总迭代次数 接下来N行：对应每个学习实例的输出和测试输入的输出 接下来为所有权值 }
uses SysUtils, Windows, ClassFunctionsUnit in 'ClassFunctionsUnit.pas';
{ Global Variables }
const MAX_note=20; // 一层神经元个数 MAX_layer_count=10;
var yita,epsilon,min_yita,delta_yita:Extended; layer_count,t,k,instance_count,total_time,ExtraCount:integer; // t - 迭代次数，k - 学习实例序号，total_time - 总迭代次数 func:TFunctions; n:array[1..MAX_layer_count] of integer; // 每层的神经元个数 instances:array[1..140] of record // 学习实例 X,Y:array[1..MAX_note] of Extended; end;
 W:array[1..MAX_layer_count-1] of array[1..MAX_note,1..MAX_note] of Extended; IO_map:array[1..MAX_layer_count,1..MAX_note] of record I,Extended; end; E:array[1..MAX_note] of Extended; // E - 神经网络输出误差 delta:array[1..MAX_layer_count,1..MAX_note] of Extended;
{ Global Procedures }
 procedure LoadFromFile; var F:TextFile; FileName:String; i,j:integer; begin AssignFile(F,'BP.in'); Reset(F); Readln(F,FileName);
 func:=TFunctions.Create(FileName);
 Read(F,layer_count);
 for i:=1 to layer_count do read(f,n); Readln(F);
 Read(F,epsilon); read(F,yita); Read(F,instance_count); Read(F,ExtraCount); Read(F,total_time); if total_time>0 then Read(F,min_yita); Readln(F);
 for i:=1 to instance_count do begin for j:=1 to n[1] do read(f,instances.X[j]); Readln(F); for j:=1 to n[layer_count] do read(F,Instances.Y[j]); Readln(F); end; if ExtraCount>0 then for i:=instance_count+1 to ExtraCount+instance_count do begin for j:=1 to n[1] do read(f,instances.X[j]); Readln(F); end;
 CloseFile(F); end;
 procedure MapIO;forward;
 procedure WriteResultToFile; var F:TextFile; i,j,r:integer; begin AssignFile(F,'BP.out'); Rewrite(F); Writeln(F,t-1); //for k:=1 to instance_count do k:=1; while k<=instance_count+ExtraCount do begin MapIO; if n[1]>1 then for i:=1 to n[1]-1 do write(F,Format('%8.8f,',[Instances[k].X])); write(F,Format('%8.8f',[Instances[k].X[n[1]]])); write(F,' --> '); if n[layer_count]>1 then for i:=1 to n[layer_count]-1 do write(F,Format('%8.8f,',[IO_map[layer_count,i].O])); writeln(F,Format('%8.8f',[IO_map[layer_count,n[layer_count]].O])); k:=k+1; end; for i:=1 to layer_count-1 do for j:=1 to n do for r:=1 to n[i+1] do Writeln(F,Format('w(%d,%d->%d,%d): %8.8f',[i,j,i+1,r,W[j,r]])); CloseFile(F); end;
 procedure Init; var i,j,r:integer; begin // init W for i:=1 to layer_count-1 do for j:=1 to n do for r:=1 to n[i+1] do W[j,r]:=Random(100)/1000; //init t,k t:=1; k:=1; // init delta_yita if total_time>0 then delta_yita:=(yita-min_yita)/total_time else delta_yita:=0; end;
 function computeIn(layer,q:integer):Extended; { TEST OK } // 计算layer层第q个神经元的输入 var j:integer; a,b:Extended; begin if layer=1 then begin Result:=Instances[k].X[q]; Exit; end;
 Result:=0; for j:=1 to n[layer-1] do begin a:=IO_map[layer-1,j].O; b:=W[layer-1][j,q]; Result:=Result+a*b; end; end;
 { MapIO 搞定所有神经元的输入输出值 } procedure MapIO; var i,j:integer; begin for i:=1 to layer_count do for j:=1 to n do begin IO_map[i,j].I:=computeIn(i,j); if i=1 then IO_map[i,j].=func.layer1(IO_map[i,j].I) else begin if i=layer_count then IO_map[i,j].=func.last_layer(IO_map[i,j].I) else IO_map[i,j].=func.middle_layer(IO_map[i,j].I); end; end; end;
 { computeE 计算神经网络的输出误差，在 调用该过程前要先MapIO } procedure computeE; var i:integer; begin for i:=1 to n[layer_count] do E:=sqr(Instances[k].Y-IO_map[layer_count,i].O)/2; end;
 procedure computeDelta; { maybe test OK } var i,j,r:integer; x:Extended; begin for i:=1 to n[layer_count] do delta[layer_count,i]:=(IO_map[layer_count,i].O-Instances[k].Y)* func.d_last_layer(IO_map[layer_count,i].I); for i:=layer_count-1 downto 1 do for j:=1 to n do begin x:=0; for r:=1 to n[i+1] do x:=x+delta[i+1,r]*W[j,r]; if i>1 then // middle layer x:=x*func.d_middle_layer(IO_map[i,j].I) else // first layer x:=x*func.d_layer1(IO_map[i,j].I); delta[i,j]:=x; end; end;
 procedure makeWChange; { maybe Test OK } var deltaW:Extended; i,j,r:integer; begin for i:=1 to layer_count-1 do for j:=1 to n do for r:=1 to n[i+1] do begin deltaW:=-yita*delta[i+1,r]*IO_map[i,j].O; W[j,r]:=W[j,r]+deltaW; end; end;
 function isInRange:Boolean; var i:integer; begin Result:=True; for i:=1 to n[layer_count] do if E>epsilon then begin Result:=False; break; end; end;
 function isAllInRange:Boolean; var old_k:integer; begin MapIO; computeE; if not isInRange then begin Result:=False; Exit; end;
 old_k:=k; Result:=True;
 // while (k<=instance_count)and(k<>old_k) do for k:=1 to instance_count do if k<>old_k then begin MapIO; computeE; if not isInRange then begin Result:=False; break; end; end;
 k:=old_k; end;
 procedure MainCompute; begin while true do begin if (total_time>0) and (t>total_time) then break; if isAllInRange then Break; // MapIO; <-- included in isAllInRange // computeE; computeDelta; makeWChange; t:=t+1; k:=((k+1) mod instance_count)+1; yita:=yita-delta_yita; end; end;
begin Randomize; LoadFromFile;
Init; MainCompute;
WriteResultToFile;
func.Free; end.

dphhzh · 发表于 2005-10-19 19:30:11

<

>高手!佩服!

		自动登录	找回密码
密码			注-册-帐-号