The following source code can be downloaded as kohonen.pas.
program Kohonen;
uses Crt,Graph;
const n = 2; m = 15; l =15;
n1 = n-1; m1 = m-1; l1 = l-1;
mdiv2 = (m+l)/2;
ExpPar = 0.045;
ViewParam = 0;
Scale = 400;
Shift = 5;
type number = real;
nRank1 = 0..n1;
input = array [nRank1] of number;
mRank1 = 0..m1;
lRank1 = 0..l1;
var w : array [mRank1,lRank1] of input;
x : input;
Neigh : integer;
Down : real;
Param : word;
function max ( a,b:integer ) : mRank1;
begin if a>b then max:=a else max:=b
end;
function min ( a,b:integer ) : mRank1;
begin if a<b then min:=a else min:=b
end;
procedure SetDependentParams;
var aux : real;
begin aux:=ln(Param);
aux:=exp(-ExpPar*sqr(aux));
Down:=aux;
Neigh:=Round(mdiv2*aux);
end;
function Coord ( x:number ) : integer;
begin Coord:=Round(Scale*x+Shift)
end;
procedure SetXs;
var j : nRank1;
begin if (Param>8000)and(Param mod 50<2) then j:=0*Random(2);
for j:=0 to n1 do x[j]:=Random;
end;
procedure InitParameters;
var i1,i2 : mRank1;
j : nRank1;
begin RandSeed:=257623757;
for i1:=0 to m1 do
for i2:=0 to l1 do
for j:=0 to n1 do
w[i1,i2][j]:=0.5+0.0007*Random(100);
SetColor(Red);
Rectangle(Shift-1,Shift-1,Scale+Shift+1,Scale+Shift+1);
for Param:=0 to 1000 do
begin SetXs;
PutPixel(Coord(x[0]),Coord(x[1]),LightBlue);
end;
Param:=1;
SetDependentParams;
end;
procedure InitEnvironment;
var gd,gm:integer;
begin gd:=VGA; gm:=VGAHi;
InitGraph(gd,gm,'');
SetFillStyle(SolidFill,Black);
end;
procedure ViewMap;
var i1,i2 : mRank1;
q:word;
begin SetColor(Green);
SetWriteMode(XORPut);
for i2:=0 to l1 do
begin MoveTo(Coord(w[0,i2][0]),Coord(w[0,i2][1]));
for i1:=1 to m1 do
LineTo(Coord(w[i1,i2][0]),Coord(w[i1,i2][1]));
end;
for i1:=0 to m1 do
begin MoveTo(Coord(w[i1,0][0]),Coord(w[i1,0][1]));
for i2:=1 to l1 do
LineTo(Coord(w[i1,i2][0]),Coord(w[i1,i2][1]));
end;
SetWriteMode(NormalPut);
end;
procedure Draw ( from1,to1:mRank1; from2,to2:lRank1 );
var i1,i2,f1,t1,f2,t2 : mRank1;
begin SetColor(Green);
SetWriteMode(XORPut);
if from1>0 then f1:=from1-1
else f1:=from1;
if to1<m1 then t1:=to1+1
else t1:=to1;
for i2:=from2 to to2 do
begin MoveTo(Coord(w[f1,i2][0]),Coord(w[f1,i2][1]));
for i1:=f1+1 to t1 do
LineTo(Coord(w[i1,i2][0]),Coord(w[i1,i2][1]));
end;
if from2>0 then f2:=from2-1
else f2:=from2;
if to2<l1 then t2:=to2+1
else t2:=to2;
for i1:=from1 to to1 do
begin MoveTo(Coord(w[i1,f2][0]),Coord(w[i1,f2][1]));
for i2:=f2+1 to t2 do
LineTo(Coord(w[i1,i2][0]),Coord(w[i1,i2][1]));
end;
SetWriteMode(NormalPut);
end;
procedure Update;
var i1,i2,a1,a2,from1,to1,from2,to2 : mRank1;
j : nRank1;
d,dmin : real;
s : string[7];
begin if Param>ViewParam then
begin SetColor(LightGray);
Bar(500,0,540,7);
Str(Param:3,s);
OutTextXY(500,0,s);
end;
SetXs;
a1:=0; a2:=0; dmin:=1000000+1; { > max. sum of distances }
for i1:=0 to m1 do
for i2:=0 to l1 do
begin d:=0;
for j:=0 to n1 do
d:=d+Sqr(x[j]-w[i1,i2][j]);
if dmin>d then begin a1:=i1; a2:=i2;
dmin:=d
end
end;
from1:=max(0,a1-Neigh);
to1:=min(m1,a1+Neigh);
from2:=max(0,a2-Neigh);
to2:=min(l1,a2+Neigh);
if Param>ViewParam then
Draw(from1,to1,from2,to2);
for i1:=from1 to to1 do
for i2:=from2 to to2 do
for j:=0 to n1 do
w[i1,i2][j]:=w[i1,i2][j]+down*(x[j]-w[i1,i2][j]);
if Param>ViewParam then Draw(from1,to1,from2,to2);
end;
begin { Kohonen }
InitEnvironment;
InitParameters;
repeat if Param=ViewParam+1 then ViewMap;
Update;
Param:=Param+1;
SetDependentParams;
if KeyPressed then
case ReadKey of
#27 : Halt;
else
end;
until (down<0.000001);
end. { Kohonen }
|
