{------------------------------------------------------------------------------}
                                   Program 
{------------------------------------------------------------------------------}
                               Backpropagation
                               (Input, Output);
{------------------------------------------------------------------------------}
{                     Back-Propagation Networks Simulator                      }
{------------------------------------------------------------------------------}
{                  Implementation of Advanced Learning Rules                   }
{------------------------------------------------------------------------------}
{                    Copyright (C) 1992  by  Steffen Beyer                     }
{------------------------------------------------------------------------------}
{                This program may be used and distributed freely               }
{                    for personal use or scientific research                   }
{              --- Commercial use and distribution prohibited ---              }
{------------------------------------------------------------------------------}
{                         Geschrieben 1990/91/92                               }
{                                   von                                        }
{                      Steffen Beyer   Matr.-Nr. 142 832                       }
{                          als Teil der Diplomarbeit                           }
{                          Eingereicht zum 30.4.1992                           }
{     Betreuer:                                                                }
{                                                                              }
{     Prof. Dr. Walter Huber         Prof. Dr. Walter Oberschelp               }
{     Dr. Klaus Willmes                                                        }
{                                                                              }
{     Klinikum der RWTH Aachen       Lehrstuhl fuer angewandte Mathematik      }
{     Neurologische Klinik           insbesondere Informatik                   }
{     Abteilung Neurolinguistik                                                }
{     Pauwelsstrasse 30              Ahornstrasse 155                          }
{     5100 Aachen                    5100 Aachen                               }
{                                                                              }
{------------------------------------------------------------------------------}
                                    Const
{------------------------------------------------------------------------------}
                   maxinp = 100; { maximum number of input units  }
                   maxhid = 100; { maximum number of hidden units }
                   maxout = 100; { maximum number of output units }
                   maxmode =  7;
                 { maximum number of available learning algorithms }
{------------------------------------------------------------------------------}
                     xmax = 4095; { Graphic terminal maximum x-coordinate }
                     xlim = 4096;
                     ymax = 3134; { Graphic terminal maximum y-coordinate }
                     ylim = 3135;
{------------------------------------------------------------------------------}
                             shortlength  =   5;
                            stringlength  =  30;
                              linelength  =  80;
                              longlength  = 255;
{------------------------------------------------------------------------------}
                                    Type
{------------------------------------------------------------------------------}
                  datatype = (none,normal,converted,mixed);
                    IOtype = (screen,file1,file2);
{------------------------------------------------------------------------------}
                   inpvector = array[0..maxinp] of real;
                   hidvector = array[0..maxhid] of real;
                   outvector = array[0..maxout] of real;
{------------------------------------------------------------------------------}
                 short  = varying[  shortlength ] of char;
                 string = varying[ stringlength ] of char;
                 line   = varying[   linelength ] of char;
                 long   = varying[   longlength ] of char;
{------------------------------------------------------------------------------}
                                    Var   
{------------------------------------------------------------------------------}
                               inp : integer;
                               hid : integer;
                               out : integer;

                              inpV : inpvector;
                              hidV : hidvector;
                              outV : outvector;
                              tarV : outvector;

                   Wji : array[0..maxhid, 0..maxinp] of real;
                   Wkj : array[0..maxout, 0..maxhid] of real;
{ weight matrix }
                   Sji : array[0..maxhid, 0..maxinp] of real;
                   Skj : array[0..maxout, 0..maxhid] of real;
{ save area for weight matrix }
                   dji : array[0..maxhid, 0..maxinp] of real;
                   dkj : array[0..maxout, 0..maxhid] of real;
{ last matrix update }
                   mji : array[0..maxhid, 0..maxinp] of real;
                   mkj : array[0..maxout, 0..maxhid] of real;
{ current partial derivative and sum of derivatives for batch1 }
                   rji : array[0..maxhid, 0..maxinp] of real;
                   rkj : array[0..maxout, 0..maxhid] of real;
{ last partial derivative (QuickProp, delta-bar-delta and Almeidas algorithm) }
                   bji : array[0..maxhid, 0..maxinp] of real;
                   bkj : array[0..maxout, 0..maxhid] of real;
{ sum of updates for batch2 }
                   eji : array[0..maxhid, 0..maxinp] of real;
                   ekj : array[0..maxout, 0..maxhid] of real;
{ individual learn rates (delta-bar-delta rule and Almeidas algorithm) }
{------------------------------------------------------------------------------}
                            RandomStr : varying[10] of char;
                             firstrun : boolean;
                                break : char;
                                 Rand : unsigned;  { random number seed }
                                    c : char;
{------------------------------------------------------------------------------}
                      { Graphics Subroutine Declarations }
{------------------------------------------------------------------------------}
Xcount : integer;
Procedure Code(S:Integer); External;
Procedure Clear_Screen; External;
Procedure Clear_Dialog; External;
Procedure Move(X,Y:Integer); External;
Procedure Draw(X,Y:Integer); External;
Procedure Box(X1,Y1,X2,Y2:Integer); External;
{------------------------------------------------------------------------------}
                         { General Utility Routines }
{------------------------------------------------------------------------------}
Procedure UpperCase(var c : char);
Begin
  If c in ['a'..'z'] then c := chr( ord(c) - ord('a') + ord('A') )
End;

Function MTH$RANDOM(var seed: unsigned):real; extern;
{ library random number generator }

Function Random(a,b : real) : real;
Begin
  Random := a + MTH$RANDOM(Rand) * (b-a)
End;

Procedure GetRandom;
Var str : packed array[1..11] of char;
Begin
  Time(str);
  If length(RandomStr)>8
  then RandomStr := substr(str,10,2) + substr(RandomStr,1,8)
  else RandomStr := substr(str,10,2) + RandomStr
End;

Procedure Randomize;
Begin
  If length(RandomStr)>9 then RandomStr := substr(RandomStr,1,9);
  ReadV(RandomStr,Rand);
  WriteLn;
  WriteLn('Random number seed: ',Rand)
End;

Procedure Wait;
Begin
  WriteLn;
  WriteLn('(Press <CR> to return to main menu)');
  ReadLn;
  GetRandom
End;

Procedure Continue;
Begin
  WriteLn;
  WriteLn('(Press <CR> to continue)');
  ReadLn;
  GetRandom
End;

Procedure Empty;
Begin
  WriteLn;
  WriteLn('No patterns in buffer to learn.',chr(7));
  Wait
End;

Procedure NoGraphics;
Begin
  WriteLn;
  WriteLn('Sorry - no graphics available on your terminal.',chr(7));
  Continue
End;

Function Sign(X : Real) : Integer;
Begin
  If (X = 0.0) Then Sign := 0
  Else If (X < 0.0) then Sign := -1
                    else Sign :=  1
End;
{------------------------------------------------------------------------------}
                        { Back-Propagation Main Part }
{------------------------------------------------------------------------------}
Procedure BP;

Type   Zeiger = ^Struct;
       Struct = Record
                  Input  : inpvector;
                  Target : outvector;
                  Tag    : string;
                  Weight : real;    { for dynamic learning }
                  Count  : integer; { number of presentations during learning }
                  Next   : Zeiger
                End;

Var      Name : string;
           NI : short;
           NH : short;
           NO : short;
       IOfile : text;
       IOname : string;
      Logfile : text;
      Logname : string;
    Logactive : boolean;
     Logcount : integer;
     IOselect : IOtype;
       suffix : array[0..7] of string;
      default : array[0..7] of string;
     filetype : array[0..7] of string;
    learntype : array[0..6] of string;
     dataflag : datatype;
         Root : Zeiger;
          Buf : long;
          Tag : string;
       Result : real;
      display : long;
{------------------------------------------------------------------------------}
                          { Simulation Variables }
{------------------------------------------------------------------------------}
         stop : boolean;  { stop flag for learning routines }
        worse : boolean;  { error increased flag }
     localsum : real;     { sum calculated in localerr }
     localRMS : real;     { localsum divided by # of output units & 4 if symm }
      MAXnorm : boolean;  { type of error measure to be used: F=RMS, T=MAX }
      globERR : real;     { global error save variable }
      globLMS : real;     { global Least Mean Squares error }
      globRMS : real;     { global Root Mean Squares error }
      globMAX : real;     { global maximum norm }
      globVAL : boolean;  { indicates validity of contents of globERR }
      bestERR : real;     { best global error reached so far }
      bestVAL : boolean;  { indicates validity of contents of bestERR }
       oldERR : real;     { previous globERR }
       oldVAL : boolean;  { oldERR VALidity }
       abserr : real;     { maximum absolute error }
      patterr : real;     { maximum pattern error }
       unique : boolean;  { add uniqueness error term to local err? }
    tolerance : real;     { zero error if | Out - Targ | < tolerance }
      errbias : real;     { error bias to avoid trivial minima }
       enable : boolean;  { enable/inhibit graphics }
   batch1flag : boolean;  { batch1 on/off flag }
   batch2flag : boolean;  { batch2 on/off flag }
       Toggle : boolean;  { true/false = cycles/epochs (with UF) }
       Cancel : boolean;  { cancel learn steps that increased error }
      SaveOpt : boolean;  { save option to save best matrix automatically }
      KeepOpt : boolean;  { option to keep a copy of best matrix found }
      KeepVAL : boolean;  { indicates validity of weight matrix save area }
        learn : boolean;  { only count Psteps and BPsteps during learning }
       Psteps : integer;  { number of Propagation calls }
      BPsteps : integer;  { number of Backpropagation calls }
      updates : integer;  { number of weight matrix updates }
       cycles : integer;  { number of learning cycles executed }
       epochs : integer;  { number of learning epochs executed }
      Scycles : integer;  { save number of cycles }
      Sepochs : integer;  { save number of epochs }
      SPsteps : integer;  { save number of Prop calls }
     SBPsteps : integer;  { save number of BackProp calls }
     Supdates : integer;  { save number of updates }
    weightsum : real;     { sum of weights of all patterns }
     patterns : integer;  { number of patterns in buffer }
{------------------------------------------------------------------------------}
                          { Simulation Parameters }
{------------------------------------------------------------------------------}
         mode : integer;  { version of weight update routine to use }
     symmetry : boolean;  { use of the symmetric logistic function and }
                          { values in the range [-1, 1] }
        range : real;  { range of random values for matrix initialization }
          eta : real;  { learning rate }
          mom : real;  { momentum }
       lambda : real;  { Chan & Fallside's algorithm lambda (for mom calculation) }
       mineta : real;  { Chan & Fallside's algorithm minimum for eta }
       maxeta : real;  { Chan & Fallside's algorithm maximum for eta }
         Smin : real;  { Steffen's algorithm minimum for eta }
         Smax : real;  { Steffen's algorithm maximum for eta }
        Theta : real;  { delta-bar-delta rule parameter }
        Kappa : real;  { delta-bar-delta rule parameter }
          Phi : real;  { delta-bar-delta rule parameter }
            u : real;  { Almeidas algorithm up factor }
            d : real;  { Almeidas algorithm down factor }
     hypererr : boolean; { (Fahlmans suggestion) flag for hyperbolic err fctn }
     spliteta : boolean; { Fahlmans QuickProp algorithm flag }
    threshold : real;    { Fahlmans QuickProp algorithm parameter }
    maxfactor : real;    { Fahlmans QuickProp algorithm parameter }
 shrinkfactor : real;    { Fahlmans QuickProp algorithm parameter }
        decay : real;    { Fahlmans QuickProp algorithm parameter }
           RF : integer;  { pattern repeat factor (periodical & dynamic) }
           UF : integer;  { number of cycles/epochs, after which all }
                          { weights are updated (in dynamic learning) }
      maxstep : real;     { maximum step size in Schmidhuber's algorithm }
{------------------------------------------------------------------------------}
                    { Central Neural Network BP Routines }
{------------------------------------------------------------------------------}
{------------------------ Forward Pass : Propagation --------------------------}
Procedure PerceptronProp;
Var j,k : integer;
    sum : real;
Begin
  inpV[0] := 0.0; { bias not used in usual way }
  For k:=1 to out do
  begin         { linear threshold activation function: }
    sum := 0.0;
    For j:=1 to inp do sum := sum + Wkj[k,j] * inpV[j];
    If (sum > Wkj[k,0]) Then outV[k] := 1.0 Else
    If symmetry Then outV[k] := -1.0 Else outV[k] := 0.0
  end
End;

Procedure Propagate;
Var i,j,k : integer;
      sum : real;
Begin { Propagate }
  If learn then Psteps := succ(Psteps);
  If (mode=6) Then PerceptronProp Else
  Begin
    inpV[0] := 1.0;  { Bias unit }
    For j:=1 to hid do
    begin
      sum := 0.0;
      For i:=0 to inp do sum := sum + Wji[j,i] * inpV[i];
      If sum<-88.0 Then
      If symmetry then hidV[j] := -1.0 else hidV[j] := 0.0 Else
      If symmetry then hidV[j] := 2.0 / (1.0 + exp(-sum)) - 1.0
                  else hidV[j] := 1.0 / (1.0 + exp(-sum))
    end;
    hidV[0] := 1.0;  { Bias unit }
    For k:=1 to out do
    begin
      sum := 0.0;
      For j:=0 to hid do sum := sum + Wkj[k,j] * hidV[j];
      If sum<-88.0 Then
      If symmetry then outV[k] := -1.0 else outV[k] := 0.0 Else
      If symmetry then outV[k] := 2.0 / (1.0 + exp(-sum)) - 1.0
                  else outV[k] := 1.0 / (1.0 + exp(-sum))
    end
  End
End;  { Propagate }
{----------------------- Backward Pass : Backpropagation ----------------------}
Procedure PerceptronBP;
Var deltaH : real;
     i,j,k : integer;
Begin
  For k:=1 to out do
  begin
    deltaH := (tarV[k] - outV[k]);
    If abs(deltaH) < tolerance then deltaH := 0.0;
    For j:=0 to inp do
    begin
      If batch1flag
      then mkj[k,j] := mkj[k,j] + eta * deltaH * inpV[j]
      else mkj[k,j] :=            eta * deltaH * inpV[j]
    end
  end;
  For j:=1 to inp do
    For i:=0 to inp do
      mji[j,i] := 0.0
End;

Procedure Backpropagate;
Var deltaO : outvector;
    deltaH : real;
     i,j,k : integer;
   sum,O,H : real;
Begin { Backpropagate }
  If learn then BPsteps := succ(BPsteps);
  If (mode=6) Then PerceptronBP Else
  Begin
    For k:=1 to out do
    begin
      O := outV[k];
      deltaH := (tarV[k] - O);
      If abs(deltaH) < tolerance then deltaH := 0.0;
      If hypererr then
      begin
        If symmetry then deltaH := 0.5 * deltaH;
        If abs(deltaH) > 0.9999999
        then deltaH := Sign(deltaH) * 17.0
        else deltaH := ln( (1.0+deltaH) / (1.0-deltaH) )
      end;
      If symmetry
      then deltaH := deltaH * (0.5 * (1-O*O) + errbias)
      else deltaH := deltaH * (  O * (1-O)   + errbias);
      deltaO[k] := deltaH;
      For j:=0 to hid do
      begin
        If batch1flag
        then mkj[k,j] := mkj[k,j] + deltaH * hidV[j]
        else mkj[k,j] :=            deltaH * hidV[j]
      end
    end;
    For j:=1 to hid do
    begin
      H := hidV[j];
      sum := 0.0;
      For k:=1 to out do sum := sum + deltaO[k] * Wkj[k,j];
      If symmetry
      then deltaH := sum * (0.5 * (1-H*H) + errbias)
      else deltaH := sum * (  H * (1-H)   + errbias);
      For i:=0 to inp do
      begin
        If batch1flag
        then mji[j,i] := mji[j,i] + deltaH * inpV[i]
        else mji[j,i] :=            deltaH * inpV[i]
      end
    end
  End
End;  { Backpropagate }
{------------------------------ Update Rules ----------------------------------}
Procedure Standard;
Var i,j,k : integer;
      lim : integer;
Begin { Standard }
  If not batch2flag
  then begin
    updates := succ(updates);
    globVAL := false
  end;
  If (mode=6) then lim := inp else lim := hid;  { Perceptron }
  For k:=1 to out do
  begin
    For j:=0 to lim do
    begin
      If batch2flag then bkj[k,j] := bkj[k,j] + eta * mkj[k,j] else
      begin
        dkj[k,j] := mom * dkj[k,j] + eta * mkj[k,j];
        Wkj[k,j] := Wkj[k,j] + dkj[k,j]
      end
    end
  end;
  If (mode<>6) then
  For j:=1 to hid do
  begin
    For i:=0 to inp do
    begin
      If batch2flag then bji[j,i] := bji[j,i] + eta * mji[j,i] else
      begin
        dji[j,i] := mom * dji[j,i] + eta * mji[j,i];
        Wji[j,i] := Wji[j,i] + dji[j,i]
      end
    end
  end
End;  { Standard }

Procedure schmidhu;
Var deltaO : real;
     i,j,k : integer;
     Ep,ny : real;
Begin { schmidhu }
  If not batch2flag
  then begin
    updates := succ(updates);
    globVAL := false
  end;
  Ep := 0.0;
  ny := 0.0;
  For k:=1 to out do
  begin
    deltaO := (tarV[k] - outV[k]);
    If abs(deltaO) < tolerance then deltaO := 0.0;
    Ep := Ep + sqr( deltaO );
    For j:=0 to hid do ny := ny + sqr( mkj[k,j] )
  end;
  For j:=1 to hid do 
    For i:=0 to inp do ny := ny + sqr( mji[j,i] );
  {  ny = Sum(i=1 to #weights) (dEp/dwi)^2  }
  {  Ep = Sum(k=1 to out) (t[k] - O[k])^2  } 
  If (ny <> 0.0) then
  begin
    Ep := 0.5 * Ep;
    {  Ep is defined as 1/2 * Sum(k=1 to out) (t[k] - O[k])^2  }
    ny := Ep / ny;
    If ny > maxstep then ny := maxstep;
    For k:=1 to out do
    For j:=0 to hid do
    If batch2flag then bkj[k,j] := bkj[k,j] + ny * mkj[k,j] else
    begin
      dkj[k,j] := ny * mkj[k,j];
      Wkj[k,j] := Wkj[k,j] + dkj[k,j]
    end;
    For j:=1 to hid do
    For i:=0 to inp do
    If batch2flag then bji[j,i] := bji[j,i] + ny * mji[j,i] else
    begin
      dji[j,i] := ny * mji[j,i];
      Wji[j,i] := Wji[j,i] + dji[j,i]
    end
  end
End;  { schmidhu }

Procedure ChanFallside;
Var i,j,k : integer;
     grad : real;
     delt : real;
     prod : real;
     lmbd : real;
 costheta : real;
Begin { ChanFallside }
  grad := 0.0;  { calculate the norm of the gradient vector, }
  delt := 0.0;  { of the previous update vector }
  prod := 0.0;  { and calculate the inner product between the two }
  For j:=1 to hid do
  begin
    For i:=0 to inp do
    begin
      grad := grad + sqr(mji[j,i]);
      delt := delt + sqr(dji[j,i]);
      prod := prod + mji[j,i] * dji[j,i]
    end
  end;
  For k:=1 to out do
  begin
    For j:=0 to hid do
    begin
      grad := grad + sqr(mkj[k,j]);
      delt := delt + sqr(dkj[k,j]);
      prod := prod + mkj[k,j] * dkj[k,j]
    end
  end;
  grad := sqrt(grad);
  delt := sqrt(delt);
  If (grad <> 0.0) and (delt <> 0.0) then
  Begin
    costheta := prod / ( grad * delt );
  { calculate cosine of angle theta between grad. and delta vect. }
    eta := eta * ( 1.0 + 0.5 * costheta );
    If eta < mineta then eta := mineta;
    If eta > maxeta then eta := maxeta;
    lmbd := lambda * grad / delt;
    mom := lmbd * eta
  End;
  Standard
End;  { ChanFallside }

Procedure Steffen;
Var i,j,k : integer;
     grad : real;
     delt : real;
     prod : real;
     lmbd : real;
 costheta : real;
   etasav : real;
   momsav : real;
Begin { Steffen }
  etasav := eta;  { save value of eta !! }
  momsav := mom;  { same for mom !! }
  grad := 0.0;  { calculate the norm of the gradient vector, }
  delt := 0.0;  { of the previous update vector }
  prod := 0.0;  { and calculate the inner product between the two }
  For j:=1 to hid do
  begin
    For i:=0 to inp do
    begin
      grad := grad + sqr(mji[j,i]);
      delt := delt + sqr(dji[j,i]);
      prod := prod + mji[j,i] * dji[j,i]
    end
  end;
  For k:=1 to out do
  begin
    For j:=0 to hid do
    begin
      grad := grad + sqr(mkj[k,j]);
      delt := delt + sqr(dkj[k,j]);
      prod := prod + mkj[k,j] * dkj[k,j]
    end
  end;
  grad := sqrt(grad);
  delt := sqrt(delt);
  If (grad <> 0.0) and (delt <> 0.0) then
  Begin
    costheta := prod / ( grad * delt );
  { calculate cosine of angle theta between grad. and delta vect. }
    eta := Smin + (Smax-Smin) * 0.5 * (1.0 + costheta);
    mom := momsav * eta * grad / delt
  End;
  Standard;
  eta := etasav;  { restore value of eta !! }
  mom := momsav   { same for mom !! }
End;  { Steffen }

Procedure QuickProp;  { Fahlman }
Var i,j,k : integer;
 nextstep : real;

Procedure QuickStep(Var W,d,m,r: real; n: integer);
{  W  =  Weights       }
{  d  =  DeltaWeights  }
{  m  =  Slopes        }
{  r  =  PrevSlopes    }
{  n  =  Nconnections  }
Begin
  nextstep := 0.0;
  If abs(d) > threshold  {  ModeSwitchThreshold  }
  Then Begin
    If d > 0.0
    Then Begin
      If m > 0.0 then
      begin
        If spliteta
        then nextstep := nextstep + eta * m / n
        else nextstep := nextstep + eta * m
      end;
      If m > shrinkfactor * r
      then nextstep := nextstep + maxfactor * d
      else nextstep := nextstep + ( m / ( r - m ) ) * d
    End
    Else Begin
      If m < 0.0 then
      begin
        If spliteta
        then nextstep := nextstep + eta * m / n
        else nextstep := nextstep + eta * m
      end;
      If m < shrinkfactor * r
      then nextstep := nextstep + maxfactor * d
      else nextstep := nextstep + ( m / ( r - m ) ) * d
    End
  End
  Else Begin {  abs( d ) <= threshold  }   {  grad.-descent  }
    If spliteta
    then nextstep := nextstep + mom * d + eta * m / n
    else nextstep := nextstep + mom * d + eta * m
  End
End;

Begin { QuickProp }
  updates := succ(updates);
  globVAL := false;
  For k:=1 to out do
  For j:=0 to hid do
  begin
    QuickStep( Wkj[k,j], dkj[k,j], mkj[k,j], rkj[k,j], succ(hid) );
    dkj[k,j] := nextstep;
    Wkj[k,j] := Wkj[k,j] + nextstep
  end;
  For j:=1 to hid do
  For i:=0 to inp do
  begin
    QuickStep( Wji[j,i], dji[j,i], mji[j,i], rji[j,i], succ(inp) );
    dji[j,i] := nextstep;
    Wji[j,i] := Wji[j,i] + nextstep
  end
End;  { QuickProp }

Procedure deltabar;  { Jacobs }
Var deltab : real;
     i,j,k : integer;
Begin { deltabar }
  If not batch2flag
  then begin
    updates := succ(updates);
    globVAL := false
  end;
  For k:=1 to out do
  begin
    For j:=0 to hid do
    begin
      deltab := rkj[k,j] * mkj[k,j];
      If (deltab <> 0.0) then
      begin
        If deltab > 0.0
        then ekj[k,j] := ekj[k,j] + Kappa
        else ekj[k,j] := ekj[k,j] * (1.0-Phi)
      end;
      rkj[k,j] := (1.0-Theta) * mkj[k,j] + Theta * rkj[k,j];
      If batch2flag then bkj[k,j] := bkj[k,j] + ekj[k,j] * mkj[k,j] else
      begin
        dkj[k,j] := mom * dkj[k,j] + ekj[k,j] * mkj[k,j];
        Wkj[k,j] := Wkj[k,j] + dkj[k,j]
      end
    end
  end;
  For j:=1 to hid do
  begin
    For i:=0 to inp do
    begin
      deltab := rji[j,i] * mji[j,i];
      If (deltab <> 0.0) then
      begin
        If deltab > 0.0
        then eji[j,i] := eji[j,i] + Kappa
        else eji[j,i] := eji[j,i] * (1.0-Phi)
      end;
      rji[j,i] := (1.0-Theta) * mji[j,i] + Theta * rji[j,i];
      If batch2flag then bji[j,i] := bji[j,i] + eji[j,i] * mji[j,i] else
      begin
        dji[j,i] := mom * dji[j,i] + eji[j,i] * mji[j,i];
        Wji[j,i] := Wji[j,i] + dji[j,i]
      end
    end
  end
End;  { deltabar }

Procedure Almeida;
Var deltab : real;
     i,j,k : integer;
Begin { Almeida }
  If not batch2flag
  then begin
    updates := succ(updates);
    globVAL := false
  end;
  For k:=1 to out do
  begin
    For j:=0 to hid do
    begin
      deltab := rkj[k,j] * mkj[k,j];
      If (deltab <> 0.0) then
      begin
        If deltab > 0.0
        then ekj[k,j] := u * ekj[k,j]
        else ekj[k,j] := d * ekj[k,j]
      end;
      rkj[k,j] := mkj[k,j];
      If batch2flag then bkj[k,j] := bkj[k,j] + ekj[k,j] * mkj[k,j] else
      begin
        dkj[k,j] := mom * dkj[k,j] + ekj[k,j] * mkj[k,j];
        Wkj[k,j] := Wkj[k,j] + dkj[k,j]
      end
    end
  end;
  For j:=1 to hid do
  begin
    For i:=0 to inp do
    begin
      deltab := rji[j,i] * mji[j,i];
      If (deltab <> 0.0) then
      begin
        If deltab > 0.0
        then eji[j,i] := u * eji[j,i]
        else eji[j,i] := d * eji[j,i]
      end;
      rji[j,i] := mji[j,i];
      If batch2flag then bji[j,i] := bji[j,i] + eji[j,i] * mji[j,i] else
      begin
        dji[j,i] := mom * dji[j,i] + eji[j,i] * mji[j,i];
        Wji[j,i] := Wji[j,i] + dji[j,i]
      end
    end
  end
End;  { Almeida }
{--------------------------- Cancel Learning Step -----------------------------}
Procedure CancelStep;
Var i,j,k : integer;
Begin
  globVAL := false;
  For k:=1 to out do
  For j:=0 to hid do
  begin
    Wkj[k,j] := Wkj[k,j] - dkj[k,j];
    dkj[k,j] := 0.0
  end;
  For j:=1 to hid do
  For i:=0 to inp do
  begin
    Wji[j,i] := Wji[j,i] - dji[j,i];
    dji[j,i] := 0.0
  end
End;
{-------------------------- Composite Update Rules ----------------------------}
Procedure Batch1Step;
Begin
  Case mode of
    0: Standard;
    1: schmidhu;   { Schmidhuber }
    2: ChanFallside;
    3: QuickProp;  { Fahlman }
    4: deltabar;   { Jacobs }
    5: Almeida;
    6: Standard;   { Perceptron }
    7: Steffen;
  End
End;  { Batch1Step }

Procedure Batch2Step;
Var i,j,k : integer;
Begin { Batch2Step }
  updates := succ(updates);
  globVAL := false;
  For k:=1 to out do
  For j:=0 to hid do
  begin
    dkj[k,j] := mom * dkj[k,j] + bkj[k,j];
    Wkj[k,j] := Wkj[k,j] + dkj[k,j]
  end;
  For j:=1 to hid do
  For i:=0 to inp do
  begin
    dji[j,i] := mom * dji[j,i] + bji[j,i];
    Wji[j,i] := Wji[j,i] + dji[j,i]
  end
End;  { Batch2Step }

Procedure BackProp;  { Backward Pass & Update together }
Begin
  Backpropagate;
  Case mode of
    0: Standard;
    1: schmidhu;   { Schmidhuber }
    2: ChanFallside;
    3: Standard;   { only QuickProp in Batch1-mode! }
    4: deltabar;   { Jacobs }
    5: Almeida;
    6: Standard;   { Perceptron }
    7: Steffen;
  End
End;
{---------------------------- BP Initializations ------------------------------}
Procedure InitDelta;
Var i,j,k : integer;
Begin { InitDelta }
  For j:=0 to hid do
  Begin
    For i:=0 to inp do dji[j,i] := 0.0;
    For k:=0 to out do dkj[k,j] := 0.0
  End
End;  { InitDelta }

Procedure InitQuickProp;
Var i,j,k : integer;
Begin
  shrinkfactor := maxfactor / ( 1.0 + maxfactor );
  For j:=0 to hid do
  Begin
    For i:=0 to inp do mji[j,i] := 0.0;
    For k:=0 to out do mkj[k,j] := 0.0
  End
End;

Procedure QuickUpdate;
Var i,j,k : integer;
Begin
  For j:=0 to hid do
  Begin
    For i:=0 to inp do
    begin rji[j,i] := mji[j,i]; mji[j,i] := -decay * Wji[j,i] end;
    For k:=0 to out do
    begin rkj[k,j] := mkj[k,j]; mkj[k,j] := -decay * Wkj[k,j] end
  End
End;

Procedure Initdeltabar;
Var i,j,k : integer;
Begin
  For j:=0 to hid do
  Begin
    For i:=0 to inp do begin eji[j,i] := eta; rji[j,i] := 0 end;
    For k:=0 to out do begin ekj[k,j] := eta; rkj[k,j] := 0 end
  End
End;

Procedure InitBatch1;  { used before EACH epoch in batch1 learning }
Var i,j,k : integer;
Begin
  If (mode=3) Then QuickUpdate Else
  For j := 0 to hid do
  begin
    For k := 0 to out do mkj[k,j] := 0.0;
    For i := 0 to inp do mji[j,i] := 0.0
  end
End;

Procedure InitBatch2;  { used before EACH epoch in batch2 learning }
Var i,j,k : integer;
Begin
  For j := 0 to hid do
  begin
    For k := 0 to out do bkj[k,j] := 0.0;
    For i := 0 to inp do bji[j,i] := 0.0
  end
End;

Procedure InitBackProp;  { used ONCE in all routines before learning starts }
Var k : integer;
Begin
  InitDelta;
  Case mode of
    0: ;           { Standard }
    1: ;           { Schmidhuber }
    2: ;           { ChanFallside }
    3: InitQuickProp;  { Fahlman }
    4: Initdeltabar;   { Jacobs }
    5: Initdeltabar;   { Almeida }
    6: For k:=0 to hid do hidV[k]:=0.0; { Perceptron }
    7:             { Steffen }
  End
End;
{--------------------------- Pattern Fetch Routine ----------------------------}
Procedure Fetch(p : Zeiger);
Var k : integer;
Begin
  If learn then begin p^.Count := succ(p^.Count); cycles := succ(cycles) end;
  For k:=1 to inp do inpV[k] := p^.Input[k];
  For k:=1 to out do tarV[k] := p^.Target[k];
  Propagate
End;
{---------------------------- BP Error Measures -------------------------------}
Function localerr : real;
Var k : integer;
  pnt : integer;
  min : real;
  max : real;
  tpnt : integer;
  tmin : real;
  tmax : real;
  diff : real;
 tdiff : real;

Begin
  diff := 0.0;
  If unique then
  begin
    min := outV[1];
    max := min;
    pnt := 1;
    tmin := tarV[1];
    tmax := tmin;
    tpnt := 1;
    for k := 2 to out do
    begin  { determine min,max of target and output vectors }
      If outV[k] < min then min := outV[k];
      If outV[k] > max then
      begin max := outV[k]; pnt := k end;
      If tarV[k] < tmin then tmin := tarV[k];
      If tarV[k] > tmax then
      begin tmax := tarV[k]; tpnt := k end
    end;
    tdiff := tmax - tmin;
    If tdiff <= 0.0 Then tdiff := 1.0; { prevent division by 0 error }
    diff := min;  { look for next smaller element after the maximum }
    for k:=1 to out do If (k<>pnt) and (outV[k]>diff) then diff:=outV[k];
    diff := max - diff;
    { difference between maximum and next smaller element }
    If (diff <= 0.0) then diff := 1.0  { maximum is not unique! }
    else begin
      diff := (tdiff - diff) / tdiff;
      If diff < 0.0 then diff := 0.0; { If (diff > tdiff) ! }
      If pnt <> tpnt then diff := diff + 1.0
      { penalty for wrong classification }
    end
  end;
  localsum := 0.0;
  For k := 1 to out do localsum := localsum + sqr(tarV[k] - outV[k]);
  localRMS := localsum;
  If (out<>0) then localRMS := localRMS / out;
  If symmetry then localRMS := localRMS * 0.25;
  localerr := sqrt(localRMS) + diff
End;

Function globalerr(update: boolean) : real;
Var p : Zeiger;
    k : integer;
  err : real;

Begin
  If globVAL and not update then globalerr := globERR
  else begin
    globLMS := 0.0;
    globRMS := 0.0;
    globMAX := 0.0;
    weightsum := 0.0;
    patterns := 0;
    p := Root;
    While p<>nil do
    begin
      patterns := succ(patterns);
      Fetch(p);
      err := localerr;
      globLMS := globLMS + localsum;
      globRMS := globRMS + localRMS;
      If err > globMAX then globMAX := err;
      If update then p^.Weight := err;
      weightsum := weightsum + p^.Weight;
      p := p^.Next
    end;
    globLMS := globLMS * 0.5; { = error on which partial derivatives are based }
    If (patterns <> 0) then globRMS := globRMS / patterns;
    globRMS := sqrt(globRMS);
    If MAXnorm
    then globERR := globMAX
    else globERR := globRMS;
    If not bestVAL then
    begin
      bestERR := globERR;
      bestVAL := true
    end;
    If not oldVAL then
    begin
      oldERR := globERR;
      oldVAL := true
    end;
    globVAL := true;
    globalerr := globERR
  end
End;
{------------------------------------------------------------------------------}
                           { Graphics Utilities }
{------------------------------------------------------------------------------}
Procedure HGR;
Var i,j : integer;
Begin
  Clear_Screen;
  Clear_Dialog;
  Move(0,0);
  Draw(0,ymax);
  Move(0,0);
  Draw(xmax,0);
  For i := 0 to 3 do
  begin
    j := Round( i / 3.0 * ymax );
    Move(0,j);
    Draw(16,j)
  end;
  i := 0;
  While i<=500 do
  begin
    Move(i*8,0);
    Draw(i*8,8);
    i := i + 10
  end;
  Xcount := 1
End;

Procedure GraphicsON;
Begin
  break := ' ';
  If enable then
  begin
    Code(0); { TEK }
    Clear_Screen;
    Clear_Dialog;
    Xcount := 0
  end
End;

Procedure GraphicsOFF;
Begin
  learn := false;
  If enable then
  begin
    Clear_Dialog;
    Reset(Input);
    Read(break);
    Reset(Input);
    UpperCase(break);
    Clear_Screen;
    Clear_Dialog;
    Code(2) { EDIT }
  end
End;

Procedure PlotError;
Var x : real;
    y : integer;
Begin
  If enable then
  begin
    If (Xcount<=0) or (Xcount>500) then
    begin
      If (Xcount>500) then
      begin Clear_Dialog; Continue end;
      HGR
    end;
    x := globalerr(false) / 3.0;
    y := Round( x * ymax );
    If (Xcount<512) and (y<ylim) Then
    begin Move(Xcount*8,y); Draw(Xcount*8,y) end;
    Xcount := succ(Xcount)
  end
End;
{------------------------------------------------------------------------------}
                               { Utilities }
{------------------------------------------------------------------------------}
Procedure ClearCount;  { clears each pattern's fetch counter }
Var p : Zeiger;
Begin
  p := Root;
  While p <> nil do
  begin
    p^.Count := 0;
    p := p^.Next
  end
End;

Procedure ClearCounters;  { clear all complexity measure counters }
Begin
  ClearCount;
  Psteps := 0;
  BPsteps := 0;
  updates := 0;
  cycles := 0;
  epochs := 0;
  oldERR := 0.0;
  oldVAL := false;
  globERR := 0.0;
  globLMS := 0.0;
  globRMS := 0.0;
  globMAX := 0.0;
  globVAL := false;
  bestERR := 0.0;
  bestVAL := false
End;

Procedure ReleaseHeap;
Var p,q : Zeiger;
Begin
  p := Root;
  while p<>nil do
  begin
    q := p^.next;
    dispose(p);
    p := q
  end;
  Root := nil;
  weightsum := 0.0;
  patterns := 0;
  dataflag := none;
  oldERR := 0.0;
  oldVAL := false;
  globERR := 0.0;
  globLMS := 0.0;
  globRMS := 0.0;
  globMAX := 0.0;
  globVAL := false;
  bestERR := 0.0;
  bestVAL := false
End;

Procedure NextReal;
Var i,j : integer;
   Buf2 : long;

Function Scan1 : Boolean;
Begin
  If (i<=Length(Buf))
  then Scan1 := not(Buf[i] in ['+','-','0'..'9'])
  else Scan1 := false
End;
Function Scan2 : Boolean;
Begin
  If (j<=Length(Buf))
  then Scan2 := (Buf[j] in ['+','-','.','0'..'9'])
  else Scan2 := false
End;

Begin { NextReal }
  Result := 0.0;
  i := 1;
  j := 1;
  Repeat
    While (Length(Buf)=0) and not EOF(IOfile) do ReadLn(IOfile,Buf);
    If (Length(Buf)<>0) then
    Begin
      i := 1;
      While Scan1 do i := succ(i);
      j := i;
      While Scan2 do j := succ(j);
      If (i>Length(Buf)) then Buf := ''
    End
  Until (i<j) or EOF(IOfile);
  If (i<j) then
  begin
    Buf2 := substr(Buf,i,j-i);
    Buf := substr(Buf,j,succ(Length(Buf)-j));
    ReadV(Buf2,Result)
  end
End;  { NextReal }

Procedure ReadTag;
Var i,j : Integer;

Function ScanX : Boolean;
Begin
  If (i<=Length(Buf))
  Then ScanX := (Buf[i]=' ')
  Else ScanX := false
End;
Function ScanY : Boolean;
Begin
  If (j<=Length(Buf)) and (j-i<stringlength)
  Then ScanY := Buf[j] <> ' '
  Else ScanY := false
End;

Begin { ReadTag }
  Tag := '';
  i := 1;
  j := 1;
  Repeat
    While (Length(Buf)=0) and not EOF(IOfile) do ReadLn(IOfile,Buf);
    If (Length(Buf)<>0) then
    Begin
      i := 1;
      While ScanX do i := succ(i);
      j := i;
      While ScanY do j := succ(j);
      If (i>Length(Buf)) then Buf := ''
    End
  Until (i<j) or EOF(IOfile);
  If (i<j) then
  begin
    Tag := substr(Buf,i,j-i);
    Buf := substr(Buf,j,succ(Length(Buf)-j))
  end
End;  { ReadTag }

Procedure GetName(N : integer);
Var i,j,k : integer;
Function Ok : boolean;
Begin
  If j>Length(IOname)
  then Ok := false
  else Ok := (IOname[j]='-')
End;
Begin
Repeat
  WriteLn;
  Write('Please enter name of ',filetype[N],' file (default=',default[N],'): ');
  ReadLn(IOname); GetRandom; WriteLn;
  If IOname = ''
  Then IOname := default[N]
  Else begin
    i := Index(IOname,'*');
    If i>0 then
    begin
      j := succ(i);
      While Ok do j := succ(j);
      j := j - succ(i);
      k := Length(default[N]);
      If k > j
      Then IOname := substr(IOname,1,pred(i))
                   + substr(default[N],1,k-j)
                   + substr(IOname,succ(i+j),Length(IOname)-(i+j))
      Else IOname := substr(IOname,1,pred(i))
                   + substr(IOname,succ(i+j),Length(IOname)-(i+j))
    end;
    If Index(IOname,'.')=0 Then IOname := IOname + suffix[N];
  end;
  Repeat
    WriteLn;
    Write('Is ''',IOname,''' correct? (yes/no) ');
    ReadLn(c);
    GetRandom;
    WriteLn;
    UpperCase(c)
  Until c in ['Y','J','N']
Until c in ['Y','J'];
default[N] := IOname
End;
{------------------------------------------------------------------------------}
                            { Output Utilities }
{------------------------------------------------------------------------------}
Procedure Print(S : long);
Begin
  Case IOselect of
    screen: Write(S); 
    file1:  Write(IOfile,S);
    file2:  Write(Logfile,S)
  End
End;

Procedure PrintLn(S : long);
Begin
  Case IOselect of
    screen: WriteLn(S); 
    file1:  WriteLn(IOfile,S);
    file2:  WriteLn(Logfile,S)
  End
End;

Procedure Define_filename_defaults;
Begin
  learntype[0] := 'sequential';
  learntype[1] := 'periodical';
  learntype[2] := 'batch1';
  learntype[3] := 'batch2';
  learntype[4] := 'dynamic';
  learntype[5] := 'dynamic batch1';
  learntype[6] := 'dynamic batch2';
  filetype[0] := 'matrix';
  filetype[1] := 'matrix';
  filetype[2] := 'data';
  filetype[3] := 'output';
  filetype[4] := 'display';
  filetype[5] := 'matrix';
  filetype[6] := 'log';
  filetype[7] := 'default identifier for a';
  suffix[0] := '.MAT';  { for input }
  suffix[1] := '.MAT';  { for output }
  suffix[2] := '.DATA';
  suffix[3] := '.LST';
  suffix[4] := '';      { for 'type <file>' main menu option }
  suffix[5] := '.MAT';  { for best matrix save option }
  suffix[6] := '.LOG';
  suffix[7] := '';
  WriteV(NI,inp:1);
  WriteV(NH,hid:1);
  WriteV(NO,out:1);
  If symmetry then Name := 'BPS_' else Name := 'BP_';
  default[2] := Name + NI + '_' + NO + suffix[2];
  Name := Name + NI + '_' + NH + '_' + NO;
  WriteLn;
  Repeat
    default[7] := Name;
    GetName(7)
  Until Index(default[7],'.') = 0;
  default[0] := default[7] + suffix[0];
  default[1] := default[7] + suffix[1];
  If default[7] <> Name then
  default[2] := default[7] + suffix[2];
  default[3] := default[7] + suffix[3];
  default[4] := '';
  default[5] := default[7] + suffix[5];
  default[6] := default[7] + suffix[6];
  IOname := ''
End;

Procedure ModeNames(modus : integer);
Begin
  Case modus of
    0: Tag := 'Standard';
    1: Tag := 'Schmidhubers Zero-Point-Search';
    2: Tag := 'ChanFallside (autom. eta/mom)';
    3: Tag := 'Fahlmans QuickProp';
    4: Tag := 'Jacobs delta-bar-delta-rule';
    5: Tag := 'Almeidas adaptive BP';
    6: Tag := 'Perceptron';
    7: Tag := 'Steffen''s autom. eta/mom';
  End
End;

Procedure WriteMode(N : integer);
Begin
  If (Mode<>3) or (N=2) or (N=5)  { QuickProp only in Batch1 mode ! }
  then ModeNames(Mode)
  else ModeNames(0);
  WriteLn;
  WriteLn('Using ',Tag,' update rule.')
End;

Procedure ParamDisplay;
Begin
      PrintLn('');
      PrintLn('');
      PrintLn(
'                  --- Simulation Parameters ---');
      PrintLn('');
      WriteV(display,
'              (I) [I]nitialization range          = ', range:12:7);
      PrintLn(display);
      WriteV(display,
'              (E) [E]ta (learning rate)           = ',   eta:12:7);
      PrintLn(display);
      WriteV(display,
'              (M) [M]omentum term                 = ',   mom:12:7);
      PrintLn(display);
      Print(
'              (R) [R]oot Mean Squares/MAXimum norm error:    ');
      If MAXnorm then PrintLn('MAX') else PrintLn('RMS');
      Print(
'              (H) [H]yperbolic (atanh) error function:       ');
      If hypererr then PrintLn(' ON') else PrintLn('OFF');
      Print(
'              (S) [S]everal output activations penalty term: ');
      If unique then PrintLn(' ON') else PrintLn('OFF');
      WriteV(display,
'              (Z) [Z]ero error if | (tar - out) | < ',tolerance:12:7);
      PrintLn(display);
      WriteV(display,
'              (B) [B]ias error ( O * (1-O) + ... ): ',errbias:12:7);
      PrintLn(display);
      WriteV(display,
'              (A) [A]bsolute error limit          = ',abserr:12:7);
      PrintLn(display);
      WriteV(display,
'              (P) [P]attern error limit           = ',patterr:12:7);
      PrintLn(display);
      Print(
'              (C) [C]ancel learn steps that increased error: ');
      If Cancel then PrintLn(' ON') else PrintLn('OFF');
      WriteV(display,
'              (F) [F]actor for pattern repetition = ',RF:4);PrintLn(display);
      Print(
'              (T) [T]oggle epochs/cycles below:           ');
      If Toggle then PrintLn('CYCLES') else PrintLn('EPOCHS');
      WriteV(display,
'              (U) [U]pdate pattern weights every  = ',UF:4,'  ');
      Print(display);
      If Toggle then PrintLn('cycles') else PrintLn('epochs');
      ModeNames(mode);
      PrintLn(
'              (X) e[X]tra update (learn) rules: '+Tag);
      PrintLn('');
      Print(
'              (O) [O]ption: save best matrix automatically   ');
      If SaveOpt then PrintLn(' ON') else PrintLn('OFF');
      Print(
'              (K) [K]eep a copy of best matrix found         ');
      If KeepOpt then PrintLn(' ON') else PrintLn('OFF');
      PrintLn('');
      PrintLn(
'              (Q) [Q]uit');
      PrintLn('');
End;
Procedure Param1Display;
Begin
      PrintLn('');
      PrintLn(
'              --- Schmidhubers algorithm parameters ---');
      PrintLn('');
      WriteV(display,
'              (M) [M]aximum step size         = ', maxstep:9:4);
      PrintLn(display);
      PrintLn(
'              (Q) [Q]uit');
      PrintLn('');
End;
Procedure Param2Display;
Begin
      PrintLn('');
      PrintLn(
'              --- Chan & Fallside''s automatic choice of eta & mom ---');
      PrintLn('');
      WriteV(display,
'              (N) mi[N]imum for eta (learning rate)   = ',mineta:12:7);
      PrintLn(display);
      WriteV(display,
'              (X) ma[X]imum for eta (learning rate)   = ',maxeta:12:7);
      PrintLn(display);
      WriteV(display,
'              (L) [L]ambda (for momentum calculation) = ',lambda:12:7);
      PrintLn(display);
      PrintLn(
'              (D) [D]efault values for learning rate and momentum:');
      PrintLn(
'                          eta ->    0.5       mom ->    0.9');
      WriteV(display,
'                         (eta  = ',eta:9:4,'    mom  = ',mom:9:4,')');
      PrintLn(display);
      PrintLn(
'              (Q) [Q]uit');
      PrintLn('');
End;
Procedure Param3Display;
Begin
      PrintLn('');
      PrintLn(
'***** Only in conjunction with batch learning (main menu option [V])!! *****'+
      chr(7));
      PrintLn('');
      PrintLn(
'                  --- QuickProp parameters ---');
      PrintLn('');
      Print(
'              (H) [H]yperbolic (atanh) error function:           ');
      If hypererr then PrintLn(' ON') else PrintLn('OFF');
      Print(
'              (S) [S]plit learn rate ("split eta"):              ');
      If spliteta then PrintLn(' ON') else PrintLn('OFF');
      WriteV(display,
'              (T) [T]hreshold (below:descent/above:jump) = ', threshold:9:4);
      PrintLn(display);
      WriteV(display,
'              (M) [M]aximum step factor                  = ', maxfactor:9:4);
      PrintLn(display);
      WriteV(display,
'              (D) weight [D]ecay factor                  = ', decay:12:7);
      PrintLn(display);
      PrintLn(
'              (Q) [Q]uit');
      PrintLn('');
End;
Procedure Param4Display;
Begin
      PrintLn('');
      PrintLn(
'          --- delta-bar-delta rule parameters ---');
      PrintLn('');
      WriteV(display,
'              (T) [T]heta         = ', Theta:9:4);PrintLn(display);
      WriteV(display,
'              (K) [K]appa         = ', Kappa:9:4);PrintLn(display);
      WriteV(display,
'              (P) [P]hi           = ',   Phi:9:4);PrintLn(display);
      PrintLn(
'              (Q) [Q]uit');
      PrintLn('');
End;
Procedure Param5Display;
Begin
      PrintLn('');
      PrintLn(
'          --- Almeidas adaptive algorithm parameters ---');
      PrintLn('');
      WriteV(display,
'              (U) [U]p factor            = ', u:9:4);PrintLn(display);
      WriteV(display,
'              (D) [D]own factor          = ', d:9:4);PrintLn(display);
      PrintLn(
'              (Q) [Q]uit');
      PrintLn('');
End;
Procedure Param7Display;
Begin
      PrintLn('');
      PrintLn(
'              --- Steffen''s automatic choice of eta & mom ---');
      PrintLn('');
      WriteV(display,
'              (N) mi[N]imum for eta (learning rate)   = ',Smin:12:7);
      PrintLn(display);
      WriteV(display,
'              (X) ma[X]imum for eta (learning rate)   = ',Smax:12:7);
      PrintLn(display);
      PrintLn(
'              (Q) [Q]uit');
      PrintLn('');
End;
Procedure InfoDisplay;
Var error : real;
Begin
  error := globalerr(true);
  PrintLn('');
  PrintLn('');
  PrintLn('--- Backpropagation Networks Simulator Status Information ---');
  PrintLn('');
  WriteV(display,inp:8,'  input units');PrintLn(display);
  WriteV(display,hid:8,' hidden units');PrintLn(display);
  WriteV(display,out:8,' output units');PrintLn(display);
  PrintLn('');
  If symmetry
  then PrintLn('SYMMETRIC logistic function    (range [-1, 1])')
  else PrintLn('standard logistic function     (range [ 0, 1])');
  PrintLn('');
  WriteV(display,patterns:8,' patterns of ',dataflag,' data in buffer');
      PrintLn(display);
  PrintLn('');
  WriteV(display,'    LMS error : ',globLMS:12:7);Print(display);
  WriteV(display,'          RMS error : ',globRMS:12:7);Print(display);
  If not MAXnorm then Print('   <<<');
  PrintLn('');
  WriteV(display,'    weightsum : ',weightsum:12:7);Print(display);
  WriteV(display,'      maximum error : ',  globMAX:12:7);Print(display);
  If MAXnorm then Print('   <<<');
  PrintLn('');
  WriteV(display,'   best error : ',  bestERR:12:7);PrintLn(display);
  PrintLn('');
  WriteV(display,cycles:8,' pattern fetch cycles');PrintLn(display);
  WriteV(display,epochs:8,' epochs of learning');PrintLn(display);
  WriteV(display,Psteps:8,' propagation routine calls');PrintLn(display);
  WriteV(display,BPsteps:8,' backpropagation routine calls');PrintLn(display);
  WriteV(display,updates:8,' weight matrix updates');PrintLn(display);
  PrintLn('');
  PrintLn('last filename used: '''+IOname+'''');
End;

Procedure WriteParms;
Begin
  IOselect := file2;
  ParamDisplay;
  Case mode of
    1: Param1Display;
    2: Param2Display;
    3: Param3Display;
    4: Param4Display;
    5: Param5Display;
    7: Param7Display
  End;
  InfoDisplay;
  IOselect := screen
End;

Procedure SaveM;
Var i,j,k : integer;
        f : boolean;
Begin
  for i:=0 to inp do
  begin
    WriteV(display,'<',i:3,'>'); Print(display);
    k := 0;
    for j:=1 to hid do
    begin
      WriteV(display,'  ',Wji[j,i]:11:7); Print(display);
      k := succ(k);
      f := (j=hid);
      if (k>4) or f then
      begin
        k:=0;
        PrintLn('');
        if not f then Print('     ')
      end
    end
  end;
  for i:=0 to hid do
  begin
    WriteV(display,'<',i:3,'>'); Print(display);
    k := 0;
    for j:=1 to out do
    begin
      WriteV(display,'  ',Wkj[j,i]:11:7); Print(display);
      k := succ(k);
      f := (j=out);
      if (k>4) or f then
      begin
        k:=0;
        PrintLn('');
        if not f then Print('     ')
      end
    end
  end;
  PrintLn('');
  WriteV(display,cycles); PrintLn(display);
  WriteV(display,epochs); PrintLn(display);
  WriteV(display,Psteps); PrintLn(display);
  WriteV(display,BPsteps); PrintLn(display);
  WriteV(display,updates); PrintLn(display);
  PrintLn('');
  InfoDisplay;
  IOselect := screen
End;

Procedure OpenLog(N : integer);
Var k : integer;
Begin
  If not Logactive then
  begin
    If (Logcount > 0) Then
    Begin
      Logname := default[6];
      k := Index(Logname,'.');
      If k <> 0 Then Logname := Substr(Logname,1,pred(k));
      WriteV(display,Logcount:1);
      Logname := Logname + display + '.LOG'
    End;
    Open(Logfile,Logname,history := new,sharing := readwrite);
    Rewrite(Logfile);
    Logactive := true
  end;
  WriteParms;
  WriteLn(Logfile);
  WriteLn(Logfile,learntype[N],' learning.');
  Writeln(Logfile);
  IOselect := screen
End;

Procedure CloseLog;
Begin
  If Logactive then
  begin
    IOselect := file2;
    SaveM;
    Close(Logfile);
    Logactive := false;
    Logcount := succ(Logcount)
  end;
  IOselect := screen
End;

Procedure OpenLearnMode(N : integer);
Begin
  WriteLn;
  WriteLn('Performing ',learntype[N],' learning...');
  WriteMode(N);
  OpenLog(N);
  learn := true;
  InitBackProp;
  stop := false;
  oldVAL := false;
  GraphicsON
End;

Procedure SaveMatrix;
Begin { SaveMatrix }
  Open(IOfile,IOname+'Q',history := unknown,disposition := delete);
  Close(IOfile,disposition := delete);
  Open(IOfile,IOname+'Q',new);
  Rewrite(IOfile);
  IOselect := file1;
  SaveM;
  Close(IOfile);
  Open(IOfile,IOname,history := unknown,disposition := delete);
  Close(IOfile,disposition := delete);
  Open(IOfile,IOname,new);
  Rewrite(IOfile);
  IOselect := file1;
  SaveM;
  Close(IOfile)
End;  { SaveMatrix }

Procedure GetBestMatrixName;
Begin
  If SaveOpt then
  begin
    WriteLn;
    WriteLn('Best matrix save option:');
    GetName(5)
  end
End;

Procedure SaveBestMatrix;
Var i,j,k : integer;
Begin
  If SaveOpt then SaveMatrix;
  If KeepOpt then
  begin
    For j:=0 to hid do
    begin
      For i:=0 to inp do Sji[j,i] := Wji[j,i];
      For k:=0 to out do Skj[k,j] := Wkj[k,j]
    end;
    Scycles  := cycles;
    Sepochs  := epochs;
    SPsteps  := Psteps;
    SBPsteps := BPsteps;
    Supdates := updates;
    KeepVAL := true
  end
End;

Procedure Putout(var l : integer; x : real);
Var S : String;
Begin
  If l > 70 then
  begin
    l := 0;
    WriteLn(IOfile)
  end;
  While (l<5) do
  begin
    l := succ(l);
    Write(IOfile,' ')
  end;
  WriteV(S,x:5:2);
  Write(IOfile,S);
  l := l + Length(S);
  If l > 70
  then begin
    l := 0;
    WriteLn(IOfile)
  end
  else begin
    l := l + 2;
    Write(IOfile,'  ')
  end
End;
{----------------------------- BP Stopping Rule -------------------------------}
Procedure TestStop(update : boolean);
Var error, err : real;
Begin
  epochs := succ(epochs);
  error := globalerr(update);
  If Logactive then Writeln(Logfile,'@ ',error:9:7);
  PlotError;
  worse := false;
  If oldVAL then worse := (error > oldERR);
  If not (Cancel and worse) Then
  begin
    oldERR := error;
    oldVAL := true
  end;
  If (error < bestERR) then
  begin
    bestERR := error;
    bestVAL := true;
    SaveBestMatrix
  end;
  If (error < abserr) then
  begin
    stop := true;
    If enable then Clear_Dialog else WriteLn;
    WriteLn('Global error went below ABSOLUTE error limit!',chr(7));
    Continue
  end
End;
{------------------------------------------------------------------------------}
                          { Initialization Routines }
{------------------------------------------------------------------------------}
Procedure InitSave;
Var i,j,k : integer;
Begin
  For j:=0 to hid do
  begin
    For i:=0 to inp do Sji[j,i] := 0;
    For k:=0 to out do Skj[k,j] := 0
  end;
  Scycles  := 0;
  Sepochs  := 0;
  SPsteps  := 0;
  SBPsteps := 0;
  Supdates := 0;
  KeepVAL := false
End;

Procedure InitAll;
Var i,j,k : integer;
Begin { InitAll }
  For j:=0 to maxhid do
  Begin
    For i:=0 to maxinp do
    begin
      Wji[j,i] := 0.0;
      dji[j,i] := 0.0;
      mji[j,i] := 0.0;
      rji[j,i] := 0.0;
      bji[j,i] := 0.0;
      eji[j,i] := 0.0
    end;
    For k:=0 to maxout do
    begin
      Wkj[k,j] := 0.0;
      dkj[k,j] := 0.0;
      mkj[k,j] := 0.0;
      rkj[k,j] := 0.0;
      bkj[k,j] := 0.0;
      ekj[k,j] := 0.0
    end
  End;
  For i := 0 to maxinp do inpV[i] := 0.0;
  For j := 0 to maxhid do hidV[j] := 0.0;
  For k := 0 to maxout do begin outV[k] := 0.0; tarV[k] := 0.0 end;
  ClearCounters
End;  { InitAll }

Procedure InitRand;
Var i,j,k : integer;
Begin
  ClearCounters;
  Randomize;
  For j:=0 to hid do
  Begin
    For i:=0 to inp do Wji[j,i] := Random(-range,range);
    For k:=0 to out do Wkj[k,j] := Random(-range,range)
  End
End;

Procedure Initialize;
Begin
  WriteLn;
  WriteLn('Initializing...');

  Logactive := false;
  Logcount := 0;
  IOselect := screen;
  mode := 0;
  range := 0.2;
  eta := 0.5;
  mom := 0.9;
  lambda := 0.9;
  mineta := 0.0001;
  maxeta := 20.0;
  Smin := 0.0025;
  Smax := 0.5;
  Theta := 0.7;
  Kappa := 0.05;
  Phi := 0.1;
  u := 1.2;
  d := 0.7;
  hypererr := false;
  spliteta := false;
  threshold := 0.0;
  maxfactor := 1.75;
  decay := 0.0001;
  MAXnorm := true;
  abserr := 0.002;
  patterr:= 0.002;
  RF := 1;
  UF := 1;
  batch1flag := false;
  batch2flag := false;
  Toggle := false;
  Cancel := false;
  worse := false;
  SaveOpt := false;
  KeepOpt := true;
  KeepVAL := false;
  learn := false;
  unique := true;
  tolerance := 0.0;
  errbias := 0.0;
  oldERR := 0.0;
  oldVAL := false;
  globERR := 0.0;
  globLMS := 0.0;
  globRMS := 0.0;
  globMAX := 0.0;
  globVAL := false;
  bestERR := 0.0;
  bestVAL := false;
  maxstep := 20.0;

  If firstrun
  then begin
    Root := nil;   { Initialize pointer list, very important !! }
    ReleaseHeap
  end
  else begin
    WriteLn;
    WriteLn('Warning: Pattern buffer for learning not cleared!',chr(7));
    WriteLn('Still ',patterns:1,' patterns contained in buffer.');
    WriteLn('Data status: ',dataflag);
    Continue
  end;

  CloseLog;
  InitAll;
  InitSave;
  InitRand

End;
{------------------------------------------------------------------------------}
                           { Main Menu Items }
{------------------------------------------------------------------------------}
Procedure ClearBuffer;
Begin
  ReleaseHeap;
  WriteLn;
  WriteLn('Buffer (for learning patterns) cleared.');
  Wait
End;

Procedure ReadData;
Var i,j,k : integer;
      p,q : Zeiger;
 dataconv : boolean;

Begin { ReadData }
  weightsum := 0.0;
  patterns := 0;
  oldERR := 0.0;
  oldVAL := false;
  globERR := 0.0;
  globLMS := 0.0;
  globRMS := 0.0;
  globMAX := 0.0;
  globVAL := false;
  bestERR := 0.0;
  bestVAL := false;
  p := Root;   { If a list already exists, go to its end: }
  q := nil;
  While p<>nil do
  begin
    weightsum := weightsum + p^.Weight;
    patterns := succ(patterns);
    q := p;
    p := p^.Next
  end;
  k := 0;
  GetName(2);
  dataconv := symmetry;
  If symmetry Then
  Repeat
    Repeat
      WriteLn;
      Write('Data conversion (from range [0, 1] to [-1, 1]) is now ');
      If dataconv then WriteLn('ON') else WriteLn('OFF');
      WriteLn;
      Write('Is this correct? (yes/no) ');
      ReadLn(c);
      GetRandom;
      WriteLn;
      UpperCase(c)
    Until c in ['Y','J','N'];
    If c='N' Then dataconv := not dataconv
  Until c in ['Y','J'];
  WriteLn;
  If dataconv then WriteLn('Reading and converting ',IOname,'...')
              else WriteLn('Reading ',IOname,'...');
  If dataflag=none
  then begin
    If dataconv
    then dataflag := converted
    else dataflag := normal
  end
  else begin
    If ( (dataflag=normal)    and     dataconv ) or
       ( (dataflag=converted) and not dataconv ) then dataflag := mixed
  end;
  Open(IOfile,IOname,history := old,sharing := readonly);
  Reset(IOfile);
  Buf := '';
  While not EOF(IOfile) do
  Begin
    New(p);
    p^.Next := nil;
    If Root=nil then Root := p
                else q^.Next := p;
    q := p;
    ReadTag;
    p^.Tag := Tag;
    Nextreal;
    Result := abs(Result);
    p^.Weight := Result;
    weightsum := weightsum + Result;
    p^.Count := 0;
    patterns := succ(patterns);
    k := succ(k);
    For i:=1 to inp do
    Begin
      NextReal;     { Beware: Fills up the last record with zeros }
                    { if there aren't enough entries in the input file! }
      If dataconv then p^.Input[i] := 2 * Result - 1
                  else p^.Input[i] := Result
    End;
    For j:=1 to out do
    Begin
      NextReal;     { see comment above }
      If dataconv then p^.Target[j] := 2 * Result - 1
                  else p^.Target[j] := Result
    End
  End;
  Close(IOfile);
  WriteLn;
  WriteLn('Read ',k:1,' patterns.');
  WriteLn('Now ',patterns:1,' patterns contained in buffer.');
  WriteLn('Data status: ',dataflag);
  Wait
End;  { ReadData }

Procedure Restart;
Begin
  Repeat
    WriteLn;
    WriteLn('This option re-initializes the weight matrix (randomly);');
    WriteLn('therefore ''forgetting'' any learning carried out previously.',
    chr(7));
    WriteLn;
    Write('Are you sure you want to do this? (yes/no) ');
    ReadLn(c);
    GetRandom;
    WriteLn;
    UpperCase(c)
  Until c in ['Y','J','N','Q'];
  If c in ['Y','J'] Then
  Begin
    WriteLn;
    WriteLn('Initializing...');
    CloseLog;
    InitAll;
    InitRand;
    WriteLn;
    WriteLn('All arrays initialized to zero;');
    WriteLn('Weight matrix initialized randomly in the range [',
    -range:6:4,', ',range:6:4,'].');
    Wait
  End
End;

Procedure KeptMatrix;
Var i,j,k : integer;
Begin
  If KeepVal then
  Begin
    Repeat
      WriteLn;
      WriteLn('This option returns you to the best weight matrix');
      WriteLn('that has been found through previous learning.',chr(7));
      WriteLn;
      Write('Are you sure you want to do this? (yes/no) ');
      ReadLn(c);
      GetRandom;
      WriteLn;
      UpperCase(c)
    Until c in ['Y','J','N','Q'];
    If c in ['Y','J'] Then
    Begin
      InitAll;
      For j:=0 to hid do
      begin
        For i:=0 to inp do Wji[j,i] := Sji[j,i];
        For k:=0 to out do Wkj[k,j] := Skj[k,j]
      end;
      cycles  := Scycles;
      epochs  := Sepochs;
      Psteps  := SPsteps;
      BPsteps := SBPsteps;
      updates := Supdates;
      If logactive then
      begin
        WriteLn(Logfile);
        WriteLn(Logfile,'! Returned to best matrix kept.');
        WriteLn(Logfile)
      end;
      Wait
    End
  End
  Else Begin
    WriteLn;
    WriteLn('No valid best matrix in memory.',chr(7));
    Wait
  End
End;

Procedure ReadMatrix;
Var i,j,k : Integer;

Begin { ReadMatrix }
  InitAll;
  GetName(0);
  WriteLn;
  WriteLn('Reading ',IOname,'...');
  Open(IOfile,IOname,old);
  Reset(IOfile);
  Buf := '';
  For i:=0 to inp do
  begin
    NextReal;    { Skip unneeded line number! }
    For j:=1 to hid do 
    begin
      NextReal;
      Wji[j,i] := Result
    end
  end;
  For j:=0 to hid do
  begin
    NextReal;    { Skip unneeded line number! }
    For k:=1 to out do
    begin
      NextReal;
      Wkj[k,j] := Result
    end
  end;
  NextReal;
  cycles := Round(abs(Result));
  NextReal;
  epochs := Round(abs(Result));
  NextReal;
  Psteps := Round(abs(Result));
  NextReal;
  BPsteps := Round(abs(Result));
  NextReal;
  updates := Round(abs(Result));
  Close(IOfile);
  WriteLn('Weight matrix read.');
  If logactive then
  begin
    WriteLn(Logfile);
    WriteLn(Logfile,'! Read weight matrix from file ''',IOname,'''');
    If (IOname = default[5]) then
      WriteLn(Logfile,'(equal to best matrix save option filename!)');
    WriteLn(Logfile)
  end;
  Wait
End;  { ReadMatrix }

Procedure WriteMatrix;
Begin
  GetName(1);
  WriteLn;
  WriteLn('Saving weight matrix to ',IOname,'...');
  SaveMatrix;
  WriteLn('Matrix saved.');
  Wait
End;

Procedure Parameters;
Var i : integer;

Procedure schmidhuparms;
Begin
  Repeat
    Repeat
      Param1Display;
      Write  (
'Please select: ');
      ReadLn(c);
      GetRandom;
      WriteLn;
      UpperCase(c)
    Until c in ['M','Q'];
    If c = 'M' then
    Begin
      Repeat
        WriteLn;
        Write('Please enter the new value for [maxstep]: ');
        ReadLn(maxstep);
        GetRandom;
        WriteLn
      Until (maxstep>0.0)
    End
  Until c = 'Q';
  c := ' '
End;

Procedure ChanFallsideparms;
Begin
  Repeat
    Repeat
      Param2Display;
      Write  (
'Please select: ');
      ReadLn(c);
      GetRandom;
      WriteLn;
      UpperCase(c)
    Until c in ['N','X','L','D','Q'];
    Case c of
      'N':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [mineta]: ');
          ReadLn(mineta);
          GetRandom;
          WriteLn
        Until (mineta>0.0) and (mineta<maxeta)
      End;
      'X':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [maxeta]: ');
          ReadLn(maxeta);
          GetRandom;
          WriteLn
        Until (maxeta>0.0) and (mineta<maxeta)
      End;
      'L':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [lambda]: ');
          ReadLn(lambda);
          GetRandom;
          WriteLn
        Until (lambda>=0.0) and (lambda<1.0)
      End;
      'D':
      Begin
        Repeat
          WriteLn;
          WriteLn('Set  eta -> 0.5   mom -> 0.9');
          WriteLn;
          Write  ('Are you sure? (yes/no) ');
          ReadLn(c);
          GetRandom;
          WriteLn;
          UpperCase(c)
        Until c in ['Y','J','N'];
        eta := 0.5;
        mom := 0.9
      End
    End  { case }
  Until c = 'Q';
  c := ' '
End;

Procedure Steffenparms;
Begin
  Repeat
    Repeat
      Param7Display;
      Write  (
'Please select: ');
      ReadLn(c);
      GetRandom;
      WriteLn;
      UpperCase(c)
    Until c in ['N','X','Q'];
    Case c of
      'N':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [Smin]: ');
          ReadLn(Smin);
          GetRandom;
          WriteLn
        Until (Smin>0.0) and (Smin<Smax)
      End;
      'X':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [Smax]: ');
          ReadLn(Smax);
          GetRandom;
          WriteLn
        Until (Smax>0.0) and (Smin<Smax)
      End
    End  { case }
  Until c = 'Q';
  c := ' '
End;

Procedure deltabarparms;
Begin
  Repeat
    Repeat
      Param4Display;
      Write  (
'Please select: ');
      ReadLn(c);
      GetRandom;
      WriteLn;
      UpperCase(c)
    Until c in ['T','K','P','Q'];
    Case c of
      'T':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [Theta]: ');
          ReadLn(Theta);
          GetRandom;
          WriteLn
        Until (Theta>0.0) and (Theta<1.0)
      End;
      'K':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [Kappa]: ');
          ReadLn(Kappa);
          GetRandom;
          WriteLn
        Until (Kappa>0.0);
      End;
      'P':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [Phi]: ');
          ReadLn(Phi);
          GetRandom;
          WriteLn
        Until (Phi>0.0) and (Phi<1.0)
      End
    End { case }
  Until c = 'Q';
  c := ' '
End;

Procedure Almeidaparms;
Begin
  Repeat
    Repeat
      Param5Display;
      Write  (
'Please select: ');
      ReadLn(c);
      GetRandom;
      WriteLn;
      UpperCase(c)
    Until c in ['U','D','Q'];
    Case c of
      'U':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [u]: ');
          ReadLn(u);
          GetRandom;
          WriteLn
        Until (u>1.0)
      End;
      'D':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [d]: ');
          ReadLn(d);
          GetRandom;
          WriteLn
        Until (d>0.0) and (d<1.0)
      End
    End { case }
  Until c = 'Q';
  c := ' '
End;

Procedure QuickPropParms;
Begin
  Repeat
    Repeat
      Param3Display;
      Write  (
'Please select: ');
      ReadLn(c);
      GetRandom;
      WriteLn;
      UpperCase(c)
    Until c in ['H','S','T','M','D','Q'];
    Case c of
      'H': hypererr := not hypererr;
      'S': spliteta := not spliteta;
      'T':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [threshold]: ');
          ReadLn(threshold);
          GetRandom;
          WriteLn
        Until (threshold>=0.0)
      End;
      'M':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [maxfactor]: ');
          ReadLn(maxfactor);
          GetRandom;
          WriteLn
        Until (maxfactor>0.0)
      End;
      'D':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [decay]: ');
          ReadLn(decay);
          GetRandom;
          WriteLn
        Until (decay>=0.0)
      End
    End { case }
  Until c = 'Q';
  c := ' '
End;

Begin
  Repeat
    Repeat
      ParamDisplay;
      Write  (
'Please select: ');
      ReadLn(c);
      GetRandom;
      WriteLn;
      UpperCase(c)
    Until
c in ['I','E','M','R','H','S','Z','B','A','P','C','F','T','U','O','K','X','Q'];
    Case c of
      'I':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [range]: ');
          ReadLn(range);
          GetRandom;
          WriteLn
        Until (range>0.0)
      End;
      'E':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [eta]: ');
          ReadLn(eta);
          GetRandom;
          WriteLn
        Until (eta>0.0)
      End;
      'M':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [mom]: ');
          ReadLn(mom);
          GetRandom;
          WriteLn
        Until (mom>=0.0)
      End;
      'R': begin
             MAXnorm := not MAXnorm;
             globVAL := false;
             bestVAL := false;
             oldVAL := false
           end;
      'H': hypererr := not hypererr;
      'S': begin
             unique := not unique;
             globVAL := false;
             bestVAL := false;
             oldVAL := false
           end;
      'Z':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [tolerance]: ');
          ReadLn(tolerance);
          GetRandom;
          WriteLn
        Until (tolerance>=0.0)
      End;
      'B':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [errbias]: ');
          ReadLn(errbias);
          GetRandom;
          WriteLn
        Until (errbias>=0.0)
      End;
      'A':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [abserr]: ');
          ReadLn(abserr);
          GetRandom;
          WriteLn
        Until (abserr>0.0)
      End;
      'P':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [patterr]: ');
          ReadLn(patterr);
          GetRandom;
          WriteLn
        Until (patterr>0.0)
      End;
      'C': Cancel := not Cancel;
      'F':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [RF]: ');
          ReadLn(RF);
          GetRandom;
          WriteLn
        Until (RF>0)
      End;
      'T':
      Begin
        If (patterns > 0) then
        begin
          If Toggle then
          begin
            UF := Round( UF / patterns );
            If UF=0 Then UF := 1
          end
          else UF := UF * patterns
        end;
        Toggle := not Toggle
      End;
      'U':
      Begin
        Repeat
          WriteLn;
          Write('Please enter the new value for [UF]: ');
          ReadLn(UF);
          GetRandom;
          WriteLn
        Until (UF>0)
      End;
      'O': SaveOpt := not SaveOpt;
      'K': KeepOpt := not KeepOpt;
      'X':
      Begin
        WriteLn; ModeNames(mode);
        WriteLn('Selected: ',Tag,'  (mode #',mode:1,')');
        WriteLn;
        For i:=0 to maxmode do
        begin ModeNames(i); WriteLn(i:3,'  :  ',Tag) end;
        Repeat
          WriteLn;
          Write('Please enter the new value for [mode]: ');
          ReadLn(c);
          GetRandom;
          WriteLn;
          mode := ord(c) - ord('0')
        Until mode in [0..maxmode];
        Case mode of
          1: schmidhuparms;
          2: ChanFallsideparms;
          3: QuickPropParms;
          4: deltabarparms;
          5: Almeidaparms;
          7: Steffenparms
        End
      End
    End { case }
  Until c = 'Q'
End;

Procedure Sequential;
Var      p : Zeiger;
         k : integer;
    ploops : integer;
     loops : integer;
Begin
  If (Root = nil) Then Empty
  Else Begin
    GetBestMatrixName;
    Repeat
      WriteLn;
      WriteLn('Please enter maximum number of learning CYCLES to perform');
      Write(  ' PER PATTERN (negative = infinite, zero = quit): ');
      ReadLn(ploops); GetRandom; WriteLn;
      c := ' ';
      If (ploops <> 0) then
      Repeat
        WriteLn;
        WriteLn('Perform maximally ',ploops:1,' cycles per pattern.');
        WriteLn;
        Write('Is this correct? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N']
    Until (c in ['Y','J']) or (ploops = 0);
    If (ploops <> 0) then
    Begin
      Repeat
        WriteLn;
        WriteLn('Please enter maximum number of learning EPOCHS to perform');
        Write(  ' IN TOTAL (negative = infinite, zero = quit): ');
        ReadLn(loops); GetRandom; WriteLn;
        c := ' ';
        If (loops <> 0) then
        Repeat
          WriteLn;
          WriteLn('Perform maximally ',loops:1,
          ' epochs of sequential learning.');
          WriteMode(0);
          WriteLn;
          Write('Is this correct? (yes/no) ');
          ReadLn(c);
          GetRandom;
          WriteLn;
          UpperCase(c)
        Until c in ['Y','J','N']
      Until (c in ['Y','J']) or (loops = 0);
      If (loops <> 0) then
      Begin
        OpenLearnMode(0);
        If Logactive then
        begin
          WriteLn(Logfile,'performing maximally ',ploops:1,
          ' cycles per pattern');
          WriteLn(Logfile)
        end;
        Repeat
          stop := true;
          p := Root;
          While (p <> nil) do
          begin
            Fetch(p);
            k := ploops;
            While (localerr >= patterr) and (k <> 0) do
            begin
              k := pred(k);
              stop := false;
              Backprop;
              Propagate
            end;
            p := p^.Next
          end;
          TestStop(false);
          loops := pred(loops)
        Until stop or (loops = 0) or (break='Q');
        GraphicsOFF
      End
    End
  End
End;  { Sequential }

Procedure Periodical;
Var      p : Zeiger;
         k : integer;
     loops : integer;
Begin
  If (Root = nil) Then Empty
  Else Begin
    GetBestMatrixName;
    Repeat
      WriteLn;
      WriteLn('Please enter maximum number of learning epochs');
      Write  (' to perform (negative = infinite, zero = quit): ');
      ReadLn(loops); GetRandom; WriteLn;
      c := ' ';
      If (loops <> 0) then
      Repeat
        WriteLn;
        WriteLn(
        'Perform maximally ',loops:1,' epochs of periodical learning.');
        WriteMode(1);
        WriteLn;
        Write('Is this correct? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N']
    Until (c in ['Y','J']) or (loops = 0);
    If (loops <> 0) then
    Begin
      OpenLearnMode(1);
      Repeat
        stop := true;
        p := Root;
        While (p <> nil) do
        begin
          Fetch(p);
          k := RF;
          While (localerr >= patterr) and (k > 0) do
          begin
            k := pred(k);
            stop := false;
            Backprop;
            Propagate
          end;
          p := p^.Next
        end;
        TestStop(false);
        loops := pred(loops)
      Until stop or (loops = 0) or (break='Q');
      GraphicsOFF
    End
  End
End;  { Periodical }

Procedure Batch1;
Var      p : Zeiger;
     loops : integer;
Begin
  batch1flag := true;
  If (Root = nil) Then Empty
  Else Begin
    GetBestMatrixName;
    Repeat
      WriteLn;
      WriteLn('Please enter maximum number of learning epochs');
      Write(' to perform (negative = infinite, zero = quit): ');
      ReadLn(loops); GetRandom; WriteLn;
      c := ' ';
      If (loops <> 0) then
      Repeat
        WriteLn;
        WriteLn('Perform maximally ',loops:1,' epochs of batch1 learning.');
        WriteMode(2);
        WriteLn;
        Write('Is this correct? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N']
    Until (c in ['Y','J']) or (loops = 0);
    If (loops <> 0) then
    Begin
      OpenLearnMode(2);
      Repeat
        InitBatch1;
        p := Root;
        While (p <> nil) do
        begin
          Fetch(p);
          Backpropagate;  { not BackProp! }
          p := p^.Next
        end;
        Batch1Step;
        TestStop(false);
        If Cancel and worse then CancelStep;
        loops := pred(loops)
      Until stop or (loops = 0) or (break='Q');
      GraphicsOFF
    End
  End;
  batch1flag := false
End;  { Batch1 }

Procedure Batch2;
Var      p : Zeiger;
     loops : integer;
Begin
  batch2flag := true;
  If (Root = nil) Then Empty
  Else Begin
    GetBestMatrixName;
    Repeat
      WriteLn;
      WriteLn('Please enter maximum number of learning epochs');
      Write(' to perform (negative = infinite, zero = quit): ');
      ReadLn(loops); GetRandom; WriteLn;
      c := ' ';
      If (loops <> 0) then
      Repeat
        WriteLn;
        WriteLn('Perform maximally ',loops:1,' epochs of batch2 learning.');
        WriteMode(3);
        WriteLn;
        Write('Is this correct? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N']
    Until (c in ['Y','J']) or (loops = 0);
    If (loops <> 0) then
    Begin
      OpenLearnMode(3);
      Repeat
        InitBatch2;
        p := Root;
        While (p <> nil) do
        begin
          Fetch(p);
          Backprop;    { batch2flag active! }
          p := p^.Next
        end;
        Batch2Step;
        TestStop(false);
        If Cancel and worse then CancelStep;
        loops := pred(loops)
      Until stop or (loops = 0) or (break='Q');
      GraphicsOFF
    End
  End;
  batch2flag := false
End;  { Batch2 }

Procedure Dynamic;
Var    err : real;
    sample : real;
       p,q : Zeiger;
     loops : integer;
        ll : integer;
         k : integer;
         N : integer;

Procedure UpDate;
Begin
  ll := 0;
  If batch1flag then
  begin
    Batch1Step;
    InitBatch1
  end;
  If batch2flag then
  begin
    Batch2Step;
    InitBatch2
  end;
  TestStop(true);
  If (batch1flag or batch2flag) and Cancel and worse then CancelStep
End;

Begin { Dynamic }
  If (length(Tag) > 1) then c := Tag[2] else c := ' ';
  UpperCase(c);
  N := 4;         { number for learntype }
  If c = 'V' then begin batch1flag := true; N := 5 end;
  If c = 'B' then begin batch2flag := true; N := 6 end;
  If (Root = nil) Then Empty
  Else Begin
    GetBestMatrixName;
    Repeat
      Repeat
        WriteLn;
        Write('Please enter number of learning epochs');
        Write(' to perform (0 to quit): ');
        ReadLn(loops); GetRandom; WriteLn;
        c := ' '
      Until (loops>=0);
      If (loops > 0) then
      Repeat
        WriteLn;
        WriteLn('Perform ',loops:1,' epochs of ',learntype[N],' learning.');
        WriteMode(N);
        WriteLn;
        Write('Is this correct? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N']
    Until (c in ['Y','J']) or (loops = 0);
    If (loops > 0) Then
    Begin
      loops := loops * patterns;
      ll := 0;
      err := globalerr(true);  { force update of all (pattern) weights }
      OpenLearnMode(N);
      If batch1flag then InitBatch1;
      If batch2flag then InitBatch2;
      Repeat
        if weightsum<=0.0 then
        begin
          writeln('Warning: error in calculation of weight sum!',chr(7));
          writeln(weightsum:9:7);
          weightsum := 1.0E-5
        end;

        sample := Random(0.0, weightsum);

        if (sample<=0.0) or (sample>=weightsum) then
        begin
          writeln('Warning: error in calculation of random number!',chr(7));
          writeln(sample:9:7);
          if sample<=0.0 then sample := 1.0E-5 else sample := weightsum
        end;

        q := Root;
        p := q;
        While (sample>0.0) and (q<>nil) do
        begin
          sample := sample - q^.Weight;
          p := q;
          q := q^.Next
        end;
        Fetch(p);
        k := RF;
        If batch1flag Then Backpropagate Else
        If batch2flag Then Backprop Else
        Begin
          err := localerr;
          While (err >= patterr) and (k > 0) do
          begin
            k := pred(k);
            Backprop;
            Propagate;
            err := localerr
          end;
          weightsum := weightsum - p^.Weight + err;
          p^.Weight := err
        End;
        ll := succ(ll);
        If Toggle
        then begin If (ll >= UF)            then UpDate end
        else begin If (ll >= UF * patterns) then UpDate end;
        loops := pred(loops)
      Until stop or (loops = 0) or (break='Q');
      If (ll <> 0) then UpDate; { save matrix if last was best }
      learn := false;
      GraphicsOFF
    End   { loops > 0 }
  End;  { Root <> nil }
  batch1flag := false;
  batch2flag := false
End;  { Dynamic }

Procedure Skeleton;
Var i,j,k : integer;
   m,n,nn : integer;
  y0,y,yy : integer;
  min,max : real;
     l,rr : real;
 inprelev : boolean;
 hidrelev : boolean;
   inperr : inpvector;
   hiderr : hidvector;
  inpsort : array[0..maxinp] of integer;
  hidsort : array[0..maxhid] of integer;
     both : boolean;
     cont : boolean;
     temp : real;
      err : real;
        p : Zeiger;

Procedure Propagate2;
Var j,k : integer;
    sum : real;
Begin { Propagate2 }
  hidV[0] := 1.0;  { Bias unit }
  For k:=1 to out do
  begin
    sum := 0.0;
    For j:=0 to hid do
      sum := sum + Wkj[k,j] * hidV[j];
    If sum<-88.0
    Then If symmetry then outV[k] := -1.0 else outV[k] := 0.0
    Else If symmetry
    then outV[k] := 2.0 / (1.0 + exp(-sum)) - 1.0
    else outV[k] := 1.0 / (1.0 + exp(-sum))
  end
End;  { Propagate2 }

Procedure Calculate;
Begin
  WriteLn;
  WriteLn('Calculating relevance...');
  For i := 1 to inp do begin inperr[i] := 0.0; inpsort[i] := i end;
  For j := 1 to hid do begin hiderr[j] := 0.0; hidsort[j] := j end;
  p := Root;
  While p <> nil do
  Begin
    Fetch(p);
    err := localerr;
    If inprelev then
    For i := 1 to inp do
    begin
      temp := inpV[i];
      inpV[i] := 0.0;
      Propagate;
      inperr[i] := inperr[i] + (localerr - err);
      inpV[i] := temp
    end;
    Fetch(p);
    If hidrelev then
    For j := 1 to hid do
    begin
      temp := hidV[j];
      hidV[j] := 0.0;
      Propagate2;
      hiderr[j] := hiderr[j] + (localerr - err);
      hidV[j] := temp
    end;
    p := p^.Next
  End
End;

Procedure Sort;
Begin
  WriteLn;
  WriteLn('Sorting the results...');
  If inprelev then
  Begin
    cont := true;
    i := inp;
    While cont and (i>1) do
    Begin
      cont := false;
      i := pred(i);
      For j := 1 to i do If inperr[j] > inperr[j+1] then
      begin
        cont := true;
        temp := inperr[j];
        inperr[j] := inperr[j+1];
        inperr[j+1] := temp;
        k := inpsort[j];
        inpsort[j] := inpsort[j+1];
        inpsort[j+1] := k
      end
    End
  End;
  If hidrelev then
  Begin
    cont := true;
    i := hid;
    While cont and (i>1) do
    Begin
      cont := false;
      i := pred(i);
      For j := 1 to i do If hiderr[j] > hiderr[j+1] then
      begin
        cont := true;
        temp := hiderr[j];
        hiderr[j] := hiderr[j+1];
        hiderr[j+1] := temp;
        k := hidsort[j];
        hidsort[j] := hidsort[j+1];
        hidsort[j+1] := k
      end
    End
  End;
  WriteLn;
  WriteLn('All relevance measure values have been sorted.');
  Continue
End;

Procedure Unsort;
Var last,temp : real;
Begin
  WriteLn;
  WriteLn('Unsorting the results...');
  cont := true;
  If inprelev then While cont do
  begin
    cont := false;
    i := 1;
    While (i<=inp) and (inpsort[i]=i) do i := succ(i);
    If (i<=inp) and (inpsort[i]<>i) then
    begin
      cont := true;
      last := inperr[i];
      n := inpsort[i];
      Repeat
        k := n;
        temp := inperr[n];
        m := inpsort[n];
        inperr[n] := last;
        inpsort[n] := n;
        last := temp;
        n := m
      Until k=i
    end
  end;
  cont := true;
  If hidrelev then While cont do
  begin
    cont := false;
    j := 1;
    While (j<=hid) and (hidsort[j]=j) do j := succ(j);
    If (j<=hid) and (hidsort[j]<>j) then
    begin
      cont := true;
      last := hiderr[j];
      n := hidsort[j];
      Repeat
        k := n;
        temp := hiderr[n];
        m := hidsort[n];
        hiderr[n] := last;
        hidsort[n] := n;
        last := temp;
        n := m
      Until k=j
    end
  end;
  WriteLn;
  WriteLn('The original order of all values has been re-established.');
  Continue
End;

Procedure Show;
Begin
  If inprelev then
  Begin
    WriteLn;
    WriteLn('ordinal-#   unit-#   input unit relevance');
    WriteLn;
    k := 0;
    For i := 1 to inp do
    begin
      WriteLn('   ',i:3,'        ',inpsort[i]:3,'     ',inperr[i]:12:7);
      k := succ(k);
      If k>=20 then begin k:=0; Continue end
    end;
    If k<>0 then Continue
  End;
  If hidrelev then
  Begin
    WriteLn;
    WriteLn('ordinal-#   unit-#   hidden unit relevance');
    WriteLn;
    k := 0;
    For j := 1 to hid do
    begin
      WriteLn('   ',j:3,'        ',hidsort[j]:3,'     ',hiderr[j]:12:7);
      k := succ(k);
      If k>=20 then begin k:=0; Continue end
    end;
    If k<>0 then Continue
  End
End;

Procedure Display;
Begin
  If enable then
  begin { graphics }
    m := Round(ymax / 2);
    If both
    then If inp > hid then n := inp else n := hid
    else If inprelev then n := inp else n := hid;
    If n < 20 then n := 20;
    l := xmax / n;
    If both then yy := m-16 else yy := ymax;
    GraphicsON;
    If inprelev then
    begin
      min := inperr[1];
      max := min;
      For i := 2 to inp do
      begin
        If inperr[i] < min then min := inperr[i];
        If inperr[i] > max then max := inperr[i]
      end;
      If min > 0.0 then min := 0.0;
      If max < 0.0 then max := 0.0;
      rr := max - min;
      y0 := Round(abs(min) / rr * yy);
      n := 0;
      For i := 1 to inp do
      begin
        nn := Round(i * l);
        y := Round((inperr[i]-min) / rr * yy);
        If y >= y0 then Box(n,y0,nn,y) else Box(n,y,nn,y0);
        n := nn
      end
    end;
    If hidrelev then
    begin
      min := hiderr[1];
      max := min;
      For j := 2 to hid do
      begin
        If hiderr[j] < min then min := hiderr[j];
        If hiderr[j] > max then max := hiderr[j]
      end;
      If min > 0.0 then min := 0.0;
      If max < 0.0 then max := 0.0;
      rr := max - min;
      y0 := Round(abs(min) / rr * yy);
      n := 0;
      For j := 1 to hid do
      begin
        nn := Round(j * l);
        y := Round((hiderr[j]-min) / rr * yy);
        If both
        then If y >= y0
          then Box(n,m+y0+8,nn,m+y+8)
          else Box(n,m+y+8,nn,m+y0+8)
        else If y >= y0
          then Box(n,y0,nn,y)
          else Box(n,y,nn,y0);
        n := nn
      end
    end;
    GraphicsOFF
  end
  else NoGraphics
End;

Procedure Remove;
Begin
  If inprelev then
  begin
    WriteLn;
    WriteLn(
'Note: The removal of input units is not implemented!',chr(7));
    WriteLn;
    WriteLn(
'It is the user''s responsibility to use the relevance information given here');
    WriteLn(
'to modify his/her input data to discard unnecessary input units!');
    Continue
  end;
  If hidrelev and (hid > 1)
  then begin
    Repeat
      WriteLn;
      WriteLn('--- Remove a HIDDEN unit ---');
      Repeat
        WriteLn;
        Write(
'Please choose the unit to be removed by ordinal number (0 to quit): ');
        ReadLn(k);
        GetRandom;
        WriteLn
      Until k in [0..hid];
      j := 0;
      c := ' ';
      If k<>0 then
      Repeat
        WriteLn;
        WriteLn('Remove the following unit:');
        WriteLn;
        WriteLn('ordinal-#   unit-#   hidden unit relevance');
        WriteLn;
        j := hidsort[k];
        WriteLn('   ',k:3,'        ',j:3,'     ',hiderr[k]:12:7);
        WriteLn;
        Write('Is this correct? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N'];
      If c in ['Y','J'] then
      Repeat
        WriteLn;
        Write('Are you definitely sure to remove that unit? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N']
    Until (k=0) or (c in ['Y','J']);
    If (k<>0) then
    begin
      For i:=1 to hid do
        If hidsort[i]>j then hidsort[i]:=pred(hidsort[i]);
      hiderr[k] := hiderr[hid];
      hidsort[k] := hidsort[hid];
      If (j<>hid) then
      begin
        For i := 0 to inp do Wji[j,i] := Wji[hid,i];
        For k := 1 to out do Wkj[k,j] := Wkj[k,hid]
      end;
      hid := pred(hid);
      globVAL := false;
      bestVAL := false;
      KeepVAL := false;
      oldVAL := false;
      If logactive then
      begin
        WriteLn(Logfile);
        WriteLn(Logfile,'% Hidden unit #',j:1,' has been removed!');
        WriteLn(Logfile)
      end;
      WriteLn;
      WriteLn;
      WriteLn('Hidden unit #',j:1,' has been removed.',chr(7));
      Define_filename_defaults;
      WriteLn
    end
  end
End;

Begin { Skeleton }
  If (Root = nil) then Empty
  else begin
    Repeat
      Repeat
        WriteLn;
        Write('Calculate relevance of [I]nput or [H]idden units or [B]oth? ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['I','H','B','Q'];
      inprelev := (c in ['I','B']);
      hidrelev := (c in ['H','B']);
      If (mode=6) and hidrelev then
      begin
        WriteLn; ModeNames(6);
        WriteLn('No calculation of hidden unit relevance in ',Tag,
        ' mode.',chr(7));
        hidrelev := false
      end;
      both := inprelev and hidrelev;
      If inprelev or hidrelev then
      Repeat
        WriteLn;
        Write('Calculating relevance of ');
        If both
        then WriteLn('both input and hidden units')
        else If inprelev
             then WriteLn('input units')
             else WriteLn('hidden units');
        WriteLn;
        Write('Is this correct? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N']
    Until c in ['Y','J','Q'];
    If c <> 'Q' then
    Begin
      Calculate;
      Repeat
        Repeat
          WriteLn;
          WriteLn('                   --- Skeletonizing Menu ---');
          WriteLn;
          WriteLn('              (L)  [L]ist the relevance values');
          WriteLn('              (D)  [D]isplay bar-histogram');
          WriteLn('              (S)  [S]ort');
          WriteLn('              (U)  [U]nsort');
          WriteLn('              (R)  [R]emove a (hidden) unit');
          WriteLn;
          WriteLn('              (Q)  [Q]uit');
          WriteLn;
          Write  ('Please select: ');
          ReadLn(c);
          GetRandom;
          WriteLn;
          UpperCase(c)
        Until c in ['L','D','S','U','R','Q'];
        Case c of
        'L': Show;
        'D': Display;
        'S': Sort;
        'U': Unsort;
        'R': Remove
        End
      Until c='Q'
    End;
    c := ' '
  end
End;  { Skeleton }

Procedure Info;
Begin
  WriteLn;
  WriteLn('Collecting data...');
  InfoDisplay;
  Wait
End;
{------------------------------------------------------------------------------}
                         { User Functions Menu Items }
{------------------------------------------------------------------------------}
Procedure FunctionPlot;
Var i,j,k,l,m,r : integer;
      pinp,pout : integer;
          x,y,z : real;
              p : Zeiger;
Begin
  If enable then
  begin
    pinp := 1;
    If inp>1 then
    Repeat
      Repeat
        WriteLn;
        Write('Please enter # of input unit to plot: ( 1..',inp:1,' ) ');
        ReadLn(pinp);
        GetRandom;
        WriteLn
      Until pinp in [1..inp];
      Repeat
        WriteLn;
        WriteLn('Plot input unit # : ',pinp:3);
        WriteLn;
        Write('Is this correct? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N']
    Until c in ['Y','J'];
    pout := 1;
    If out>1 then
    Repeat
      Repeat
        WriteLn;
        Write('Please enter # of output unit to plot: ( 1..',out:1,' ) ');
        ReadLn(pout);
        GetRandom;
        WriteLn
      Until pout in [1..out];
      Repeat
        WriteLn;
        WriteLn('Plot output unit # : ',pout:3);
        WriteLn;
        Write('Is this correct? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N']
    Until c in ['Y','J'];
    m := 0;
    Repeat
      Repeat
        WriteLn;
        Write('Please enter the number of (equidistant) samples to plot: ');
        ReadLn(m);
        GetRandom;
        WriteLn
      Until (m >= 0);
      Repeat
        WriteLn;
        If (m=0)
        then WriteLn('Plot the samples given in the pattern buffer only.')
        else WriteLn('Plot ',m:1,' (equidistant) samples.');
        WriteLn;
        Write('Is this correct? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N']
    Until c in ['Y','J'];
    If patterns > m then l := patterns else l := m;
    If (l < 512) and (l > 0) Then l := l * 8 Else l := xmax;
    Repeat
      WriteLn;
      Write('Draw borderline around graphics window used? (yes/no) ');
      ReadLn(c);
      GetRandom;
      WriteLn;
      UpperCase(c)
    Until c in ['Y','J','N'];
    GraphicsON;
    If (c in ['Y','J']) Then Box(0,0,l,ymax);
    p := Root;
    While p <> nil do
    begin
      Fetch(p);
      x := inpV[pinp];
      y := outV[pout];
      z := tarV[pout];
      If symmetry then
      begin
        x := ( x + 1.0 ) * 0.5;
        y := ( y + 1.0 ) * 0.5;
        z := ( z + 1.0 ) * 0.5
      end;
      i := Round( x * l );
      j := Round( y * ymax );
      k := Round( z * ymax );
      If (i>=0) and (i<xlim) then
      begin
        If (j>=0) and (j<ylim) then
        begin Move(i,j); Draw(i,j) end;
        If (k>=0) and (k<ylim) then
        begin Move(i,k); Draw(i,k) end
      end;
      p := p^.Next
    end;
    If (m<>0) Then
    For i := 0 to m do
    begin
      For j:=1 to inp do inpV[j] := 0.0;
      x := i / m;
      j := Round( x * l );
      If symmetry then x := 2.0 * x - 1.0;
      inpV[pinp] := x;
      Propagate;
      y := outV[pout];
      If symmetry then y := ( y + 1.0 ) * 0.5;
      r := Round( y * ymax );
      If (j>=0) and (j<xlim) and (r>=0) and (r<ylim) then
      begin Move(j,r); Draw(j,r) end
    end;
    GraphicsOFF
  end
  else NoGraphics
End;

Procedure MuxPlot;
Var i,j,k,l,m,n,o : integer;
            noise : boolean;
            clamp : real;
              x,y : integer;
                z : real;
                s : string;
Begin
  n := 0;
  Repeat
    n := succ(n);
    o := 2 ** n;
  Until inp <= (o + n);
  WriteLn;
  WriteLn(o:5,' input channels');
  WriteLn(n:5,' selector bits');
  If inp <> (o + n) then
  begin
    WriteLn;
    WriteLn('Error: doesn''t equal number of input bits!',chr(7));
    Wait
  end
  else If enable then
  begin
    Repeat
      Repeat
        WriteLn;
        Write('Please enter the number of (equidistant) samples to plot: ');
        ReadLn(m);
        GetRandom;
        WriteLn
      Until (m > 0);
      Repeat
        WriteLn;
        WriteLn('Plot ',m:1,' (equidistant) samples.');
        WriteLn;
        Write('Is this correct? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N']
    Until c in ['Y','J'];
    noise := true;
    Repeat
      Repeat
        WriteLn;
        Write('Put noise on the other inputs  option is ');
        If noise then WriteLn('ON') else WriteLn('OFF');
        WriteLn;
        Write('Is this correct? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N'];
      If c = 'N' then noise := not noise
    Until c in ['Y','J'];
    clamp := 0.0;
    If not noise then
    Repeat
      Repeat
        WriteLn;
        Write('Please enter the value to clamp the other inputs to: ');
        ReadLn(clamp);
        GetRandom;
        WriteLn
      Until (clamp <= 1.0) and (clamp >= -1.0) and ((clamp>=0.0) or symmetry);
      Repeat
        WriteLn;
        WriteLn('Clamp all other inputs to ',clamp:9:7);
        WriteLn;
        Write('Is this correct? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N']
    Until c in ['Y','J'];
    l := m;
    If (l < 512) and (l > 0) Then l := l * 8 Else l := xmax;
    GraphicsON;
    For i := 1 to o do
    Begin
      Move(0,0); Draw(0,ymax); Draw(l div 3,ymax);
      Move(l - (l div 3),0); Draw(l,0); Draw(l,ymax);
      WriteLn('input #',i:1);
      Move(0,0);
      s := Bin(pred(i),n,n);
      For j := 0 to m do
      begin
        For k := 1 to inp do inpV[k] := clamp;
        If noise then
        begin
          For k := 1 to o do If symmetry
          then inpV[k] := Random( -1.0, 1.0 )
          else inpV[k] := Random(  0.0, 1.0 )
        end;
        inpV[i] := j / m;
        If symmetry then inpV[i] := 2.0 * inpV[i] - 1.0;
        For k := 1 to n do If symmetry
        then inpV[inp-n+k] := 2.0 * (ord( s[k] ) - ord('0')) - 1.0
        else inpV[inp-n+k] :=        ord( s[k] ) - ord('0');
        Propagate;
        z := outV[1];
        If symmetry then z := ( z + 1.0 ) * 0.5;
        x := Round( j / m * l );
        y := Round( z * ymax );
        Draw(x,y)
      end;
      If i < o then
      begin
        Clear_Dialog;
        ReadLn;
        GetRandom;
        Clear_Screen;
        Clear_Dialog
      end
    End;
    GraphicsOFF
  end
  else NoGraphics
End;

Procedure MeshAreaPlot;
Var i,j : integer;
    a,b : integer;
    x,y : real;
      p : Zeiger;
Begin
  If enable then
  begin
    GraphicsON;
    Box(0,0,390*8,390*8);
    p := Root;
    While p<>nil do
    begin
      Fetch(p);
      i := 8 * Round(inpV[1] * 390);
      j := 8 * Round(inpV[2] * 390);
      Move(i,j);
      Draw(i,j);
      p := p^.Next
    end;
    For i := 0 to 390 do
    begin
      a := i * 8;
      x := i / 390;
      For j := 0 to 390 do
      begin
        b := j * 8;
        y := j / 390;
        inpV[1] := x;
        inpV[2] := y;
        Propagate;
        If outV[1] > outV[2] then
        begin
          Move(a,b);
          Draw(a,b)
        end
      end
    end;
    GraphicsOFF
  end
  else NoGraphics
End;

Procedure MeshLinePlot;
Var i,j : integer;
    a,b : integer;
    x,y : real;
      p : Zeiger;
Begin
  If enable then
  begin
    GraphicsON;
    Box(0,0,390*8,390*8);
    p := Root;
    While p<>nil do
    begin
      Fetch(p);
      i := 8 * Round(inpV[1] * 390);
      j := 8 * Round(inpV[2] * 390);
      Move(i,j);
      Draw(i,j);
      p := p^.Next
    end;
    For i := 0 to 390 do
    begin
      a := i * 8;
      x := i / 390;
      For j := 1 to hid do
      begin
        y := -1.0 * ( Wji[j,1] * x + Wji[j,0] ) / Wji[j,2];
        If (y >= 0.0) and (y <= 1.0) Then
        Begin
          b := 8 * Round( y * 390 );
          Move(a,b);
          Draw(a,b)
        End
      end
    end;
    For i := 0 to 390 do
    begin
      b := i * 8;
      y := i / 390;
      For j := 1 to hid do
      begin
        x := -1.0 * ( Wji[j,2] * y + Wji[j,0] ) / Wji[j,1];
        If (x >= 0.0) and (x <= 1.0) Then
        Begin
          a := 8 * Round( x * 390 );
          Move(a,b);
          Draw(a,b)
        End
      end
    end;
    GraphicsOFF
  end
  else NoGraphics
End;

Procedure Ginfo;
Var i,j,k,l : integer;
         kk : integer;
        err : real;
        max : integer;
       maxx : real;
          X : array[0..255] of integer;
          p : Zeiger;
Begin
  WriteLn;
  WriteLn('Collecting data...');
  kk := patterns;
  If kk > 171 then kk := 171;
  For k := 0 to 255 do X[k] := 0;
  maxx := 0.0;
  p := Root;
  While p<>nil do
  begin
    Fetch(p);
    err := localerr;
    p^.Weight := err;
    If err > maxx then maxx := err;
    p := p^.Next
  end;
  p := Root;
  While p<>nil do
  begin
    err := p^.Weight;
    k := trunc(err / maxx * kk);
    If k < kk then X[k] := succ(X[k])
              else X[pred(kk)] := succ(X[pred(kk)]);
    p := p^.Next
  end;
  max := 1;
  For k := 0 to pred(kk) do If X[k] > max then max := X[k];
  WriteLn;
  WriteLn('Maximum error: ',maxx:9:7);
  WriteLn('Maximum density: ',max:1);
If enable then
begin
  Continue;
  GraphicsON;
  Move(xmax,0);
  Draw(xmax,ymax);
  For k := 0 to max do
  begin
    j := round( k / max * ymax );
    Move(xmax,j);
    Draw(4080,j)
  end;
  i := 0;
  For k := 0 to pred(kk) do
  Begin
    l := round( succ(k) / kk * xmax );
    j := round( X[k] / max * ymax );
    If (X[k]<>0) then Box(i,0,l,j);
    i := l
  End;
  GraphicsOFF
end
  else NoGraphics
End;

Procedure ListRates;
Var i,j,k : integer;
        f : boolean;
      min : real;
      max : real;
Begin
  GetName(3);
  WriteLn;
  WriteLn('Writing list of learn rates to ',IOname,'...');
  Open(IOfile,IOname,new);
  Rewrite(IOfile);
  min := eji[1,1];
  max := min;
  for i:=0 to inp do
  begin
    Write(IOfile,'<',i:3,'>');
    k := 0;
    for j:=1 to hid do
    begin
      If eji[j,i] < min Then min := eji[j,i];
      If eji[j,i] > max Then max := eji[j,i];
      Write(IOfile,'  ',eji[j,i]:11:7);
      k := succ(k);
      f := (j=hid);
      if (k>4) or f then
      begin
        k:=0;
        WriteLn(IOfile);
        if not f then Write(IOfile,'     ')
      end
    end
  end;
  for i:=0 to hid do
  begin
    Write(IOfile,'<',i:3,'>');
    k := 0;
    for j:=1 to out do
    begin
      If ekj[j,i] < min Then min := ekj[j,i];
      If ekj[j,i] > max Then max := ekj[j,i];
      Write(IOfile,'  ',ekj[j,i]:11:7);
      k := succ(k);
      f := (j=out);
      if (k>4) or f then
      begin
        k:=0;
        WriteLn(IOfile);
        if not f then Write(IOfile,'     ')
      end
    end
  end;
  WriteLn(IOfile,'Minimum: ',min:12:7);
  WriteLn(IOfile,'Maximum: ',max:12:7);
  Close(IOfile);
  WriteLn('Output file written.');
  WriteLn;
  WriteLn('Minimum: ',min:12:7);
  WriteLn('Maximum: ',max:12:7);
  Wait
End;

Procedure RoundMatrix;
Var i,j,k : integer;
        r : real;
Begin
  Repeat
    WriteLn;
    WriteLn('This option rounds the weight matrix elements,');
    WriteLn('therefore alters the learned responses to the input data.',
    chr(7));
    WriteLn;
    Write('Are you sure you want to do this? (yes/no) ');
    ReadLn(c);
    GetRandom;
    WriteLn;
    UpperCase(c)
  Until c in ['Y','J','N','Q'];
  If c in ['Y','J'] Then
  Begin
    Repeat
      WriteLn;
      Write('Please enter number of decimals to round to: (0-7) ');
      ReadLn(k); GetRandom; WriteLn
    Until k in [0..7];
    r := Round( 10.0 ** k );
    WriteLn;
    WriteLn('Rounding to ',k:1,' decimals...');
    For j := 0 to hid do
    Begin
      For i := 0 to inp do Wji[j,i] := Round( Wji[j,i] * r ) / r;
      For k := 1 to out do Wkj[k,j] := Round( Wkj[k,j] * r ) / r
    End;
    globVAL := false;
    bestVAL := false;
    oldVAL := false;
    Wait
  End
End;

Function Correct : Boolean;
Var k : integer;
    b : boolean;
  lim : real;
Begin
  If symmetry then lim := 0.0 else lim := 0.5;
  b := true;
  k := 1;
  While b and (k <= out) do
  Begin
b := ((tarV[k]>=lim) and (outV[k]>=lim)) or ((tarV[k]<lim) and (outV[k]<lim));
k := succ(k)
  End;
  Correct := b
End;

Procedure Outcorrpattns;
Var  pn : integer;
      p : Zeiger;
      k : integer;
      l : integer;
Begin
  GetName(3);
  WriteLn;
  WriteLn('Writing list of patterns to ',IOname,'...');
  Open(IOfile,IOname,new);
  Rewrite(IOfile);
  WriteLn(IOfile,'Correct patterns:');
  WriteLn(IOfile);
  pn := 0;
  p := Root;
  While p<>nil do
  begin
    Fetch(p);
    pn := succ(pn);
    If Correct Then
    Begin
      WriteLn(IOfile,'#: ',pn:1,'   tag: ',p^.Tag);
      l:=0; For k := 1 to out do Putout(l,tarV[k]);
            For k := 1 to out do Putout(l,outV[k]);
      If l<>0 then WriteLn(IOfile)
    End;
    p := p^.Next
  end;
  WriteLn(IOfile);
  WriteLn(IOfile,'Incorrect patterns:');
  WriteLn(IOfile);
  pn := 0;
  p := Root;
  While p<>nil do
  begin
    Fetch(p);
    pn := succ(pn);
    If not Correct Then
    Begin
      WriteLn(IOfile,'#: ',pn:1,'   tag: ',p^.Tag);
      l:=0; For k := 1 to out do Putout(l,tarV[k]);
            For k := 1 to out do Putout(l,outV[k]);
      If l<>0 then WriteLn(IOfile)
    End;
    p := p^.Next
  end;
  Close(IOfile);
  WriteLn('Output file written.');
  Wait
End;

Procedure Classify;
Var a,b : integer;
      p : Zeiger;
Begin
  a := 0;
  b := 0;
  p := Root;
  While p<>nil do
  begin
    Fetch(p);
    If Correct
    Then a := succ(a)
    Else b := succ(b);
    p := p^.Next
  end;
  WriteLn;
  WriteLn;
  WriteLn('Correctly classified patterns:   ',a:5);
  WriteLn('Incorrectly classified patterns: ',b:5);
  WriteLn;
  Wait
End;

Procedure UserMenu;
Begin
  Repeat
    WriteLn;
    WriteLn;
    WriteLn('                   --- User Functions Menu ---');
    WriteLn;
    WriteLn('              (F)  real [F]unctions plot');
    WriteLn('              (A)  mesh problem [A]rea plot');
    WriteLn('              (L)  mesh problem [L]ine plot');
    WriteLn('              (M)  [M]ultiplexer I/O characteristics plot');
    WriteLn('              (D)  [D]istribution of errors histogramm');
    WriteLn('              (E)  list individual learn rates [E]ta(j,i)');
    WriteLn('              (R)  [R]ound all matrix elements');
    WriteLn('              (C)  [C]ount # of correct/incorrect patterns');
    WriteLn('              (O)  [O]utput list of correct/incorrect patterns');
    WriteLn;
    WriteLn('              (Q)  [Q]uit');
    WriteLn;
    Write  ('Please select: ');
    ReadLn(c);
    GetRandom;
    WriteLn;
    UpperCase(c)
  Until c in ['F','A','L','M','D','E','R','C','O','Q'];
  Case c of
    'F': FunctionPlot;
    'A': MeshAreaPlot;
    'L': MeshLinePlot;
    'M': MuxPlot;
    'D': Ginfo;
    'E': ListRates;
    'R': RoundMatrix;
    'C': Classify;
    'O': Outcorrpattns
  End; { Case }
  c := ' '
End;

Procedure Outpatterns;
Var err : real;
  error : real;
     pn : integer;
      p : Zeiger;
      k : integer;
      l : integer;

Begin
  GetName(3);
  WriteLn;
  WriteLn('Writing list of patterns to ',IOname,'...');
  Open(IOfile,IOname,new);
  Rewrite(IOfile);
  pn := 0;
  p := Root;
  While p<>nil do
  begin
    Fetch(p);
    pn := succ(pn);
    err := localerr;
    WriteLn(IOfile,'#: ',pn:1,'   fetches: ',p^.Count:1,
    '   weight: ',p^.Weight:6:4,'   error: ',err:6:4,'   tag: ',p^.Tag);
    l:=5;Write(IOfile,'inp: '); For k := 1 to inp do Putout(l,inpV[k]);
    If l<>0 then WriteLn(IOfile);
    l:=5;Write(IOfile,'hid: '); For k := 1 to hid do Putout(l,hidV[k]);
    If l<>0 then WriteLn(IOfile);
    l:=5;Write(IOfile,'tar: '); For k := 1 to out do Putout(l,tarV[k]);
    If l<>0 then WriteLn(IOfile);
    l:=5;Write(IOfile,'out: '); For k := 1 to out do Putout(l,outV[k]);
    If l<>0 then WriteLn(IOfile);
    p := p^.Next
  end;
  error := globalerr(false);
  WriteLn(IOfile);
  WriteLn(IOfile,inp:8,'  input units');
  WriteLn(IOfile,hid:8,' hidden units');
  WriteLn(IOfile,out:8,' output units');
  WriteLn(IOfile);
  If symmetry
  then WriteLn(IOfile,'SYMMETRIC logistic function    (range [-1, 1])')
  else WriteLn(IOfile,'standard logistic function     (range [ 0, 1])');
  WriteLn(IOfile,pn:8,' patterns of ',dataflag,' data in buffer');
  WriteLn(IOfile);
  WriteLn(IOfile,'    weightsum : ',weightsum:12:7);
  WriteLn(IOfile,' global error : ',    error:12:7);
  If MAXnorm
  then WriteLn(IOfile,'(maximum norm)')
  else WriteLn(IOfile,'(Root Mean Squares)');
  Close(IOfile);
  WriteLn('Output file written.');
  Wait
End;

Procedure TypeFile;
Var k : integer;
Begin
  default[4] := IOname;
  GetName(4);
  WriteLn;
  WriteLn('Displaying ',IOname,'...');
  WriteLn;
  Open(IOfile,IOname,old);
  Reset(IOfile);
  While not EOF(IOfile) do
  Begin
    ReadLn(IOfile,Buf);
    WriteLn(Buf)
  End;
  Close(IOfile);
  Wait
End;
{------------------------------------------------------------------------------}
                             { Main Menu Handling }
{------------------------------------------------------------------------------}
Procedure DisplayMenu;
Begin
  WriteLn;
  WriteLn;
  WriteLn('                        --- Main Menu ---');
  WriteLn;
  WriteLn('                   (C)  [C]lear data buffer');
  WriteLn('                   (D)  read [D]ata file (patterns) into buffer');
  WriteLn('                   (Z)  initiali[Z]e weight matrix');
  WriteLn('                   (R)  [R]ead weight matrix from file');
  WriteLn('                   (W)  [W]rite weight matrix to disk');
  WriteLn('                   (K)  return to best matrix [K]ept');
  WriteLn;
  WriteLn('                   (L)  [L]earn parameters');
  WriteLn('                   (S)  [S]equential learning');
  WriteLn('                   (P)  [P]eriodical learning');
  WriteLn('                   (V)  sum of deri[V]atives batch learning');
  WriteLn('                   (B)  sum of updates [B]atch learning');
  WriteLn('                   (Y)  d[Y]namic learning ( & ''YV'', ''YB'' )');
  WriteLn('                   (X)  Skeletonizing (Mozer&Smolensky)');
  WriteLn;
  WriteLn('                   (I)  status [I]nformation display');
  WriteLn('                   (U)  [U]ser functions menu');
  WriteLn('                   (O)  write [O]utput file (pattern list)');
  WriteLn('                   (T)  [T]ype file');
  WriteLn('                   (Q)  [Q]uit');
  WriteLn;
  Write  ('     Please select: ')
End;

Procedure ExecuteItem;
Begin
  break := ' ';
  learn := false;
  batch1flag := false;
  batch2flag := false;
  Case c of
    'C': ClearBuffer;
    'D': ReadData;
    'Z': Restart;
    'R': ReadMatrix;
    'W': WriteMatrix;
    'K': KeptMatrix;
    'L': Parameters;
    'S': Sequential;
    'P': Periodical;
    'V': Batch1;
    'B': Batch2;
    'Y': Dynamic;
    'X': Skeleton;
    'I': Info;
    'U': UserMenu;
    'O': Outpatterns;
    'T': TypeFile
  End; { Case }
  c := ' '
End;

Procedure MainMenu;
Begin
  Repeat
    Repeat
      DisplayMenu;
      ReadLn(Tag);
      GetRandom;
      WriteLn;
      If (length(Tag) > 0) then c := Tag[1] else c := ' ';
      UpperCase(c)
    Until c in
['C','D','Z','R','W','K','L','S','P','V','B','Y','X','I','U','O','T','Q'];
    If c = 'Q' Then
    Begin
      Repeat
        WriteLn;
        Write  ('Are you sure you want to quit? (yes/no) ');
        ReadLn(c);
        GetRandom;
        WriteLn;
        UpperCase(c)
      Until c in ['Y','J','N'];
      If c in ['Y','J'] Then c := 'Q'
    End
    Else ExecuteItem
  Until c = 'Q'
End;
{------------------------------------------------------------------------------}
                                   { BP }
{------------------------------------------------------------------------------}
Begin { BP }
  Repeat
    WriteLn;
    WriteLn;
    Repeat
      Write('Please enter number of INPUT units  (1..',maxinp:1,'): ');
      ReadLn(inp);
      GetRandom;
      WriteLn
    Until (inp in [1..maxinp]);
    WriteLn;
    Repeat
      Write('Please enter number of HIDDEN units (1..',maxhid:1,'): ');
      ReadLn(hid);
      GetRandom;
      WriteLn
    Until (hid in [1..maxhid]);
    WriteLn;
    Repeat
      Write('Please enter number of OUTPUT units (1..',maxout:1,'): ');
      ReadLn(out);
      GetRandom;
      WriteLn
    Until (out in [1..maxout]);
    Repeat
      WriteLn;
      WriteLn('Input  units: ',inp:3);
      WriteLn('Hidden units: ',hid:3);
      WriteLn('Output units: ',out:3);
      WriteLn;
      Write('Is this correct? (yes/no) ');
      ReadLn(c);
      GetRandom;
      WriteLn;
      UpperCase(c)
    Until c in ['Y','J','N']
  Until c in ['Y','J'];
  symmetry := true;
  Repeat
    WriteLn;
    Repeat
      WriteLn;
      WriteLn('In the following simulations,');
      If symmetry
      then WriteLn(
'the SYMMETRIC logistic function and values in the range [-1, 1] are used.')
      else WriteLn(
'the standard logistic function and values in the range [0, 1] are used.');
      WriteLn;
      Write('Is this correct? (yes/no) ');
      ReadLn(c);
      GetRandom;
      WriteLn;
      UpperCase(c)
    Until c in ['Y','J','N'];
    If c='N' Then symmetry := not symmetry
  Until c in ['Y','J'];
  Define_filename_defaults;
  WriteLn;
  GetName(6);
  Logname := IOname;
  WriteLn;
  WriteLn('Using ''',Logname,''' as name of logfile.');
  WriteLn;
  IOname := '';
  Tag := '';
  Repeat
    WriteLn;
    Write('Is your terminal capable of graphics (TEK 4205)? (yes/no) ');
    ReadLn(c);
    GetRandom;
    WriteLn;
    UpperCase(c)
  Until c in ['Y','J','N'];
  enable := c in ['Y','J'];
  WriteLn;

  Initialize;
  MainMenu;
  CloseLog

End;  { BP }
{------------------------------------------------------------------------------}
                                  { Main }
{------------------------------------------------------------------------------}
Procedure Logo;
Begin
  WriteLn;
  WriteLn;
  WriteLn(
'----------------------------------------------------------------------------');
  WriteLn(
'                    Back-Propagation Networks Simulator                     ');
  WriteLn(
'----------------------------------------------------------------------------');
  WriteLn(
'                 Implementation of Advanced Learning Rules                  ');
  WriteLn(
'----------------------------------------------------------------------------');
  WriteLn(
'                   Copyright (C) 1992  by  Steffen Beyer                    ');
  WriteLn(
'----------------------------------------------------------------------------');
  WriteLn(
'                                Written at                                  ');
  WriteLn(
'                           Neurologische Klinik                             ');
  WriteLn(
'                         Abteilung Neurolinguistik                          ');
  WriteLn(
'                         Klinikum der RWTH Aachen                           ');
  WriteLn(
'                              Pauwelsstr. 30                                ');
  WriteLn(
'                               5100  Aachen                                 ');
  WriteLn(
'                                  Germany                                   ');
  WriteLn(
'----------------------------------------------------------------------------');
  WriteLn(
'               This program may be used and distributed freely              ');
  WriteLn(
'                   for personal use or scientific research                  ');
  WriteLn(
'             --- Commercial use and distribution prohibited ---             ');
  WriteLn(
'----------------------------------------------------------------------------');
  WriteLn
End;

BEGIN { Main }
  Logo;
  firstrun := true;
  break := ' ';
  RandomStr := '';
  Repeat
    BP;
    firstrun := false;
    WriteLn;
    Repeat
      WriteLn;
      Write('Re-run program? (yes/no) ');
      ReadLn(c);
      GetRandom;
      WriteLn;
      UpperCase(c)
    Until c in ['Y','J','N','Q']
  Until c in ['N','Q']
END.  { Main }
{------------------------------------------------------------------------------}
                                  { EOF }
{------------------------------------------------------------------------------}