The most famous paradigm of self adaptive neural networks. Training without a teacher.

(Original Source) : http://ktiml.mff.cuni.cz/~bozovsky/en/kohonen.htm

I had to change gd, gm at InitEnvironment to smallint type from integer to make it compile on today's compilers.

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: smallint;
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 }