Back
Propagation |
| The most famous neural network paradigm. Training with a teacher. |
Pascal Exemplary Implementation  |
The following source code can be downloaded as a part of the Pascal programs package. This is orig_bp.pas, other modules include object oriented implementation of the Gain Adaptive Back Propagation (GAB).
New: Java version with a support of NetBeans can be also downloaded.
program BackPropagation;
const MaxLayer = 5; { max. number of layers }
MaxNeuron = 15; { max. number of neurons in one layer }
MaxPattern = 50; { max. number of patterns }
type Layers = 0..MaxLayer; { available layers }
Neurons = 1..MaxNeuron; { available neurons }
NeurThrs = 0..MaxNeuron; { neurons including thresholds source }
Patterns = 1..MaxPattern; { usable patterns }
Weights = array [Layers,NeurThrs,Neurons] of real;
{ Weights[i,j,k] : }
{ if j>0 ... weight from neuron j in layer i to }
{ neuron k in layer i+1 }
{ if j=0 ... threshold of neuron k in layer i+1 }
var w,wold : Weights; { values of weights in time t and t-1 }
x : array [Layers,NeurThrs] of real;
{ x[i,j] : }
{ if j>0 ... output value of neuron j in layer i }
{ if j=0 ... value -1 used as a threshold source }
delta : array [Layers,Neurons] of real;
{ delta[i,j] = see remark after Eq.(18), concerning now neuron j in layer i }
lmax : Layers; { layers = 0 [bottom]..lmax [top] }
n : array [Layers] of Neurons; { number of neurons in each layer }
t : Patterns; { number of learning patterns }
xt, yt : array [Patterns,Neurons] of real;
{ all input and expected output patterns from T }
y : array [Neurons] of real;
{ expected output pattern for one chosen pair from T }
eta, alpha : real; { parameters of the algorithm - see Eq.(21) }
Iters : integer; { number of iterations }
Cycles : integer; { number of cycles }
function S ( ksi:real ) : real; { neuron sigmoid transfer function }
const lambda = 1; { sigmoid gain }
RB = 30; { where to extrapolate the sigmoid by a constant }
var inp : real;
begin inp:=lambda*ksi;
if inp>30 then S:=1
else if inp<-30 then S:=0
else S:=1/(1+exp(-inp));
end;
procedure State; { new state of the network }
var l : Layers;
j : NeurThrs;
k : Neurons;
ksi : real; { neuron potential }
begin for l:=1 to lmax do
for k:=1 to n[l] do
begin ksi:=0;
for j:=0 to n[l-1] do
ksi:=ksi+w[l-1,j,k]*x[l-1,j]; { neuron potential }
x[l,k]:=S(ksi) { neuron output }
end
end; { x[lmax,k] is an actual output of the network }
procedure ChangeWeights ( l:Layers ); { new weights for one layer }
var j : NeurThrs;
k : Neurons;
saveW : real;
begin for k:=1 to n[l+1] do
for j:=0 to n[l] do
begin saveW:=w[l,j,k];
w[l,j,k]:=w[l,j,k]-
eta*delta[l+1,k]*x[l,j] +
alpha*(w[l,j,k]-wold[l,j,k]);
wold[l,j,k]:= saveW;
end;
end;
procedure MakeDelta ( l:Layers ); { new delta's for one layer }
var j, k : Neurons;
CumulEr : real; { cumulative error over neurons in a layer }
begin for j:=1 to n[l] do
begin if l=lmax { top layer }
then CumulEr:=x[lmax,j]-y[j]
else begin CumulEr:=0; { calculate from previous layer }
for k:=1 to n[l+1] do
CumulEr:=CumulEr+delta[l+1,k]*w[l,j,k];
end;
delta[l,j]:=x[l,j]*(1-x[l,j])*CumulEr
end
end;
procedure NewWeights; { network new weights }
var l : Layers;
begin for l:=lmax-1 downto 0 do
begin MakeDelta(l+1); { set up delta's in upper layer }
ChangeWeights(l); { calculate weights in this layer }
end
end;
function GlobalError : real; { global error over all layers of the network }
var p : Patterns;
j : Neurons;
Er : real;
begin Er:=0;
for p:=1 to t do
begin for j:=1 to n[0] do x[0,j]:=xt[p,j];
for j:=1 to n[lmax] do y[j]:=yt[p,j];
State;
for j:=1 to n[lmax] do
Er:=Er+Sqr(x[lmax,j]-y[j]);
end;
GlobalError:=Er;
end;
procedure Training; { provides learning of the patterns }
var p : Patterns;
j : Neurons;
Error : real; { cumulative error for one iteration }
iter, cycle : integer;
begin
writeln; { format for printed information }
writeln('Iteration LayerError Pattern Cycle GlobalError');
for cycle:=1 to Cycles do
begin write(chr(13),cycle:38,GlobalError:14:5); { prints of values }
for p:=1 to t do
begin write(chr(13),p:29);
for j:=1 to n[0] do x[0,j]:=xt[p,j];
for j:=1 to n[lmax] do y[j]:=yt[p,j];
for iter:=1 to Iters do
begin State;
Error:=0;
for j:=1 to n[lmax] do
Error:=Error+Sqr(x[lmax,j]-y[j]);
NewWeights;
write(chr(13),iter:5,Error:16:5);
end;
end;
end;
writeln(chr(13),GlobalError:52:5);
end;
procedure Testing; { you can try how well the network is learned, }
{ specifying on the request one or more input vectors }
var i : Neurons;
c : char;
begin writeln;
repeat write('Enter network inputs (',n[0],' values) : ');
for i:=1 to n[0] do read(x[0,i]);
readln;
State;
write('Output of the network is',':':9);
for i:=1 to n[lmax] do write(x[lmax,i]:5:2);
write(' More testing [Y/N] ? ');
read(c);
until (c='N')or(c='n');
writeln;
end;
procedure InitNetwork; { !! network parameters initialization routine }
var l : Layers; { this is the only task dependent procedure !! }
j : NeurThrs;
k : Neurons;
f : text;
begin lmax:=2; { the program will deal with the 4-2-4 network }
n[0]:=4; n[1]:=2; n[2]:=4;
RandSeed:=3456;
{! remove the following brackets numbered 1 if you want to start always !}
{! with new random weights; if you wish to repeat your experiments again !}
{! using the same initialization of weights, let them be there !}
{1 Randomize; 1}
for l:=0 to lmax-1 do
for j:=0 to n[l] do
for k:=1 to n[l+1] do
w[l,j,k]:=6*(Random-0.5)/10;
wold:=w;
eta:=0.3; alpha:=0.7; { choice of learning parameters }
Iters:=15; Cycles:=40; { choice of number of iterations and cycles }
{! remove brackets 2 if you do not want to create your own file of patterns!}
{! according to similar template. After removing the brackets 2, you will !}
{! train the net on identity of vertices of 4-dimensional cube as listed; !}
{! note that the file starts with the number of training pairs. !}
{ copy patterns into file PATTERNS }
{2 assign(f,'PATTERNS');
rewrite(f);
writeln(f,5);
writeln(f,'1 1 0 0 1 1 0 0');
writeln(f,'0 0 1 1 0 0 1 1');
writeln(f,'1 0 1 0 1 0 1 0');
writeln(f,'0 1 0 1 0 1 0 1');
writeln(f,'0 0 0 0 0 0 0 0 ');
close(f); 2}
end;
procedure InitImpl; { implementation init routine }
var l : Layers;
begin for l:=0 to lmax-1 do
x[l,0]:=-1; { used as a threshold source for next layer }
end;
procedure InitPatterns; { learning patterns init routine }
var p : Patterns;
j : Neurons;
f : text;
begin assign(f,'PATTERNS'); reset(f); { use your own file of training set }
read(f,t); writeln; { number of patterns }
for p:=1 to t do
begin for j:=1 to n[0] do
begin read(f,xt[p,j]); { read inputs from PATTERNS }
write(xt[p,j]:5:2); { and print them on screen }
end;
write(' ');
for j:=1 to n[lmax] do
begin read(f,yt[p,j]); { read outputs from PATTERNS }
write(yt[p,j]:5:2); { and print them on screen }
end;
readln(f); writeln;
end;
close(f);
end;
begin { BackPropagation }
InitNetwork;
InitImpl;
InitPatterns;
Training;
Testing;
end. { BackPropagation }
|
|
