UNIT BP_unit;
{
This Unit implements the necessary functions for modelling back-
propagation artificial neural network architectures.
}

{

Copyright 1989 by Wesley R. Elsberry.  All rights reserved.

Commercial use of this software is prohibited without written consent of
the author.

For information, bug reports, and updates contact

Wesley R. Elsberry
528 Chambers Creek Drive South
Everman, Texas 76140
Telephone: (817) 551-7018

}

INTERFACE

 USES
    DOS, Struct, ANN;

 CONST
    mach_inf = 1E37;
    exp_max = 80.0;
    TAB = ^I;
    Debug : BOOLEAN = FALSE;

 TYPE

    REAL = SINGLE;

    file_string_ = STRING;

    node_type_ = (Input,hidden,Output);

    weight_ptr_ = ^weight_;

    weight_ = RECORD
       w, dw : REAL;
       END;

    vector_node_ptr_ = ^vector_node_;

    vector_node_ = RECORD
       V : REAL;
       END;

    sptr_ = ^STRING;

    data_rec_ptr_ = ^data_rec_;

    data_rec_ = RECORD
       s : sptr_;
       n : data_rec_ptr_;
       END;

    weight_node_ptr_ = ^weight_node_;

    weight_node_ = RECORD
       connect : BOOLEAN;
       w, dw, ldw : REAL;
       END;

    BP_net_ptr_ = ^BP_net_;

    BP_node_ptr_ = ^BP_node_;

    BP_net_ = RECORD
       vs, ve : DVE_ptr_;          {node vector start and vector end}
       ws : DVE_ptr_;              {weight array}
       learning_rate : REAL;
       alpha : REAL;               {factor for momentum term}
       vi : DVE_ptr_;              {input vector}
       vos, voe : DVE_ptr_;        {output vector}
       vts, vte : DVE_ptr_;        {training vector}
       n_input, n_hidden, n_output : WORD;
       maxerr : REAL;
       errtol : REAL;
       data_fname : file_string_;
       data_f : TEXT;
       training_iterations : INTEGER;
       out_fname : file_string_;
       out_f : TEXT;
       wt_fname : file_string_;
       wt_f : TEXT;
       END;

    BP_node_ = RECORD
       nt : node_type_;            {Input, hidden, or output}
       loc : WORD;
       ni : REAL;                  {net input value}
       delta : REAL;               {delta value for node}
       base : REAL;
       range : REAL;
       theta : REAL;
       dtheta, ldtheta : REAL;
       fw, bw : DVE_ptr_;          {points to entries in weight_matrix}
       END;


PROCEDURE Dump_BP_net_weights
   (VAR BPN : BP_net_; VAR Fname : STRING);

{Save weights and node bias unit values to a file}


PROCEDURE Set_BP_net_weights_from_file
   (VAR BPN : BP_net_; VAR Fname : STRING);

{Restore weights and node bias unit values from a file}


PROCEDURE BP_set_net_connects_from_file
   (VAR BPN : BP_net_; VAR Fname : STRING);

{Sets network connectivity values from a file}


PROCEDURE Setup_BP_net
   (VAR BPN : BP_net_;VAR Fname : STRING);

{Get data values from a text file to set up basic BP constants, sizes, and
 other necessary information, or query user if filename is not valid.}


PROCEDURE Set_Input_vector_from_file
   (VAR BPN : BP_net_);

{Get data values from a text file to fill input vector.}


PROCEDURE Set_Training_vector_from_file
   (VAR BPN : BP_net_);

{Get data values from a text file to fill training vector.}


PROCEDURE BP_Feed_forward
   (VAR BPN : BP_net_);

{Present values to network and propagate values forward, set the output
 vector.}


PROCEDURE BP_train_presentation
   (VAR BPN : BP_net_);

{Present values to network, propagate forward, set output, compare output
 to training, back-propagate, collect statistics but do not change weights.}


PROCEDURE BP_train_and_change
   (VAR BPN : BP_net_);

{Present values to network, propagate forward, set output, compare output
 to training, back-propagate, collect statistics, change weights, and reset
 statistic variables.}


PROCEDURE BP_change
   (VAR BPN : BP_net_);

{Change weights using current statistics and reset statistics.}


PROCEDURE BP_dump_net
   (VAR BPN : BP_net_);

{Dump net parameters, node activities, and weights for inspection.}


FUNCTION BP_net_error
   (VAR BPN : BP_net_):REAL;

{Returns the largest error from the output nodes}


PROCEDURE Display_weights
   (BPN : BP_net_);

{Display of the current weight values for the network}


{----------------------------------------------------------------------}

IMPLEMENTATION

{----------------------------------------------------------------------}

{Private, internal functions}

 FUNCTION max (r1, r2 : REAL):REAL;

    BEGIN
       IF r1 >= r2 THEN max := r1
       ELSE max := r2;
       END;

{----------------------------------------------------------------------}


 PROCEDURE Dump_BP_net_weights (VAR BPN : BP_net_;
      VAR Fname : STRING);
{Save weights and node bias unit values to a file}
{
Preface vector length with !V
Preface weight vectors with !W
Preface bias unit vector with !T
}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       ii, jj, m, n : WORD;
       inch : CHAR;
       done : BOOLEAN;
       tp1 : DVE_ptr_;
       ss : STRING;

    BEGIN
       n := BPN.n_input + BPN.n_hidden + BPN.n_output;

(*
  ss := FSEARCH(Fname,GETENV('PATH'));

  IF LENGTH(ss) = 0 THEN BEGIN
    WRITELN('**ERROR** File does not exist');
    EXIT;
  END; *)

       BPN.wt_fname := Fname;
       Assign(BPN.wt_f,Fname);
       Rewrite(BPN.wt_f);

       done := FALSE;

  {Write vector length}
       Writeln(BPN.wt_f,'!V ',n:1);

       FOR jj := 1 TO n DO BEGIN
          Write(BPN.wt_f,'!W ');
          FOR ii := 1 TO n DO BEGIN
             tp1 := Find_element_matrix(ii,jj,BPN.ws);
             IF wnp_(tp1^.dptr)^.connect THEN Write(BPN.wt_f,wnp_(tp1^.dptr)^.w:
                  4:4,' ')
             ELSE Write(BPN.wt_f,0.0:4:4,' ');
             END;
          Writeln(BPN.wt_f);
          END;

       Write(BPN.wt_f,'!T ');
       FOR ii := 1 TO n DO BEGIN
          tp1 := Find_element_DVE(ii,BPN.vs);
          Write(BPN.wt_f,bpnp_(tp1^.dptr)^.theta:4:4,' ');
          END;
       Writeln(BPN.wt_f);

       Writeln(BPN.wt_f,'!Z ');

       Close(BPN.wt_f);
       END;                        {Dump_BP_net_weights}


 PROCEDURE Set_BP_net_weights_from_file (VAR BPN : BP_net_;
      VAR Fname : STRING);
 {Restore weights and node bias unit values from a file}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       ii, jj, m, n : WORD;
       rr : REAL;
       tp1, wp1, wp2 : DVE_ptr_;
       inch : CHAR;
       done : BOOLEAN;
       ss : STRING;

    BEGIN                          {}
       n := BPN.n_input + BPN.n_hidden + BPN.n_output;

       ss := FSEARCH (Fname,GETENV('PATH'));

       IF (Length(ss) = 0) THEN BEGIN
          Writeln ('**ERROR** File does not exist');
          EXIT;
          END;

       Assign (BPN.wt_f,ss);
       Reset (BPN.wt_f);

       done := FALSE;

  {Find vector length, compare to net vector length}

       REPEAT
          REPEAT                   {find command}
             Read (BPN.wt_f,inch);
             UNTIL (inch = '!') OR Eof(BPN.wt_f);
                                   {}
          Read (BPN.wt_f,inch);
          UNTIL (UpCase (inch) = 'V') OR Eof (BPN.wt_f);

       IF Eof (BPN.wt_f) THEN BEGIN
          EXIT;
          END;

       Read (BPN.wt_f,inch);
       Read (BPN.wt_f,m);

       IF (m <> n) THEN BEGIN      {Vector lengths don't match, quit}
          EXIT;
          END;

       wp1 := BPN.ws;
       REPEAT                      {get net params}
          REPEAT                   {find command}
             Read (BPN.wt_f,inch);
             UNTIL (inch = '!');   {}
          Read (BPN.wt_f,inch);
          CASE UpCase (inch) OF
             'T' :  BEGIN          {get bias values}
                Read (BPN.data_f, inch);
                FOR ii := 1 TO n DO BEGIN
                   tp1 := Find_element_DVE (ii,BPN.vs);
                   Read (BPN.wt_f,rr);
                   bpnp_(tp1^.dptr)^.theta := rr;
                   END;
                END;               {}
             'W' :  BEGIN          {get weights}
                IF wp1 <> NIL THEN BEGIN
                   Read (BPN.data_f,inch);
                   FOR ii := 1 TO n DO BEGIN
                      wp2 := Find_element_DVE (ii,wp1);
                      Read (BPN.wt_f,rr);
                      wnp_(wp2^.dptr)^.w := rr;
                      END;         {For ii}
                   wp1 := wp1^.down;
                   END;
                END;               {}
             'Z' : DONE := TRUE;
             ELSE
                BEGIN
                   DONE := TRUE;
                   END;
             END;
          UNTIL (done OR Eof (BPN.wt_f));
                                   {}
       END;                        {set_BP_net_weights_from_file}


 PROCEDURE BP_set_net_connects_from_file (VAR BPN : BP_net_;
      VAR Fname : STRING);
 {Sets network connectivity values from a file}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       ii, jj, kk, m, n : WORD;
       tp1, wp1, wp2 : DVE_ptr_;
       inch : CHAR;
       done : BOOLEAN;
       ss : STRING;
       cfile : TEXT;

    BEGIN                          {}
       n := BPN.n_input + BPN.n_hidden + BPN.n_output;

       ss := FSEARCH (Fname,GETENV('PATH'));

       IF (Length(ss) = 0) THEN BEGIN
          Writeln ('**ERROR** File does not exist');
          EXIT;
          END;

       Assign (cfile,ss);
       Reset (cfile);

       done := FALSE;

  {Find vector length, compare to net vector length}

       REPEAT
          REPEAT                   {find command}
             Read (cfile,inch);
             UNTIL (inch = '!') OR Eof(cfile);
                                   {}
          Read (cfile,inch);
          UNTIL (UpCase (inch) = 'V') OR Eof (cfile);

       IF Eof (cfile) THEN BEGIN
          EXIT;
          END;

       Read (cfile,inch);
       Read (cfile,m);

       IF (m <> n) THEN BEGIN      {Vector lengths don't match, quit}
          EXIT;
          END;

       wp1 := BPN.ws;
       REPEAT                      {get net params}
          REPEAT                   {find command}
             Read (cfile,inch);
             UNTIL (inch = '!');   {}
          Read (cfile,inch);
          CASE UpCase (inch) OF
             'C' :  BEGIN          {get weights}
                IF wp1 <> NIL THEN BEGIN
                   Read (cfile,inch);
                   FOR ii := 1 TO n DO BEGIN
                      wp2 := Find_element_DVE (ii,wp1);
                      Read (cfile,kk);
                      wnp_(wp2^.dptr)^.connect := (kk = 1);
                      END;         {For ii}
                   wp1 := wp1^.down;
                   END;
                END;               {}
             'Z' : DONE := TRUE;
             ELSE
                BEGIN
                   DONE := TRUE;
                   END;
             END;
          UNTIL (done OR Eof (cfile));
                                   {}
       END;                        {BP_set_net_connects_from_file}


 PROCEDURE Dump_node (net : BP_net_;
      node : BP_node_ptr_);

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_  = weight_node_ptr_;
       vnp_  = vector_node_ptr_;

    BEGIN
       IF (debug) THEN             {}
            BEGIN
          Writeln ('DUMP_NODE');
          Writeln (NET.OUT_F,'DUMP_NODE');
          END;
       IF (node <> NIL) THEN BEGIN
          CASE node^.nt OF
             Input  : BEGIN
                Write (net.out_f,'INPUT');
                Write ('INPUT');
                END;
             hidden : BEGIN
                Write (net.out_f,'HIDDEN');
                Write ('HIDDEN');
                END;
             Output : BEGIN
                Write (net.out_f,'OUTPUT');
                Write ('OUTPUT');
                END;
             END;
          Write (net.out_f,tab,'LOC : ',NODE^.LOC);
          Write ('LOC : ',NODE^.LOC);
          Writeln (net.out_f,tab,'ADDR : ',Seg(NODE),':',Ofs(NODE));
          Writeln (tab,'ADDR : ',Seg(NODE),':',Ofs(NODE));
          Write (net.out_f,'NI : ',node^.ni:8);
          Write ('NI : ',node^.ni:8);
          Writeln (net.out_f,tab,'DELTA : ',NODE^.DELTA:8);
          Writeln (tab,'DELTA : ',NODE^.DELTA:8);
          Write (net.out_f,'BASE : ',NODE^.BASE:8);
          Write ('BASE : ',NODE^.BASE:8);
          Writeln (net.out_f,tab,'RANGE : ',NODE^.RANGE:8);
          Writeln (tab,'RANGE : ',NODE^.RANGE:8);
          Write (net.out_f,'THETA : ',NODE^.THETA:8);
          Write ('THETA : ',NODE^.THETA:8);
          Writeln (net.out_f,tab,'DTHETA : ',NODE^.DTHETA:8,tab,
                   'LDTHETA : ',
               NODE^.LDTHETA:8);
          Writeln (tab,'DTHETA : ',NODE^.DTHETA:8,tab,'LDTHETA : ',NODE^.
               LDTHETA:8);
          Writeln (net.out_f,'FW : ',Seg(NODE^.FW),':', Ofs(NODE^.FW),
               tab,'BW : ', Seg(NODE^.BW),':',Ofs(NODE^.BW));
          Writeln ('FW : ',Seg(NODE^.FW),':', Ofs(NODE^.FW),tab,'BW : ',
               Seg(NODE^.BW),':',Ofs(NODE^.BW));
          Writeln (net.out_f);
          Writeln;
          END;
       IF (debug) THEN BEGIN
          Writeln ('END DUMP_NODE');
          Writeln (NET.OUT_F,'END DUMP_NODE');
          END;
       END;


 PROCEDURE Display_weights (BPN : BP_net_);
 {Display of the current weight values for the network}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_  = weight_node_ptr_;
       vnp_  = vector_node_ptr_;

    VAR
       twpd, twpa : DVE_ptr_;
       wptr : DVE_ptr_;

    BEGIN                          {}
       IF debug THEN BEGIN
          Writeln ('DISPLAY_WEIGHTS');
          Writeln (BPN.OUT_F,'DISPLAY_WEIGHTS');
          END;
       twpd := BPN.ws;
       twpa := BPN.ws;
       WHILE (twpd <> NIL) DO BEGIN{}
          WHILE (twpa <> NIL) DO BEGIN
                                   {}
             wptr := twpa^.dptr;
             IF (wnp_(wptr)^.connect) THEN BEGIN
                Write (BPN.out_f,wnp_(wptr)^.w:5:1,' ');
                Write (wnp_(wptr)^.w:5:1,' ');
                END
             ELSE                  {}
                  BEGIN
                Write (BPN.out_f,' --- ');
                Write (' --- ');
                END;
             twpa := twpa^.right;
             END;                  {}
          Writeln (BPN.out_f);
          Writeln ;
          twpd := twpd^.down;
          twpa := twpd;
          END;                     {}
       Writeln (BPN.out_f,'End of weights');
       Writeln ('End of weights');
       Writeln;
       Writeln;
       IF (debug) THEN             {}
            BEGIN
          Writeln ('END DISPLAY_WEIGHTS');
          Writeln (BPN.OUT_F,'END DISPLAY_WEIGHTS');
          END;
       Flush (BPN.out_f);
       END;                        {}


 PROCEDURE Display_Vector (vp : DVE_ptr_;
      N : INTEGER;
      NET : BP_net_);
{}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_  = weight_node_ptr_;
       vnp_  = vector_node_ptr_;

    VAR
       ii : INTEGER;
       vptr : vector_node_ptr_;

    BEGIN                          {}
       IF debug THEN BEGIN
          Writeln ('DISPLAY_VECTOR');
          Writeln (NET.OUT_F,'DISPLAY_VECTOR');
          END;
       FOR II := 1 TO N DO BEGIN   {}
          vptr := vp^.dptr;
          Write (net.out_f,vptr^.V:8,'  ');
          Write (vptr^.V:8,'  ');
          vp := vp^.right;
          END;
       Writeln (net.out_f);
       Writeln;
       IF (debug) THEN             {}
            BEGIN
          Writeln ('END DISPLAY_VECTOR');
          Writeln (NET.OUT_F,'END DISPLAY_VECTOR');
          END;
       END;                        {}

 FUNCTION BP_net_error (VAR BPN : BP_net_):REAL;
{Returns the largest error from the output nodes}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_  = weight_node_ptr_;
       vnp_  = vector_node_ptr_;

    VAR
       rr : REAL;
       tp, vp1, vp2 : DVE_ptr_;
       ii, n : INTEGER;

    BEGIN
       rr := 0;
       n := BPN.n_input + BPN.n_hidden + BPN.n_output;
       vp1 := BPN.vos;
       vp2 := BPN.vts;
       FOR ii := 1 TO BPN.n_output DO BEGIN
          IF (vp1^.dptr <> NIL) AND (vp2^.dptr <> NIL) THEN BEGIN
             rr := max (ABS(rr),
                   ABS(vnp_(vp2^.dptr)^.v - vnp_(vp1^.dptr)^.v));
             IF vp1^.right <> NIL THEN vp1 := vp1^.right;
             IF vp2^.right <> NIL THEN vp2 := vp2^.right;
             END
          ELSE BEGIN
             END;
          END;

       BP_net_error := ABS(rr);
       END;

 PROCEDURE Allocate_IO_vectors (VAR net : BP_net_);

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_  = weight_node_ptr_;
       vnp_  = vector_node_ptr_;

    VAR
       ii, N : WORD;

    BEGIN
       IF debug THEN BEGIN
          Writeln ('ALLOCATE_IO_VECTORS');
          Writeln (NET.OUT_F,'ALLOCATE_IO_VECTORS');
          END;
       N := net.n_input + net.n_hidden + net.n_output;
       net.vi := Create_DVE_vector (net.n_input, SizeOf(vector_node_));
       net.vos := Create_DVE_vector (net.n_output, SizeOf(vector_node_));
       net.vts := Create_DVE_vector (net.n_output, SizeOf(vector_node_));
       net.voe := Find_element_DVE (net.n_output, net.vos);
       net.vte := Find_element_DVE (net.n_output, net.vts);
       IF (debug) THEN             {}
            BEGIN
          Writeln ('END ALLOCATE_IO_VECTORS');
          Writeln (NET.OUT_F,'END ALLOCATE_IO_VECTORS');
          END;
       END;

 PROCEDURE Allocate_node_vector (VAR net : BP_net_);

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_  = weight_node_ptr_;
       vnp_  = vector_node_ptr_;

    VAR
       ii, cnt, N : INTEGER;
       Temp : BP_node_ptr_;
       nptr : DVE_ptr_;
       low, high : REAL;
       ns : BP_node_;

    BEGIN
       cnt := 1;
       N := net.n_input + net.n_hidden + net.n_output;
       IF debug THEN BEGIN
          Writeln ('ALLOCATE_NODE_VECTOR');
          Writeln (NET.OUT_F,'ALLOCATE_NODE_VECTOR');
          END;
       net.vs := Create_DVE_vector (net.n_input, SizeOf (BP_node_));
       net.ve := Find_element_DVE (net.n_input, net.vs);
       nptr := net.vs;
       FOR ii := 1 TO net.n_input DO BEGIN
          temp := nptr^.dptr;
          Temp^.loc := cnt;
          cnt := cnt + 1;
          Temp^.nt := Input;       {set node type}
          Temp^.ni := 0;           {init net input}
          Temp^.fw := NIL;         {no weight yet}
          Temp^.bw := NIL;         {no weight yet}
          Temp^.delta := 0;
          Temp^.base := 0;
          Temp^.range := 1;
          Temp^.theta := 0;
          Temp^.dtheta := 0;
          Temp^.ldtheta := 0;
          nptr := nptr^.right;
          END;                     {FOR}
       net.ve^.right := Create_DVE_vector (net.n_hidden,
            SizeOf(BP_node_));
       net.ve^.right^.left := net.ve;
       nptr := net.ve^.right;
       net.ve := Find_element_DVE (net.n_input + net.n_hidden, net.vs);

       FOR II := 1 TO net.n_hidden DO BEGIN
          temp := nptr^.dptr;
          Temp^.loc := cnt;
          cnt := cnt + 1;
          Temp^.nt := hidden;      {set node type}
          Temp^.ni := 0;           {init net input}
          Temp^.fw := NIL;         {no weight yet}
          Temp^.bw := NIL;         {no weight yet}
          Temp^.delta := 0;
          Temp^.base := 0;
          Temp^.range := 1;
          Temp^.theta := gaussian_noise (0,0.25);
          Temp^.dtheta := 0;
          Temp^.ldtheta := 0;
          nptr := nptr^.right;
          END;
       net.ve^.right := Create_DVE_vector (net.n_output,
            SizeOf(BP_node_));
       net.ve^.right^.left := net.ve;
       nptr := net.ve^.right;
       net.ve := Find_element_DVE (net.n_input + net.n_hidden
            + net.n_output,net.vs);

       FOR II := 1 TO net.n_output DO BEGIN
          temp := nptr^.dptr;
          Temp^.loc := cnt;
          cnt := cnt + 1;
          Temp^.nt := Output;      {set node type}
          Temp^.ni := 0;           {init net input}
          Temp^.fw := NIL;         {no weight yet}
          Temp^.bw := NIL;         {no weight yet}
          Temp^.delta := 0;
          Temp^.base := 0          {low};
          Temp^.range := 1         {high - low};
          Temp^.theta := gaussian_noise (0,0.25);
          Temp^.dtheta := 0;
          Temp^.ldtheta := 0;
          nptr := nptr^.right;
          END;
       IF (debug) THEN BEGIN
          Writeln ('END ALLOCATE_NODE_VECTOR');
          Writeln (NET.OUT_F,'END ALLOCATE_NODE_VECTOR');
          END;
       END;


 PROCEDURE Allocate_weight_matrix (VAR net : BP_net_);

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       ii, jj, N : WORD;
       temp : DVE_ptr_;
       tl, tc, tls, tcs : weight_node_ptr_;
       Vt : Vector_node_ptr_;
       cnt : INTEGER;

    BEGIN
       IF debug THEN BEGIN
          Writeln ('ALLOCATE_WEIGHT_MATRIX');
          Writeln (NET.OUT_F,'ALLOCATE_WEIGHT_MATRIX');
          END;
       cnt := 1;
       N := net.n_input + net.n_hidden + net.n_output;
       net.ws := create_matrix (n,n,SizeOf(weight_node_));

       FOR ii := 1 TO n DO BEGIN
          FOR jj := 1 TO n DO BEGIN
             temp := Find_element_matrix(ii, jj, net.ws);
             IF temp <> NIL THEN BEGIN
                wnp_(temp^.dptr)^.connect := FALSE;
                wnp_(temp^.dptr)^.w := 2 * Random - 1;
                                   {random weights, -1 < w < 1 }
                wnp_(temp^.dptr)^.dw := 0;
                wnp_(temp^.dptr)^.ldw := 0;
                END;               {IF temp <> NIL}
             END;
          END;
       IF (debug) THEN             {}
            BEGIN
          Writeln ('END ALLOCATE_WEIGHT_MATRIX');
          Writeln (NET.OUT_F,'END ALLOCATE_WEIGHT_MATRIX');
          END;
       END;

 PROCEDURE Link_weights_to_nodes (VAR net : BP_net_);

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       Start, TempD, TempA : DVE_ptr_;
       Vt : DVE_ptr_;
       ii, jj, N : INTEGER;

    BEGIN
  {Link to node vector}
       IF debug THEN BEGIN
          Writeln ('LINK_WEIGHTS_TO_NODES');
          Writeln (NET.OUT_F,'LINK_WEIGHTS_TO_NODES');
          END;
       N := net.n_input + net.n_hidden + net.n_output;
       Start := net.ws;
       TempD := Start;
       TempA := Start;
       Vt := net.vs;
       FOR ii := 1 TO N DO BEGIN
          bpnp_(Vt^.dptr)^.fw := TempD;
          TempD := TempD^.down;
          bpnp_(Vt^.dptr)^.bw := TempA;
          TempA := TempA^.right;
          Vt := Vt^.right;
          END;
       IF (debug) THEN             {}
            BEGIN
          Writeln ('END LINK_WEIGHTS_TO_NODES');
          Writeln (NET.OUT_F,'END LINK_WEIGHTS_TO_NODES');
          END;
       END;                        {Link_weights_to_nodes}

 PROCEDURE Display_node_type (VAR net : BP_net_);
{}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       tp : DVE_ptr_;
       N, ii : INTEGER;

    BEGIN                          {}
       IF debug THEN BEGIN
          Writeln ('DISPLAY_NODE_TYPE');
          Writeln (NET.OUT_F,'DISPLAY_NODE_TYPE');
          END;
       tp := net.vs;
       N := net.n_input + net.n_hidden + net.n_output;
       FOR ii := 1 TO n DO BEGIN   {}
          CASE bpnp_(tp^.dptr)^.nt OF
             Input  : BEGIN
                Write (net.out_f,'I');
                Write ('I');
                END;
             hidden : BEGIN
                Write (net.out_f,'H');
                Write ('H');
                END;
             Output : BEGIN
                Write (net.out_f,'O');
                Write ('O');
                END;
             END;
          TP := tp^.right;
          END;                     {}
       Writeln (net.out_f);
       Writeln ;
       IF (debug) THEN             {}
            BEGIN
          Writeln ('END DISPLAY_NODE_TYPE');
          Writeln (NET.OUT_F,'END DISPLAY_NODE_TYPE');
          END;
       END;                        {}

 PROCEDURE Display_node_deltas (VAR net : BP_net_);
{}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       tp : DVE_ptr_;
       N, ii : INTEGER;

    BEGIN                          {}
       IF debug THEN BEGIN
          Writeln ('DISPLAY_NODE_DELTAS');
          Writeln (NET.OUT_F,'DISPLAY_NODE_DELTAS');
          END;
       tp := net.vs;
       N := net.n_input + net.n_hidden + net.n_output;
       FOR ii := 1 TO n DO BEGIN   {}
          TP := tp^.right;
          END;                     {}
       IF (debug) THEN             {}
            BEGIN
          Writeln ('END DISPLAY_NODE_DELTAS');
          Writeln (NET.OUT_F,'END DISPLAY_NODE_DELTAS');
          END;
       END;                        {}

 PROCEDURE set_connectivity (VAR net : BP_net_);

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       wpt : DVE_ptr_;
       tvd, tva : DVE_ptr_;
       ii, jj, n : INTEGER;

    BEGIN
       IF debug THEN BEGIN
          Writeln ('SET_CONNECTIVITY');
          Writeln (NET.OUT_F,'SET_CONNECTIVITY');
          END;
       n := net.n_input + net.n_hidden + net.n_output;
       tvd := net.vs;              {beginning of node vector}
       tva := net.vs;
       wpt := bpnp_(tvd^.dptr)^.fw;
  {display_node_type (net);}
       FOR ii := 1 TO n DO BEGIN
          FOR jj := 1 TO n DO BEGIN
             CASE bpnp_(tvd^.dptr)^.nt OF
                Input  : BEGIN
                   wnp_(wpt^.dptr)^.connect := FALSE;
                   END;
                hidden : BEGIN
                   IF (bpnp_(tva^.dptr)^.nt = Input) THEN BEGIN
                      wnp_(wpt^.dptr)^.connect := TRUE;
                      END
                   ELSE BEGIN
                      wnp_(wpt^.dptr)^.connect := FALSE;
                      END;
                   END;
                Output : BEGIN
                   IF (bpnp_(tva^.dptr)^.nt = hidden) THEN BEGIN
                      wnp_(wpt^.dptr)^.connect := TRUE;
                      END
                   ELSE BEGIN
                      wnp_(wpt^.dptr)^.connect := FALSE;
                      END;
                   END;
                END;               {case}
             wpt := wpt^.right;
             tva := tva^.right;
             END;
          tvd := tvd^.right;
          tva := net.vs;
          wpt := bpnp_(tvd^.dptr)^.fw;
          END;
       IF (debug) THEN             {}
            BEGIN
          Writeln ('END SET_CONNECTIVITY');
          Writeln (NET.OUT_F,'END SET_CONNECTIVITY');
          END;
       END;

 PROCEDURE Display_output (VAR net : BP_net_);
 {}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    BEGIN                          {}
       IF debug THEN BEGIN
          Writeln ('DISPLAY_OUTPUT');
          Writeln (NET.OUT_F,'DISPLAY_OUTPUT');
          END;
       display_vector (net.vos,net.n_output,net);
       IF (debug) THEN             {}
            BEGIN
          Writeln ('END DISPLAY_OUTPUT');
          Writeln (NET.OUT_F,'END DISPLAY_OUTPUT');
          END;
       END;                        {}


 FUNCTION BP_error_measure (Output_vector_ptr : DVE_ptr_;
      Training_vector_ptr : DVE_ptr_;
      net : BP_net_): REAL;

    BEGIN
       END;                        {BP_error_measure}


{----------------------------------------------------------------------}

 PROCEDURE BP_set_net_defaults (VAR net : BP_net_);
{}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    BEGIN                          {}
       WITH net DO BEGIN           {}
          vs := NIL;
          ve := NIL;
          ws := NIL;
          vi := NIL;
          vos := NIL;
          voe := NIL;
          vts := NIL;
          vte := NIL;
          maxerr := 0.2;
          errtol := 0.1;
          learning_rate := 0.5;
          alpha := 0.9;            {factor for momentum term}
          n_input := 1;
          n_hidden := 1;
          n_output := 1;
{    data_fname := 'BP.DAT';}
          training_iterations := 1;
          out_fname := 'BP.OUT';
          wt_fname := '';
          END;                     {}
       END;                        {}

 PROCEDURE  BP_get_net_params_from_user (VAR net : BP_net_);
{}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    BEGIN                          {}
       Write ('File to output run data to : ');
       Readln (net.out_fname);
       Assign (net.out_f,net.out_fname);
       Rewrite (net.out_f);
  {learning rate}
       Write ('Learning rate? : ');
       Readln (net.learning_rate);
       Writeln (NET.OUT_F,'Learning rate : ',net.learning_rate:5:3);
       Writeln ('Learning rate : ',net.learning_rate:5:3);
  {momentum factor}
       Write ('Momentum factor? : ');
       Readln (net.alpha);
       Writeln (NET.OUT_F,'Momentum factor : ',net.alpha:5:3);
       Writeln ('Momentum factor : ',net.alpha:5:3);
  {# of input nodes?}              {BP_INPUT_NODES_NUM}
       Write ('Number of input nodes? : ');
       Readln (net.n_input);
       Writeln (NET.OUT_F,'# of input nodes : ',net.n_input:3);
       Writeln ('# of input nodes : ',net.n_input:3);
  {# of hidden nodes in vector}
       Write ('Number of hidden nodes? : ');
       Readln (net.n_hidden);
       Writeln (NET.OUT_F,'# of hidden nodes : ',net.n_hidden:3);
       Writeln ('# of hidden nodes : ',net.n_hidden:3);
  {# of output nodes}
       Write ('Number of output nodes? : ');
       Readln (net.n_output);
       Writeln (NET.OUT_F,'# of output nodes : ',net.n_output:3);
       Writeln ('# of output nodes : ',net.n_output:3);
  {error tolerance}
       Write ('Error tolerance? : ');
       Readln (net.errtol);
       Writeln (NET.OUT_F,'Error tolerance : ',net.errtol:5:3);
       Writeln ('Error tolerance : ',net.errtol:5:3);
       Writeln;
       Write ('Name of data file : ');
       Readln (net.data_fname);
       Writeln (NET.OUT_F,'Data file : ',net.data_fname:15);
       Writeln ('Data file : ',net.data_fname:15);
       Write ('Number of training runs? : ');
       Readln (net.training_iterations);
       Writeln (NET.OUT_F,'# of iterations : ',
                net.training_iterations:3);
       Writeln ('# of iterations : ',net.training_iterations:3);
       Writeln;
       END;                        {}

 PROCEDURE BP_set_net_params_from_file (VAR net : BP_net_;
      VAR Fname : STRING);
{
Use the following format for data entries in this section:

!<option letter><space character><data item><CR>

where the !<option letter> combinations are as follows:

 !L   set learning_rate
 !A   set alpha                 factor for momentum term
 !I   set n_input
 !H   set n_hidden
 !O   set n_output
 !T   set training_iterations
 !E   set error tolerance
 !D   set data_fname
 !R   set out_fname
 !W   set wt_fname
 !Z   mark end of parameter data
}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       inch : CHAR;
       done : BOOLEAN;

    BEGIN                          {}
       Fname := FSEARCH(Fname,GETENV('PATH'));
       IF Length(Fname) = 0 THEN BEGIN
          Writeln('**ERROR** File does not exist');
          EXIT;
          END;

       Assign(net.data_f,Fname);
       Reset(net.data_f);

       done := FALSE;
       REPEAT                      {get net params}
          REPEAT                   {find command}
             Read (net.data_f,inch);
             UNTIL (inch = '!');   {}
          Read (net.data_f,inch);
          CASE UpCase(inch) OF
             'L' :  BEGIN          {get learning rate}
                Read (net.data_f, inch);
                Read (net.data_f, net.learning_rate);
                END;               {}
             'A' :  BEGIN          {get alpha}
                Read (net.data_f, inch);
                Read (net.data_f, net.alpha);
                END;               {}
             'I' :  BEGIN          {get # inputs}
                Read (net.data_f, inch);
                Read (net.data_f, net.n_input);
                END;               {}
             'E' :  BEGIN          {get error tolerance}
                Read (net.data_f, inch);
                Read (net.data_f, net.errtol);
                END;               {}
             'H' :  BEGIN          {get # hidden units}
                Read (net.data_f, inch);
                Read (net.data_f, net.n_hidden);
                END;               {}
             'O' :  BEGIN          {get # output units}
                Read (net.data_f, inch);
                Read (net.data_f, net.n_output);
                END;               {}
             'T' :  BEGIN          {get # of training iterations}
                Read (net.data_f, inch);
                Read (net.data_f, net.training_iterations);
                END;               {}
             'D' :  BEGIN          {get datafile name}
                Read (net.data_f, inch);
                Readln (net.data_f, net.data_fname);
                END;               {}
             'R' :  BEGIN          {get outfile name}
                Read (net.data_f, inch);
                Readln (net.data_f, net.out_fname);
                END;               {}
             'W' :  BEGIN          {get weight file name}
                Read (net.data_f, inch);
                Readln (net.data_f, net.wt_fname);
                END;               {}
             'Z' : DONE := TRUE;
             ELSE
                BEGIN
                   DONE := TRUE;
                   END;
             END;
          UNTIL (done OR Eof (net.data_f));
                                   {}
       Close (net.data_f);
       END;                        {BP_set_net_params_from_file}


{$V-}

 PROCEDURE Setup_BP_net (VAR BPN : BP_net_;
      VAR Fname : STRING);
{Get data values from a text file to set up basic BP constants, sizes,
 and other necessary information, or query user if filename is not
 valid.}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       s : STRING;

    BEGIN                          {Setup_BP_net}
       BP_set_net_defaults (BPN);
       s := FSEARCH(Fname,GETENV('PATH'));
       IF (s = '') THEN            {}
            BEGIN
          BP_get_net_params_from_user (BPN);
          END
       ELSE                        {}
            BEGIN
          BP_set_net_params_from_file (BPN,s);
          Assign(BPN.out_f,BPN.out_fname);
          Rewrite(BPN.out_f);
          END;

       s := FSEARCH(BPN.data_fname,GETENV('PATH'));
       IF (s = '') THEN            {}
            BEGIN
          Assign(BPN.data_f,BPN.data_fname);
          Rewrite(BPN.data_f);
          Writeln(BPN.data_f);
          Close(BPN.data_f);
          Reset(BPN.data_f);
          END
       ELSE                        {}
            BEGIN
          Assign(BPN.data_f,s);
          Reset(BPN.data_f);
          END;


       Randomize;

       Allocate_IO_vectors (BPN);

       Allocate_node_vector (BPN);

       Allocate_weight_matrix (BPN);

       Link_weights_to_nodes (BPN);

       set_connectivity (BPN);

{  display_weights (BPN);}

       END;                        {Setup_BP_net}
{$V+}

 PROCEDURE  set_input_vector_from_file (VAR BPN : BP_net_);
{Get data values from a text file to fill input vector.}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       ii : INTEGER;
       inch : CHAR;
       vp : DVE_ptr_;
       nptr : DVE_ptr_;

    BEGIN                          {}
       IF debug THEN BEGIN
          Writeln ('SET_INPUT_FROM_FILE');
          Writeln (BPN.OUT_F,'SET_INPUT_FROM_FILE');
          END;
       IF Eof(BPN.data_f) THEN BEGIN
          Close(BPN.data_f);
          Reset(BPN.data_f);
          END;

  {find beginning of input line}
       REPEAT                      {}
          Read (BPN.data_f,inch);
          IF (inch = '!') THEN     {skip over net param commands}
               BEGIN
             Read (BPN.data_f,inch);
             Read (BPN.data_f,inch);
             END;
          UNTIL (UpCase(inch) = 'I') OR (Eof(BPN.data_f));
                                   {}
       vp := BPN.vi;
       IF NOT Eof(BPN.data_f) AND (vnp_(vp^.dptr) <> NIL) THEN BEGIN
          FOR ii := 1 TO BPN.n_input DO BEGIN
                                   {}
             Read (BPN.data_f,vnp_(vp^.dptr)^.v);
             vp := vp^.right;
             END;
          END;
       IF (debug) THEN             {}
            BEGIN
          Writeln ('END SET_INPUT_FROM_FILE');
          Writeln (BPN.OUT_F,'END SET_INPUT_FROM_FILE');
          END;
       END;                        {}


 PROCEDURE set_training_vector_from_file (VAR BPN : BP_net_);
{}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       ii : INTEGER;
       inch : CHAR;
       vp : DVE_ptr_;
       nptr : DVE_ptr_;

    BEGIN                          {}
       IF debug THEN BEGIN
          Writeln ('SET_TRAINING_V_FROM_FILE');
          Writeln (BPN.OUT_F,'SET_TRAINING_V_FROM_FILE');
          END;
       IF Eof(BPN.data_f) THEN BEGIN
          Close(BPN.data_f);
          Reset(BPN.data_f);
          END;

  {find beginning of input line}
       REPEAT                      {}
          Read (BPN.data_f,inch);
          IF (inch = '!') THEN     {skip over net param commands}
               BEGIN
             Read (BPN.data_f,inch);
             Read (BPN.data_f,inch);
             END;

          UNTIL (UpCase(inch) = 'T') OR (Eof(BPN.data_f));
                                   {}
       vp := BPN.vts;
       IF NOT Eof (BPN.data_f) THEN
          FOR ii := 1 TO BPN.n_output DO BEGIN
                                   {}
             Read (BPN.data_f,vnp_(vp^.dptr)^.v);
             vp := vp^.right;
             END;
       IF (debug) THEN             {}
            BEGIN
          Writeln ('END SET_TRAINING_V_FROM_FILE');
          Writeln (BPN.OUT_F,'END SET_TRAINING_V_FROM_FILE');
          END;
       END;                        {}

 PROCEDURE Back_propagate (VAR net : BP_net_);
{}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       ii, jj, n : INTEGER;
       rr, ss : REAL;
       tr, ts, tt, tu, tv : REAL;
       npa, npd : DVE_ptr_;        {node ptr across, down}
       cw : DVE_ptr_;              {current weight}
       out, trn : DVE_ptr_;
       inch : CHAR;

    BEGIN                          {}
       IF debug THEN BEGIN
          Writeln ('BACK_PROPAGATE');
          Writeln (NET.OUT_F,'BACK_PROPAGATE');
          END;
       n := net.n_input + net.n_hidden + net.n_output;

  {calculate deltas for the nodes}
       npa := net.ve;              {node ptr across}
       npd := net.vs;              {node ptr down}
       cw  := bpnp_(net.ve^.dptr)^.bw;
                                   {current weight ptr}
       trn := net.vte;             {training vector ptr}
       out := net.voe;             {output vector ptr}
       FOR ii := 1 TO N DO BEGIN   {}
          cw := bpnp_(npa^.dptr)^.bw;
          CASE bpnp_(npa^.dptr)^.nt OF
                                   {node pointer across type}
             Input, hidden : BEGIN {need to assign delta}
                                   {set rr to current node output}
                rr := sigmoid (bpnp_(npa^.dptr)^.range, 1,
                     bpnp_(npa^.dptr)^.base, (bpnp_(npa^.dptr)^.ni
                     + bpnp_(npa^.dptr)^.theta));
                     {find error term from forward connections}
                ss := 0;
                npd := net.vs;
                cw := bpnp_(npa^.dptr)^.bw;
                FOR jj := 1 TO N DO BEGIN
                                   {}
                   IF (wnp_(cw^.dptr)^.connect) THEN BEGIN
                      ss := ss + (bpnp_(npd^.dptr)^.delta
                            * wnp_(cw^.dptr)^.w);
                      END;
                   IF (jj < n) THEN BEGIN
                      npd := npd^.right;
                      cw := cw^.down;
                      END;
                   END;            {}
                IF DEBUG THEN
                   Write ('Delta node ',bpnp_(npa^.dptr)^.loc,' = ',
                   rr:6,' * (1 - ',rr:6,') * ',ss:6);
                bpnp_(npa^.dptr)^.delta := rr * (1 - rr) * ss;
                END;
             Output : BEGIN        {}
                rr := sigmoid (bpnp_(npa^.dptr)^.range,1,
                      bpnp_(npa^.dptr)^.base,
                      (bpnp_(npa^.dptr)^.ni + bpnp_(npa^.dptr)^.theta));
                IF DEBUG THEN
                   Write ('Delta node ',bpnp_(npa^.dptr)^.loc,' = (',
                   vnp_(trn^.dptr)^.v:6,' - ',vnp_(out^.dptr)^.v:6,
                   ') * ', rr:6,' * (1 - ',rr:6,') = ');
                IF (trn <> NIL) AND (out <> NIL) THEN BEGIN
                   bpnp_(npa^.dptr)^.delta := (vnp_(trn^.dptr)^.v
                        - vnp_(out^.dptr)^.v) * rr * (1 - rr);
                   rr := ABS (vnp_(trn^.dptr)^.v - vnp_(out^.dptr)^.v);
                   IF (net.maxerr < rr) THEN BEGIN
                      net.maxerr := rr;
                      END;
                   END
                ELSE BEGIN
                   Writeln ('NIL pointer to train or output');
                   Halt;
                   END;
                IF DEBUG THEN Writeln (bpnp_(NPA^.dptr)^.DELTA:6);
                trn := trn^.left;
                out := out^.left;
                END;               {CASE output term}
             END;                  {CASE}
          npa := npa^.left;
          cw := bpnp_(npa^.dptr)^.bw;
          END;                     {FOR ii}

  {now calculate weight changes for weights and update}
       npa := net.ve;              {node ptr across}
       npd := net.vs;              {node ptr down}
       cw := bpnp_(npa^.dptr)^.bw; {current weight ptr}
       trn := net.vte;             {training vector ptr}
       out := net.voe;             {output vector ptr}
       FOR ii := 1 TO N DO BEGIN   {}
          npd := net.vs;
          cw := bpnp_(npa^.dptr)^.bw;
          FOR jj := 1 TO N DO BEGIN{}
             IF (wnp_(cw^.dptr)^.connect) THEN
                                   {}
                  BEGIN
                rr := sigmoid(bpnp_(npa^.dptr)^.range,1,
                     bpnp_(npa^.dptr)^.base,
                     (bpnp_(npa^.dptr)^.ni + bpnp_(npa^.dptr)^.theta));
                wnp_(cw^.dptr)^.dw := wnp_(cw^.dptr)^.dw
                     + (net.learning_rate *
                     (bpnp_(npd^.dptr)^.delta * rr));
                                   {error * activation}
                END;
             npd := npd^.right;
             cw := cw^.down;
             END;                  {}
          IF DEBUG THEN
             Writeln (bpnp_(npa^.dptr)^.delta:7,'  ',bpnp_(npa^.dptr)
               ^.theta:7);
               {From Simpson, II, p 73}
          bpnp_(npa^.dptr)^.dtheta := bpnp_(npa^.dptr)^.dtheta + net.
               learning_rate * bpnp_(npa^.dptr)^.delta;
                                   {bpnp_(npa^.dptr)^.theta :=
                                      bpnp_(npa^.dptr)^.theta +
                                      bpnp_(npa^.dptr)^.dtheta;}
          npa := npa^.left;
          cw := bpnp_(npa^.dptr)^.bw;
          END;                     {}
       IF (debug) THEN             {}
            BEGIN
          Writeln ('END BACK_PROPAGATE');
          Writeln (NET.OUT_F,'END BACK_PROPAGATE');
          END;
       END;                        {}


 PROCEDURE BP_Feed_forward (VAR BPN : BP_net_);
 {Present values to network and propagate values forward, set the output
  vector.}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       ii, jj, n : INTEGER;
       rr, ss : REAL;
       dp1, dp2, dp3 : DVE_ptr_;
       npa, npd : DVE_ptr_;
       np1 : BP_node_ptr_;         {node ptr across, down}
       cw : DVE_ptr_;              {current weight}
       vin, vout : DVE_ptr_;

    BEGIN                          {}
       IF debug THEN BEGIN
          Writeln ('FEED_FORWARD');
          Writeln (BPN.OUT_F,'FEED_FORWARD');
          END;
{npd is the pointer to the node to change}
{npa points to the node that the current weight may modify the
 output of}

       n := BPN.n_input + BPN.n_hidden + BPN.n_output;
       IF BPN.vs <> NIL THEN BEGIN
          npa := BPN.vs;
          npd := BPN.vs;
          END
       ELSE BEGIN
          Writeln ('ERROR -- NIL pointer encountered #1');
          Halt;
          END;
       IF (BP_node_ptr_(npd^.dptr)^.fw <> NIL) AND (BPN.VI <> NIL)
            AND (BPN.vos <> NIL) THEN BEGIN
          cw := BP_node_ptr_(npd^.dptr)^.fw;
          vin := BPN.vi;
          vout := BPN.vos;
          END
       ELSE BEGIN
          Writeln ('ERROR -- NIL pointer encountered #2');
          Halt;
          END;
       FOR ii := 1 TO N DO BEGIN   {}
          BP_node_ptr_(npd^.dptr)^.ni := 0;
          IF (BP_node_ptr_(npd^.dptr)^.nt = Input) THEN
                                   {}
               BEGIN
             BP_node_ptr_(npd^.dptr)^.ni := VNP_(vin^.dptr)^.v;
             IF debug THEN Writeln ('I_node ',
                  BP_node_ptr_(npd^.dptr)^.loc,
                  ' = ',VNP_(vin^.dptr)^.v:4);
             vin := vin^.right;
             END;                  {IF input}
          npa := BPN.vs;
          cw := BP_node_ptr_(npd^.dptr)^.fw;
          FOR jj := 1 TO N DO BEGIN{}
             IF (WNP_(cw^.dptr)^.connect) THEN
                                   {}
                  BEGIN
                IF (BP_node_ptr_(npa^.dptr)^.nt = Input) THEN
                                   {}
                     BEGIN
                   IF DEBUG THEN
                        Write ('Node ',BP_node_ptr_(npd^.dptr)^.loc,
                        ' = ', BP_node_ptr_(npd^.dptr)^.ni:4,' + ',
                        BP_node_ptr_(npa^.dptr)^.ni:4,' * ',
                        WNP_(cw^.dptr)^.w:4,' = ');
                   rr := BP_node_ptr_(npa^.dptr)^.ni
                        * WNP_(cw^.dptr)^.w;
                   BP_node_ptr_(npd^.dptr)^.ni :=
                        BP_node_ptr_(npd^.dptr)^.ni + rr;
                   IF DEBUG THEN Writeln (rr);
                   END
                ELSE BEGIN
                   rr := (sigmoid(BP_node_ptr_(npa^.dptr)^.range,1,
                        BP_node_ptr_(npa^.dptr)^.base,
                        (BP_node_ptr_(npa^.dptr)^.ni
                        + BP_node_ptr_(npa^.dptr)^.theta))
                        * WNP_(cw^.dptr)^.w);
                   IF DEBUG THEN
                      Writeln ('Node ',BP_node_ptr_(npd^.dptr)^.loc,
                        ' = ', BP_node_ptr_(npd^.dptr)^.ni:4,' + ',rr:4);
                   BP_node_ptr_(npd^.dptr)^.ni :=
                        BP_node_ptr_(npd^.dptr)^.ni + rr;
                   END;            {IF}
                END;               {IF cinnected}
             IF (cw^.right <> NIL) AND (jj < n) THEN BEGIN
                cw := cw^.right;
                npa := npa^.right;
                END
             ELSE IF (cw^.right = NIL) AND (jj < n) THEN BEGIN
                Writeln ('ERROR -- NIL pointer encountered #3  jj=',jj);
                Halt;
                END;
             END;                  {FOR jj = 1 to N }
          IF DEBUG THEN
             Writeln ('Node net in : ',BP_node_ptr_(npd^.dptr)^.ni:6);
          IF (BP_node_ptr_(npd^.dptr)^.nt = Output) THEN BEGIN
             VNP_(vout^.dptr)^.v :=
                  sigmoid(BP_node_ptr_(npd^.dptr)^.range,1,
                  BP_node_ptr_(npd^.dptr)^.base,
                  (BP_node_ptr_(npd^.dptr)^.ni
                  + BP_node_ptr_(npd^.dptr)^.theta));
             vout := vout^.right;
             END;
          IF (npd^.right <> NIL)
               AND (BP_node_ptr_(npd^.dptr)^.fw <> NIL)
               AND (ii < N) THEN BEGIN
             npd := npd^.right;
             cw := BP_node_ptr_(npd^.dptr)^.fw;
             END
          ELSE IF ((npd^.right = NIL)
               OR (BP_node_ptr_(npd^.dptr)^.fw = NIL))
               AND (ii < n) THEN BEGIN
             Writeln ('ERROR -- NIL pointer encountered #4');
             IF (npd^.right = NIL) THEN Write ('NPD^.RIGHT is NIL  ');
             IF (BP_node_ptr_(npd^.dptr)^.fw = NIL) THEN Write (
                  'NPD^.FW is NIL  ');
             Writeln;
             Halt;
             END;
          END;                     {}
       IF (debug) THEN             {}
            BEGIN
          Writeln ('END FEED_FORWARD');
          Writeln (BPN.OUT_F,'END FEED_FORWARD');
          END;
       END;                        {}

 PROCEDURE BP_train_presentation (VAR BPN : BP_net_);
{Present values to network, propagate forward, set output, compare
output to training, back-propagate, collect statistics but do not
change weights.}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    BEGIN                          {BP_train_presentation}
       BP_feed_forward(BPN);
       back_propagate(BPN);
       END;                        {BP_train_presentation}


 PROCEDURE BP_change (VAR BPN : BP_net_);
{Change weights using current statistics and reset statistics.}
{CONST}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    VAR
       ii, jj : WORD;
       node_total : WORD;
       dp1, dp2, wp1, wp2 : DVE_ptr_;
       bpnp1, bpnp2 :BP_node_ptr_;
       wnp1, wnp2 : weight_node_ptr_;

    BEGIN                          {BP_change}
       node_total := BPN.n_input + BPN.n_hidden + BPN.n_output;
  {Change thetas}                  {set pointer to first node}
       dp1 := BPN.vs;
       FOR ii := 1 TO node_total DO BEGIN
                                   {set pointer to node}
          bpnp1 := dp1^.dptr;
          IF (bpnp1 <> NIL) THEN BEGIN
                                   {set new theta value}
             bpnp1^.ldtheta := bpnp1^.dtheta + BPN.alpha
                               * bpnp1^.ldtheta;
             bpnp1^.theta := bpnp1^.theta + bpnp1^.ldtheta;
             END
          ELSE BEGIN
             IF bpnp1 = NIL THEN Writeln (
                  '**Error** Nil ptr encountered: BP_unit.BP_change');
             END;
          IF bpnp1 <> NIL THEN BEGIN
{      bpnp1^.ldtheta := bpnp1^.dtheta;}
             bpnp1^.dtheta := 0;
             END;                  {set pointer to next node}
          dp1 := dp1^.right;
          END;                     {for ii}

  {For each weight, do change, reset stats}
       dp1 := BPN.ws;
       FOR ii := 1 TO node_total DO BEGIN
          dp2 := dp1;
          FOR jj := 1 TO node_total DO BEGIN
             IF (dp2 <> NIL) THEN BEGIN
                wp1 := dp2^.dptr;
                wnp_(wp1)^.ldw := wnp_(wp1)^.dw
                     + BPN.alpha * wnp_(wp1)^.ldw;
                wnp_(wp1)^.w := wnp_(wp1)^.w + wnp_(wp1)^.ldw;
                wnp_(wp1)^.dw := 0;
                dp2 := dp2^.right;
                END;
             END;                  {for jj}
          dp1 := dp1^.down;
          END;                     {for ii}
       END;                        {BP_change}


 PROCEDURE BP_train_and_change (VAR BPN : BP_net_);
{Present values to network, propagate forward, set output, compare output
to training, back-propagate, collect statistics, change weights, and
reset statistic variables.}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    BEGIN                          {BP_train_and_change}
       BP_train_presentation(BPN);
       BP_change(BPN);
       END;                        {BP_train_and_change}


 PROCEDURE  BP_dump_net (VAR BPN : BP_net_);
{Dump net parameters, node activities, and weights for inspection.}

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_ = weight_node_ptr_;
       vnp_ = vector_node_ptr_;

    BEGIN                          {}
       END;                        {}


 PROCEDURE BP_driver (VAR net : BP_net_);

    TYPE
       bpnp_ = BP_node_ptr_;
       wnp_  = weight_node_ptr_;
       vnp_  = vector_node_ptr_;

    VAR
       ii : INTEGER;
       nptr : DVE_ptr_;

    BEGIN                          {}
  {first, check for parameter}
       IF (ParamCount > 0) THEN    {}
            BEGIN
          net.data_fname := ParamStr(1);
          Writeln ;
          Writeln ('BACK PROPAGATION SIMULATION');
          Writeln ;
          DEBUG := FALSE;

                                   {open data file}
          Assign (net.data_f,net.data_fname);
          Reset (net.data_f);
          BP_set_net_params_from_file (net,net.data_fname);
                                   {close data file}
          Close (net.data_f);
          END
       ELSE                        {}
            BEGIN
          Writeln ;
          Writeln ('BACK PROPAGATION SIMULATION');
          Writeln ;
          BP_get_net_params_from_user (net);
          Write ('DEBUG ON OR OFF? (1 or 0) : ');
          Readln (ii);
          CASE ii OF
             0 : debug := FALSE;
             1 : debug := TRUE;
             ELSE
                debug := FALSE;
             END;
          END;
       Assign (net.out_f,net.out_fname);
       Rewrite (net.out_f);

       Writeln (net.out_f,'DEBUG : ',debug);
       Writeln ('DEBUG : ',debug);

                                   {allocate input node vector}
                                   {BP_INPUT_NODES_VECTOR}
                                   {allocate hidden node vector}
                                   {allocate output node vector}
                                   {get scale for output node}
                                   {allocate weight matrix}
                                   {seed with random values}
  {# to times to repeat data}
       Randomize;

       Allocate_IO_vectors (net);

       Allocate_node_vector (net);

       Allocate_weight_matrix (net);

       Link_weights_to_nodes (net);

       set_connectivity (net);

       display_weights (net);

       net.maxerr := net.errtol + 1.0;
       ii := 1;
       WHILE (net.maxerr > net.errtol)
            AND (ii <= net.training_iterations) DO BEGIN
          IF ((ii MOD 50) = 1) THEN BEGIN
             Writeln (net.out_f,'At iteration ',ii);
             Writeln ('At iteration ',ii);
             END;
          Assign (net.data_f,net.data_fname);
          Reset (net.data_f);
          net.maxerr := 0.0;
          WHILE (NOT Eof (net.data_f)) DO BEGIN
                                   {}
             IF debug THEN Writeln ('In data loop ');
             set_input_vector_from_file (net);
             IF (NOT Eof(NET.DATA_F)) THEN BEGIN
                IF ((ii MOD 50) = 1) THEN BEGIN
                   Writeln (NET.OUT_F);
                   Writeln ;
                   Write (net.out_f,'Input : ');
                   Write ('Input : ');
                   display_vector (net.vi,net.n_input,net);
                   END;
                set_training_vector_from_file (net);
                BP_feed_forward (net);
                IF ((ii MOD 50) = 1) THEN BEGIN
                   Write (net.out_f,'Output : ');
                   Write ('Output : ');
                   display_vector (net.vos,net.n_output,net);

                   Write (net.out_f,'Expected : ');
                   Write ('Expected : ');
                   display_vector (net.vts,net.n_output,net);
                   END;
                back_propagate (net);
                END;
             END;                  {}
          Close (net.data_f);
          ii := ii + 1;
          END;                     {while ii and out of tolerance}

       Writeln (net.out_f,'Iterations = ',ii);
       Writeln ;
       Writeln (net.out_f,'Weights after training : ');
       Writeln ('Weights after training : ');
       display_weights (net);
       Writeln (NET.OUT_F);
       Writeln ;
       Writeln (NET.OUT_F,'Final values associated with nodes :');
       Writeln ('Final values associated with nodes :');
       nptr := net.vs;
       FOR II := 1 TO (net.n_input + net.n_hidden + net.n_output) DO
            BEGIN
          dump_node (net,bpnp_(nptr^.dptr));
          nptr := nptr^.right;
          Writeln (net.out_f);
          Writeln ;
          END;

       Flush (NET.OUT_F);
       Close (NET.OUT_F);
       END;                        {}


BEGIN {BP_unit}
END. {BP_unit}

{----------------------------------------------------------------------}