+-------------------------------------------------------------+
|                      6. Programmlisting                     |
+-------------------------------------------------------------+

{************************************************************}
{*    Hebb-Net-Simulation    (c) by Marcus Hutter 25.6.90   *}
{************************************************************}

PROGRAM HebbNet;

{---------------------}
{ Vars, Consts, Types }
{---------------------}
USES Crt;

CONST
  MaxUNum = 30;              { Max. Unit-Number }
  MaxCNum = MaxUNum*MaxUNum; { Max. Connection-Number }
  ESC     = #27;
  none    = #0;

  synchron = true;           { Synchron Update of Units }
  rpres    = false;          { random pattern-presentation }
  lr       = 0.001;          { lernrate }
  ReInOff  = 0;              { Reinf-Input in remind-mode }
  scl      = 5;              { scaling factor }

TYPE
  TUnitId =  1..MaxUNum;
  TUnit0Id = 0..MaxUNum;
  TUnit = record activ:  real; { Unit-activation }
                 output: real; { Unit-output }
                 kind:   Byte; { Unit-kind (not used) }
          end;
  TUnits = array[TUnit0Id] of TUnit;

  TConn = record weight: real; { Weight }
                 elig:   real; { Connection-eligibility }
                 kind:   Byte; { (not used) }
          end;
  TConns = array[TUnit0Id,TUnitId] of TConn;
  { Weights to Unit 0 are Offsets }

VAR
  Conns:   TConns;             { all connections }
  Units:   TUnits;             { all units }
  XInp:    array[TUnitId] of real; { external net-Input }
  WSt:     Integer;            { External World-Status }
  LernF:   boolean;            { Lern-Flag }
  RE:      real;               { middle Reinforcement }
  c:       char;
  dev:     Text;               { Output-Device }

{$DEFINE Example4}             { Compile Example }

{-------------------}
{ Special Functions }
{-------------------}
FUNCTION sign(x:real):integer;
  begin
    if x>0 then sign:=+1 else
    if x<0 then sign:=-1 else sign:=0
  end;

FUNCTION bound(x,l,u: real):real;
  begin
    if x>u then bound:=u else
    if x<l then bound:=l else
    bound:=x;
  end;

FUNCTION actf(x: real):real;
{ Activation-Function of Units }
  begin actf:=bound(x*scl,-1,+1) end;

{----------------}
{$IFDEF Example1 }
{----------------}
{ Hebb-Net to lern 14 Bool-Functions }
CONST
  PSTime = 15; { Pattern-Show-Time }
  PNum = 4;    { Pattern-Number }
  PLen = 2;    { Pattern-Lenght }
  OLen = 1;    { Output-Length }
  ReIn = 5;    { ReinforcementInput-UnitId }
  UnitNum = 8; { Unit Number (here constant) }

TYPE
  TPatN = 1..PNum;  { Pattern-Numbers }

CONST   { Table of Input-Units }
  ITab: array[1..PLen] of TUnitId = (6,8); { Input-UnitIds }
  OTab: array[1..OLen] of TUnitId = (7);   { Output-UnitIds }
  IPat: array[TPatN,1..PLen] of integer =  { Input-Patterns }
   ((-1,-1 ),(-1,+1 ),(+1,-1 ),(+1,+1) );
  OPat: array[TPatN,1..OLen] of integer =  { Output-Patterns }
   (  (-1)  ,  (+1)  ,  (+1)  ,  (+1)  );  { Or-Function }
  ConW: array[0..UnitNum,1..UnitNum] of real = { Weight-Array }
   ( ( 1, 1,-1, 0, 0, 0, 0, 0 ),   { OffSets }
     ( 0, 0, 1, 0, 0, 0, 0, 0 ),   { Conn. from 1 }
     ( 0, 0, 1, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 1, 0 ),
     ( 1,-1, 0, 0, 0, 0, 0, 0 ),
     (-1, 1, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 2, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0 ) );
  ConE: array[0..UnitNum,1..UnitNum] of real = { Elig.-Array }
   ( ( 0, 0, 0, 0, 0, 0, 2, 0 ),   { OffSets }
     ( 0, 0, 0, 0, 0, 0, 0, 0 ),   { Conn. from 1 }
     ( 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0 ),      { ... }
     ( 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 2, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 2, 0 ) );
{$ENDIF}

{----------------}
{$IFDEF Example3 }
{----------------}
{ Hebb-Net to lern 16 Bool-Functions incl. XOR (1 lernlayer) }CONST
  PSTime = 15; { Pattern-Show-Time }
  PNum = 4;    { Pattern-Number }
  PLen = 2;    { Pattern-Lenght }
  OLen = 1;    { Output-Length }
  ReIn = 3;    { ReinforcementInput-UnitId }
  UnitNum = 12;{ Unit Number (here constant) }

TYPE
  TPatN = 1..PNum;  { Pattern-Numbers }

CONST   { Table of Input-Units }
  ITab: array[1..PLen] of TUnitId = (1,2);   { Input-UnitIds }
  OTab: array[1..OLen] of TUnitId = (10);    { Output-UnitIds }
  IPat: array[TPatN,1..PLen] of integer = { Input-Patterns }
   ((-1,-1),(-1,+1),(+1,-1),(+1,+1) );
  OPat: array[TPatN,1..OLen] of integer = { Output-Patterns }
   ( (-1)  , (-1)  , (-1)  , (+1)   );    { Or/And-Function }
  ConW: array[0..UnitNum,1..UnitNum] of real =
  { to_1__2__3__4__5__6__7__8__9_10_11_12_ }
   ( ( 0, 0, 0, 0,-1,-1,-1,-1,-1,-3, 1, 1 ),   { OffSets }
     ( 0, 0, 0, 0, 1, 0,-1, 0, 1, 0, 1, 0 ),   { Conn. from 1 }
     ( 0, 0, 0, 0,-1, 0, 1, 0, 1, 0, 1, 0 ),
     ( 0, 0, 0, 0, 0,-1, 0, 1, 0, 0, 0, 0 ),      { ... }
     ( 0, 0, 0, 0, 0, 1, 0,-1, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ) );
  ConE: array[0..UnitNum,1..UnitNum] of real =
   ( ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),   { OffSets }
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),   { Conn. from 1 }
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),      { ... }
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ) );
{$ENDIF}

{----------------}
{$IFDEF Example4 }
{----------------}
{ Hebb-Net to lern 14*14 Bool-Functions }
CONST
  PSTime = 20; { Pattern-Show-Time }
  PNum = 4;    { Pattern-Number }
  PLen = 2;    { Pattern-Lenght }
  OLen = 2;    { Output-Length }
  ReIn = 3;    { ReinforcementInput-UnitId }
  UnitNum = 12;{ Unit Number (here constant) }

TYPE  TPatN = 1..PNum;  { Pattern-Numbers }

CONST   { Table of Input-Units }
  ITab: array[1..PLen] of TUnitId = (1,2);   { Input-UnitIds }
  OTab: array[1..OLen] of TUnitId = (10,11); { Output-UnitIds }
  IPat: array[TPatN,1..PLen] of integer = { Input-Patterns }
   ((-1,-1),(-1,+1),(+1,-1),(+1,+1) );
  OPat: array[TPatN,1..OLen] of integer = { Output-Patterns }
   ((-1,-1),(+1,-1),(+1,-1),(+1,+1) );    { Or/And-Function }
  ConW: array[0..UnitNum,1..UnitNum] of real =
  { to_1__2__3__4__5__6__7__8__9_10_11_12_ }
   ( ( 0, 0, 0, 0, 0, 1, 1, 1, 1,-3,-3, 1 ),   { OffSets }
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),   { Conn. from 1 }
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0,-1,-1, 1, 1, 0, 0, 0 ),      { ... }
     ( 0, 0, 0, 0, 0, 1, 0,-1, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 1, 0,-1, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0 ),
     ( 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ) );
  ConE: array[0..UnitNum,1..UnitNum] of real =
   ( ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),   { OffSets }
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 0 ),   { Conn. from 1 }
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),      { ... }
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ),
     ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 0 ) );
{$ENDIF}

{----------------}
{$IFDEF Example5 }
{----------------}
{ Hebb-Net to lern Room-Inventory-Relation }
{ Test !! }
CONST
  PSTime = 20; { Pattern-Show-Time }
  PNum = 5;    { Pattern-Number }
  PLen = 9;    { Pattern-Lenght }
  OLen = 5;    { Output-Length }
  ReIn = 30;   { ReinforcementInput-UnitId }
  UnitNum = 30;{ Unit Number (here constant) }

TYPE
  TPatN = 1..PNum;  { Pattern-Numbers }

CONST   { Table of Input-Units }
  ITab: array[1..PLen] of TUnitId =       { Input-UnitIds }
    (1,2,3,4,5,6,7,8,9);
  OTab: array[1..OLen] of TUnitId =       { Output-UnitIds }
    (10,11,12,13,14);
  IPat: array[TPatN,1..PLen] of integer = { Input-Patterns }   
   ((-1,-1,+1,-1,-1,+1,+1,-1,+1),
    (-1,+1,+1,+1,-1,+1,-1,-1,+1),
    (-1,-1,+1,-1,-1,-1,-1,+1,-1),
    (+1,-1,-1,+1,-1,+1,+1,-1,-1),
    (-1,+1,-1,-1,+1,+1,-1,-1,+1));
  OPat: array[TPatN,1..OLen] of integer = { Output-Patterns }
   ( (+1,-1,-1,-1,-1),
     (-1,+1,-1,-1,-1),
     (-1,-1,+1,-1,-1),
     (-1,-1,-1,+1,-1),
     (-1,-1,-1,-1,+1) );

{ ConW and ConE are defined in InitExample }

{$ENDIF}

{----------------------}
{ Forward-Declarations }
{----------------------}
PROCEDURE chdo(ch:char); forward;
FUNCTION event:char;     forward;

{-------------}
{ IO-Features }
{-------------}
PROCEDURE wrConns;
{ Write Connections }
  var c: TUnit0Id;
      u: TUnitId;
  begin writeln(dev,'Connection-Strength:');
    for c:=0 to UnitNum do begin
      for u:= 1 to UnitNum do
        write(dev,100*Conns[c,u].weight:5:0);
      writeln(dev);
    end;
  end;

PROCEDURE wrUnits;
{ Write Activation of Units (in one line) }
  var u: TUnitId;
  begin
    for u:=1 to UnitNum do
      write(dev,100*Units[u].activ:5:0);
    writeln(dev);
  end;

PROCEDURE SaveStatus;
{ Save Status (Connection-Weights) to Disk }
  var sdev: file;
  begin
    writeln(dev,'Saving Status as Status.Dat');
    assign(sdev,'D:\pascal\myprogs\status.dat');
    rewrite(sdev,1);
    blockwrite(sdev,Conns,SizeOf(Conns));
    close(sdev);
  end;

PROCEDURE LoadStatus;
{ Load Status (Connection-Weights) from Disk }
  var sdev: file;
  begin
    writeln(dev,'Loading Status from Status.Dat');    
    assign(sdev,'D:\pascal\myprogs\status.dat');
    reset(sdev,1);
    blockread(sdev,Conns,SizeOf(Conns));
    close(sdev);
  end;

PROCEDURE wrStatus;
{ Write Status (Connection-Weights) }
  begin wrConns end;

{----------------}
{ Initialisation }
{----------------}
PROCEDURE InitExample;
{ Example-Specific-Initialistion-Routine }
  var c: TUnit0Id;
      u: TUnitId;
  begin
  {$IFDEF Example5 }
  { Create Net with Input-Units 1..9, Output-Units 10..14,
    Feedback-Units 14..29, R-Input-Unit 30 }
    FillChar(Conns,SizeOf(Conns),0);
    for c:=1 to OLen do begin
      for u:=1 to PLen do Conns[u,PLen+c].elig:=1;
      Conns[0,PLen+c].weight:=-5;
      Conns[PLen+OLen-2+3*c,PLen+c].weight:=-5;
      Conns[PLen+OLen-1+3*c,PLen+c].weight:=-5;
      Conns[0,PLen+OLen-2+3*c].weight:=-1;
      Conns[0,PLen+OLen-1+3*c].weight:=-1;
      Conns[PLen+OLen+3*c,PLen+OLen-2+3*c].weight:=+1;
      Conns[PLen+OLen+3*c,PLen+OLen-1+3*c].weight:=-1;
      Conns[ReIn,PLen+OLen-2+3*c].weight:=-1;
      Conns[ReIn,PLen+OLen-1+3*c].weight:=+1;
      Conns[PLen+c,PLen+OLen+3*c].weight:=1;
      Conns[PLen+OLen+3*c,PLen+OLen+3*c].weight:=1;
    end;
  {$ELSE}
  { Copy Net from Example to Conns-Array }
    for c:=0 to UnitNum do
      for u:=1 to UnitNum do begin
        Conns[c,u].weight:=ConW[c,u];
        Conns[c,u].elig:=ConE[c,u];
      end;
  {$ENDIF}
  end;

PROCEDURE InitConns;
{ Initialize weights with 0 and eligibility with 1 }
  var c: TUnit0Id;
      u: TUnitId;
  begin
    for c:=0 to MaxUNum do
      for u:=1 to MaxUNum do begin
        Conns[c,u].weight:=0;
        Conns[c,u].elig:=1;
      end;
  end;

PROCEDURE InitUnits;
{ Random-Initialisation of Unit-Output }
  var u:TUnitId;
  begin    FillChar(Units,SizeOf(Units),0);
    for u:=1 to MaxUNum do  { Random-Init }
      Units[u].output:=integer(random(3))-1;
    Units[0].output:=1;
    Units[0].activ:=1;
  end;

PROCEDURE InitNet;
{ Initialize Net }
  begin
    InitConns;
    InitUnits;
    FillChar(XInp,SizeOf(XInp),0);
    InitExample;
    RE:=OLen;
  end;

{--------------}
{ Net-Dynamics }
{--------------}
PROCEDURE EvalUnit(u: TUnitId);
{ Calculate new Unit-Activation with old Unit-Output }
  var s: real;
      c: TUnit0Id;
  begin
    s:=XInp[u];
    for c:=0 to UnitNum do
      s:=s + Units[c].output * Conns[c,u].weight;
    Units[u].activ:=s;
  end;

PROCEDURE EvalConn(c:TUnit0Id; u: TUnitId);
{ Change Conns[c,u].weight with Hebb-Rule }
  var change: real;
  begin
    if Conns[c,u].elig<>0 then begin
      change:=bound(Units[u].activ,-1,1) *
              bound(Units[c].activ,-1,1);
      Conns[c,u].weight:=
        bound( (1-lr)*Conns[c,u].weight
               + lr*change*Conns[c,u].elig ,-1,+1);
    end;
  end;

PROCEDURE UpdUOut(u: TUnitId);
{ Update Unit-Output (Activation --> Output) }
  begin Units[u].output:=actf(Units[u].activ) end;

PROCEDURE SetXInp;
{ Set external Input (Pattern[WSt] & Reinf.) ,
  Calculate Reinforcement-Signal and expectation of R. }
  var n: integer;
      R: real;
  begin
    FillChar(XInp,SizeOf(XInp),0); { not needed }
    XInp[ReIn]:=ReInOff;
    for n:=1 to PLen do XInp[ITab[n]]:=IPat[WSt,n];
    if LernF then begin  { Set Reinforce-Input }
      R:=0;
      for n:=1 to OLen do R:=R +
        Abs(Units[OTab[n]].output-OPat[WSt,n]);
      XInp[ReIn]:=OLen-R;      RE:=RE+0.002*(R-RE);
    end;
  end;

PROCEDURE TimeStep;
{ One Simulation-Step: SetXInp -> EvalUnit --> (EvalConn) }
  var c: TUnit0Id;
      u,v: TUnitId;
  begin
    SetXInp;
    for u:=1 to UnitNum do
      if synchron then EvalUnit(u)
      else begin
        v:=random(integer(UnitNum))+1;
        EvalUnit(v); UpdUOut(u);
      end;
    if LernF then
      for c:=0 to UnitNum do
        for u:=1 to UnitNum do
          EvalConn(c,u);
    for u:=1 to UnitNum do UpdUOut(u);
  end;

{------------}
{ Simulation }
{------------}
PROCEDURE dis1Pat;
{ Can be used to disturb disturb Inputpattern }
  var i,k: integer;
  begin end;

PROCEDURE dis2Pat;
{ Can be used to disturb disturb Inputpattern }
  begin end;

PROCEDURE lern;
{ 10 Lern-Cycles for a Set of Patterns defined in Example }
{ Show Pattern PSTime-TimeSteps }
  var t,k,p: integer;
  begin
    writeln(dev,'Pattern-Lerning');
    lernF:=true;
    for k:=1 to 10 do
    begin
      for p:=1 to PNum do begin
        if rpres then WSt:=random(PNum)+1 else WSt:=p;
        writeln(dev,'Pattern ',WSt,'   RE=',RE:0:2);
        InitUnits;
        for t:=1 to PSTime do begin
          TimeStep; wrUnits;
          if event=ESC then exit;
        end;
      end;
      wrConns;
    end;
  end;

PROCEDURE remind;
{ Remind Output to every Pattern without R-Signal }
  var t: integer;
  begin
    writeln(dev,'Pattern-Reminding');    lernF:=false;
    for WSt:=1 to PNum do begin
      writeln(dev,'Pattern ',WSt);
      InitUnits;
      for t:=1 to PSTime do begin
        TimeStep; wrUnits;
        if event=ESC then exit;
      end;
    end;
  end;

{-----------------}
{ Test-Procedures }
{-----------------}
PROCEDURE Test1;
  begin
    writeln(dev,'Init Example');
    InitExample;
  end;

PROCEDURE Test2;
  begin
    writeln(dev,'Test-Routine 2');
  end;

{--------------}
{ Menu-Control }
{--------------}
PROCEDURE wrMenu;
{ Write Menu in first screenline }
  begin
    window(1,1,80,1);
    TextBackGround(Blue);
    ClrScr;
    write('Save Load sTatus Help lerN reMind',
            ' DisturB Intr Cont test1/2 R');
    window(1,3,80,48);
    TextBackGround(Black);
  end;

PROCEDURE Menu;
{ wait for Key / Menu-selection }
  var ch:char;
  begin
    repeat
      ch:=ReadKey;
      chdo(ch);
    until ch='c';
  end;

PROCEDURE chdo(ch:char);
{ Branch on Menu-Selection ch }
  begin
    case ch of
     's': SaveStatus;  { Save status }
     'l': LoadStatus;  { Load status }
     't': wrStatus;    { write sTatus }
     'h': Menu;        { Help (not implemented) }
     'n': lern;        { lerN }
     'm': remind;      { reMind }
     'd': dis1pat;     { disturb 1 }
     'b': dis2pat;     { disturb 2 }     
     'i': Menu;        { Interrupt }
     'c':              { Continue procedure }
          writeln('Procedure Continued');
     '1': Test1;
     '2': Test2;
     'r': wrMenu;      { Refresh }
    end;
  end;

FUNCTION event:char;
{ look for keyboard-event }
  var ch:char;
  begin
    event:=none;
    if KeyPressed then begin
      ch:=ReadKey;
      chdo(ch);
      event:=ch;
    end;
  end;

{--------------}
{ Main Program }
{--------------}
BEGIN
  TextMode(Font8x8+CO80);    { Screen-Init. }
  TextColor(Yellow);         { Color-Init. }
  Randomize;                 { Random-Generator-Init. }
  wrMenu;                    { write Menu }
  assignCrt(dev);            { Output-Device-Init. }
  rewrite(dev);
  InitNet;                   { Net-Init }
  Menu;                      { Wait for Menu-Selection }
  close(dev);
END.