home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast2.iso / neurlnet / neural20.zip / SLUG3.PAS < prev    next >
Pascal/Delphi Source File  |  1994-01-09  |  39KB  |  1,250 lines
  1. {$F+}
  2.  
  3. uses objects,owindows,odialogs,strings,win31,windos, wintypes,winprocs,
  4.      ostddlgs,bwcc,bpnet2, nnunit2, dyna2,wintools,cfmtools
  5. {$IFDEF DEBUG}
  6. ,WINCRT
  7. {$ENDIF}
  8. ;
  9.  
  10. {$I c:\neural\slug3\SLUG3.inc}
  11. {$R c:\neural\slug3\slug3}
  12. type
  13.  
  14.    nninitdata = record
  15.            inputsize            : longint;
  16.            outputsize           : longint;
  17.            hiddensize           : longint;
  18.    end;
  19.  
  20.    NNLearnparams  = record
  21.            Lcoeff         : double;
  22.            momentum       : double;
  23.            Kmod           : double;
  24.            Maxerr         : double;
  25.            Maxiter        : longint;
  26.    end;
  27.  
  28.    TrainStepRec = record
  29.            DMdesired     : pdynamat;
  30.            DMinput       : pdynamat;
  31.            DVerror       : pdynavec;
  32.    end;
  33.  
  34.    Transferfuncrec = record
  35.            hiddentanh,hiddensigmoid,hiddenlinear,
  36.            outputtanh,outputsigmoid,outputlinear   : WORD;
  37.    end;
  38.  
  39.  
  40.    pannpgm  = ^ANNpgm;
  41. {----------------------------}
  42.    ANNpgm   = object(tapplication)
  43. {----------------------------}
  44.  
  45.       procedure Initmainwindow; virtual;
  46.  
  47.    end;
  48.  
  49.  
  50.     pNNwindow   = ^NNwindow;
  51. {----------------------------}
  52.     NNWindow    = object(tdlgwindow)
  53. {----------------------------}
  54.       net                   : psimplebpnet;
  55.       inname                : array[0..fspathname] of char;
  56.       outname               : array[0..fspathname] of char; {these contain a network on stream}
  57.       datainname            : array[0..fspathname] of char;
  58.       logname               : array[0..fspathname] of char; {these contain network data}
  59.       infile,
  60.       outfile               : pdosstream; {streams for network}
  61.       datainfile,
  62.       logfile               : text;
  63.       initbuffer            : nninitdata; {user data}
  64.       learnbuffer           : NNlearnparams;
  65.       funcbuffer            : transferfuncrec;
  66.       datainopen            : boolean;  {are the data files open? }
  67.       logopen               : boolean;
  68.       netok,dataok,logok    : boolean;  {are these specified ?}
  69.       modified              : boolean;  {refers to network spec file}
  70.       running               : boolean;
  71.       training              : boolean;
  72.       stopped               : boolean;
  73.       logappend             : boolean; {Logfile Append check box}
  74.       edmomentum,edlearn,                 {edit controls in the main dialog box}
  75.       edkmod,edmaxerr,
  76.       infolearn,
  77.       infomomentum          : PSTATIC; {pfloatedit;  don't need these in BP7...}
  78.       edmaxiter             : Pstatic; {pnumedit;}
  79.       edinfocount           : pnumedit;
  80.       edinfoerror           : pfloatedit;
  81.       eddatafile,
  82.       edlogfile             : Pstatic; {pedit;}
  83.       chlogappend           : pcheckbox;
  84.  
  85.  
  86.       constructor init(aparent : pwindowsobject; atitle  : pchar);
  87.       destructor done; virtual;
  88.       function  canclose : boolean; virtual;
  89.       function  getclassname : pchar ;virtual;
  90.       procedure getwindowclass(var awndclass : twndclass); virtual;
  91.       procedure CMnewfile(var mess : tmessage); virtual cm_first +cm_filenew;
  92.       procedure CMopenfile(var mess : tmessage); virtual cm_first +cm_fileopen;
  93.       procedure CMsavefile(var mess : tmessage); virtual cm_first +cm_filesave;
  94.       procedure CMsaveasfile(var mess : tmessage); virtual cm_first +cm_filesaveas;
  95.       procedure CMEXit(var mess : tmessage); virtual cm_first +cm_exit;
  96.       procedure CMbuildnet(var mess : tmessage); virtual ;
  97.       procedure CMdatain(var mess : tmessage); virtual cm_first +cm_datain;
  98.       procedure CMdataout(var mess : tmessage); virtual cm_first +cm_dataout;
  99.       procedure CMSetTransfer(var mess : tmessage); virtual cm_first+cm_settransfer;
  100.       procedure SetTransferFunctions;
  101.       procedure CMtrain(var mess : tmessage); virtual cm_first +cm_train;
  102.       procedure CMtrainparams(var mess: tmessage); virtual cm_first+ cm_trainedit;
  103.       procedure CMrun(var mess : tmessage); virtual cm_first +cm_run;
  104.       procedure CMAbout(var mess : tmessage); virtual cm_first +cm_about;
  105.       procedure CMSlughelp(var mess : tmessage); virtual cm_first + cm_slughelp;
  106.       procedure CMdisplay(var mess : tmessage); virtual cm_first +cm_display;
  107.       procedure BNResetweights(var mess : tmessage); virtual id_first+ id_reset;
  108.       procedure BNstopnet(var mess : tmessage); virtual id_first+ id_iterstop;
  109.       procedure BNsavenet(var mess : tmessage); virtual id_first+ id_savenet;
  110.       procedure BNreadnet(var mess : tmessage); virtual id_first+ id_readnet;
  111.       procedure BNshakenet(var mess : tmessage); virtual id_first+ id_shake;
  112.       procedure BNtrain(var mess : tmessage); virtual id_first+ id_train;
  113.       procedure BNSettransfer(var mess : tmessage); virtual id_first+ id_settransfer;
  114.       procedure BNdataopen(var mess : tmessage);virtual id_first+id_dataopen;
  115.       procedure BNdataclose(var mess : tmessage); virtual id_first+id_dataclose;
  116.       procedure BNlogopen(var mess : tmessage); virtual id_first+id_logopen;
  117.       procedure BNlogclose(var mess : tmessage); virtual id_first+id_logclose;
  118.       procedure BNtrainparams(var mess : tmessage); virtual id_first+id_trainparams;
  119.       procedure trainsession;
  120.       function  trainepoch(var data : trainsteprec; count: word) : double;
  121.       procedure setupnetparams;
  122.       procedure showtrainparams;
  123.       procedure shownetparams;
  124.       procedure showicon(state : word);
  125.       function  closelogfile    : boolean;
  126.       function  closedatafile   : boolean;
  127.       function  killnet         : boolean;
  128.       procedure report(rep :pchar);          
  129.  
  130.     end;
  131.  
  132.  
  133.     pSpecdialog = ^Specdialog;
  134. {----------------------------}
  135.     Specdialog  = object(tdialog)
  136. {----------------------------}
  137.        procedure zerocounts(var mess : tmessage); virtual
  138.                                                  id_first + id_netspecclear;
  139.     end;
  140.  
  141. var tempstr  : string;
  142.  
  143.  
  144.    {--------------------- NNWINDOW PROCEDURES --------------------------}
  145.  
  146.  
  147.  
  148. {----------------------------}
  149. constructor nnwindow.init(aparent : pwindowsobject;
  150.                           atitle  : pchar);
  151. {----------------------------}
  152. begin
  153.      tdlgwindow.init(aparent,atitle);
  154.      ismodal  := false;
  155.      if neuralerror <> 0 then
  156.        begin
  157.        printneuralerror;
  158.        exit;
  159.        end;
  160.      strcopy(outname,'');
  161.      strcopy(inname,'*.ann');
  162.      strcopy(datainname,'');
  163.      strcopy(logname,'');
  164.      infile         := nil;
  165.      outfile        := nil;
  166.      net            := nil;
  167.      modified   := false;
  168.  
  169.      running    := false;
  170.      stopped    := false;
  171.      training   := false;
  172.      datainopen := false;
  173.      logopen    := false;
  174.      logok      := false;
  175.      dataok     := false;
  176.      netok      := false;
  177.      logappend  := false;
  178.  
  179.  
  180.      with initbuffer do
  181.         begin
  182.         inputsize     := 2;
  183.         outputsize    := 1;
  184.         hiddensize    := 2;
  185.         end;
  186.      with learnbuffer do
  187.         begin
  188.         lcoeff      := 0.5;
  189.         momentum    := 0.8;
  190.         kmod        := 0;
  191.         maxerr      := 0.1;
  192.         maxiter     := 20000;
  193.         end;
  194.                 {set transferfunction specs}
  195.      with funcbuffer do
  196.         begin
  197.         hiddentanh    := BF_unchecked;
  198.         hiddensigmoid := BF_checked;
  199.         hiddenlinear  := BF_unchecked;
  200.         outputtanh    := BF_unchecked;
  201.         outputsigmoid := BF_unchecked;
  202.         outputlinear  := BF_checked;
  203.     end;
  204.                 { Initialize the edit controls }
  205.      new(edmomentum,initresource(@self,ed_usermomen,6));
  206.      new(edlearn,initresource(@self,ed_userlearn,6));
  207.      new(edkmod,initresource(@self,ed_userkmod,6));
  208.      new(edmaxerr,initresource(@self,ed_usermaxerr,6));
  209.      new(edmaxiter,initresource(@self,ed_usermaxiter,6));
  210.      new(eddatafile,initresource(@self,ed_userdatafile,20));
  211.      new(edlogfile,initresource(@self,ed_userlogfile,20));
  212.  
  213.      new(edinfocount,initresource(@self,ed_infocount,6,1,999));
  214.      new(edinfoerror,initresource(@self,ed_infoerror,6,0.0,9999.9));
  215.      new(infolearn,initresource(@self,ed_infolearn,6));
  216.      new(infomomentum,initresource(@self,ed_infomomen,6));
  217.      new(chlogappend,initresource(@self,id_append));
  218.  
  219.      showicon(sw_hide);
  220. end;
  221.  
  222. {----------------------------}
  223. destructor nnwindow.done;
  224. {----------------------------}
  225. begin
  226.      if net <> nil then dispose(net,done);
  227.      dispose(edmomentum, done);
  228.      dispose(edlearn,done);
  229.      dispose(edkmod,done);
  230.      dispose(edmaxerr,done);
  231.      dispose(edmaxiter,done);
  232.      dispose(eddatafile,done);
  233.      dispose(edlogfile,done);
  234.  
  235.      dispose(edinfocount,done);
  236.      dispose(edinfoerror,done);
  237.      dispose(infolearn,done);
  238.      dispose(infomomentum,done);
  239.      dispose(chlogappend,done);
  240.  
  241.      if datainopen then close(datainfile);
  242.      if logopen then close(logfile);
  243.  
  244.      tdlgwindow.done;
  245. end;
  246.  
  247.  
  248. {----------------------------}
  249. function nnwindow.getclassname : pchar;
  250. {----------------------------}
  251. begin
  252.      getclassname := 'neuralnetwindow';
  253. end;
  254.  
  255. {----------------------------}
  256. procedure nnwindow.getwindowclass(var awndclass : twndclass);
  257. {----------------------------}
  258. begin
  259.      tdlgwindow.getwindowclass(awndclass);
  260.      awndclass.hicon := loadicon(hinstance,'networkicon');
  261.      awndclass.lpszmenuname    := 'themenu';
  262.      Awndclass.hbrbackground := getstockobject(null_brush);
  263.         {Remember to specify the menu in the resource file !}
  264. end;
  265.  
  266.  
  267. {----------------------------}
  268. function nnwindow.canclose : boolean;
  269. {----------------------------}
  270. var
  271.    reply : integer;
  272.    mess  : tmessage;
  273. begin
  274.     canclose := true;
  275.     if training or running then
  276.       begin
  277.       BNstopnet(mess);
  278.       canclose := false;
  279.       exit;
  280.       end;
  281.     if netok and modified then
  282.         begin
  283.         reply := messagebox(hwindow,'Lose your changes ?','Net has changed...',
  284.                         mb_yesno or mb_iconquestion);
  285.         if reply = idno then
  286.            canclose := false
  287.         else
  288.             begin
  289.             canclose := true;
  290.             if net <> nil then
  291.                begin
  292.                dispose(net,done);
  293.                net := nil;
  294.                netok := false;
  295.                showicon(sw_hide);
  296.                end;
  297.             end;
  298.         end;
  299.  
  300. end;
  301.  
  302. {----------------------------}
  303. procedure nnwindow.cmExit(var mess: tmessage);
  304. {----------------------------}
  305. begin
  306.      if not (training or running) then tdlgwindow.CmExit(mess)
  307. end;
  308.  
  309. {----------------------------}
  310. function  nnwindow.closelogfile    : boolean;
  311. {----------------------------}
  312. begin
  313.      if logopen then close(logfile);
  314.      logopen := false;
  315.      logok   := false;
  316.      setdlgitemtext(hwindow,ed_userlogfile,'');
  317.      closelogfile := true;
  318. end;
  319.  
  320. {----------------------------}
  321. function  nnwindow.closedatafile   : boolean;
  322. {----------------------------}
  323. begin
  324.      if datainopen then close(datainfile);
  325.      datainopen := false;
  326.      dataok   := false;
  327.      setdlgitemtext(hwindow,ed_userdatafile,'');
  328.      closedatafile := true;
  329. end;
  330.  
  331. {----------------------------}
  332. function  nnwindow.killnet         : boolean;
  333. {----------------------------}
  334.                               { If a modified net exists, asks
  335.                                  before disposing of it.
  336.                                  Returns true if the net is disposed.}
  337. var
  338.    ans          : word;
  339.    mess         : Tmessage;
  340.    cankill      : boolean;
  341. begin
  342.      cankill := false;
  343.      if (net = nil) then
  344.          begin
  345.          killnet := true;
  346.          netok := false;
  347.          exit;
  348.          end;
  349.  
  350.      if not modified then cankill := true;
  351.      if modified then   
  352.           begin
  353.           ans := messagebox(hwindow,'Do you want to save it ?',
  354.                               'This net has changed',
  355.                               mb_yesnocancel or mb_iconhand);
  356.           case ans of
  357.             id_cancel : cankill := false;
  358.             id_yes    :
  359.                        begin
  360.                        CMsaveasfile(mess);
  361.                        cankill := true;
  362.                        end;
  363.             id_no     : cankill := true;
  364.             end;
  365.           end;
  366.  
  367.      if cankill then
  368.      begin
  369.      dispose(net,done);
  370.      net := nil;
  371.      netok := false;
  372.      showicon(sw_hide);
  373.      end;
  374.  
  375.      killnet := cankill;
  376. end;
  377.  
  378. {----------------------------}
  379. procedure nnwindow.CMnewfile(var mess : tmessage);
  380. {----------------------------}
  381. var
  382.    ans  : integer;
  383. begin
  384.                         {Throw the old network out and build a new one}
  385.      if not (running or training) then
  386.      if killnet then
  387.         begin
  388.         setdlgitemtext(hwindow,ed_netname,'');
  389.         strcopy(outname,'');
  390.         strcopy(inname,'');
  391.         if datainopen then closedatafile;
  392.         CMbuildnet(mess);
  393.         if net <> nil then
  394.            begin
  395.            netok := true;
  396.            showicon(sw_show);
  397.            shownetparams;
  398.             settransferfunctions;
  399.            end
  400.         else
  401.            begin
  402.            netok := false;
  403.            showicon(sw_hide);
  404.            report('No Network');
  405.            if neuralerror <> 0 then printneuralerror;
  406. {           say('It is best to restart SLUG !');}
  407.            end;
  408.         end;
  409. end;
  410.  
  411. {----------------------------}
  412. procedure nnwindow.CMopenfile(var mess : tmessage);
  413. {----------------------------}
  414.                                 {Throw out old net and read a new one}
  415. var
  416.    result,save       : integer;
  417. begin
  418.      if running or training then exit;
  419.                           { else, net is now nil.
  420.                             If If new name chosen, get it from stream. }
  421.      strcopy(inname,'*.ann');
  422.      if application^.execdialog(new(pfiledialog,init(@self,
  423.                                     pchar(sd_bcfileopen), inname))) = id_ok
  424.      then
  425.        begin
  426.        if not killnet then exit;
  427.        strcopy(outname,inname);
  428.        new(infile,init(inname,stopenread));
  429.        if (infile^.status <> stOK) then
  430.              begin
  431.              say('Could not open file ! ');
  432.              if infile <> nil then dispose(infile,done);
  433.              exit;
  434.              end;
  435.        net := psimplebpnet(infile^.get);
  436.        dispose(infile,done);
  437.  
  438.        if (net <> nil) then    { net OK}
  439.          begin
  440.          netok := true;
  441.          showicon(sw_show);
  442.          shownetparams;
  443.          setdlgitemtext(hwindow,ed_netname,inname);
  444.          if datainopen then closedatafile;
  445.          with initbuffer do
  446.             begin
  447.             inputsize    := net^.inputfield^.count;
  448.             outputsize   := net^.outputfield^.count;
  449.             hiddensize   := net^.hiddenfield^.count;
  450.             end;
  451.          with learnbuffer do
  452.             begin
  453.             lcoeff      := net^.learn;
  454.             momentum    := net^.momen;
  455.             end;
  456.          end
  457.        else                    { Net not OK} 
  458.          begin
  459.          say('No network present !');
  460.          report('Error');
  461.          showicon(sw_hide);
  462.          strcopy(inname,'*.ann');
  463.          strcopy(outname,'');
  464.          setdlgitemtext(hwindow,ed_netname,'');
  465.          netok := false;
  466.          end;  
  467.        end;
  468.      
  469.  
  470. end;
  471.  
  472. {----------------------------}
  473. procedure nnwindow.CMsaveasfile(var mess : tmessage);
  474. {----------------------------}
  475.                               { Overwrites without asking !
  476.                               }
  477. begin
  478.      if (strlen(outname) = 0) then
  479.        strcopy(outname,'*.ann')
  480.      else
  481.        strcopy(outname,inname);
  482.  
  483.      if application^.execdialog(new(pfiledialog,init(@self,
  484.                      pchar(sd_bcFileSave), outname))) = id_ok
  485.      then
  486.        begin
  487.        setdlgitemtext(hwindow,ed_netname,outname);
  488.        modified := false;
  489.        new(outfile,init(outname,stcreate));
  490.        if outfile^.status <> stOK then
  491.           begin
  492.           say('Could not create file ! ');
  493.           exit
  494.           end; 
  495.        outfile^.put(net);
  496.        dispose(outfile,done);
  497.        outfile := nil;
  498.        report('Net saved');
  499.        end;
  500. {$ifdef debug}
  501.      messagebox(hwindow,outname,'File saved as :',mb_ok);
  502. {$endif}
  503. end;
  504.  
  505. {----------------------------}
  506. procedure nnwindow.CMsavefile(var mess : tmessage);
  507. {----------------------------}
  508.  
  509.                                 {Simply save}
  510. begin
  511.      if (net <>nil) and (strlen(outname)<> 0)  then
  512.        begin
  513.        new(outfile,init(outname,stcreate));
  514.        if outfile^.status <> stOK then
  515.           begin
  516.           say('Could not open file ! ');
  517.           Report('Error during stream access');
  518.           exit
  519.           end; 
  520.        outfile^.put(net);
  521.        dispose(outfile,done);
  522.        modified := false;
  523.        report('Net written');
  524.        end
  525.      else
  526.        if (net <>nil) then CMsaveasfile(mess);
  527.  
  528. {$ifdef debug}
  529.      messagebox(hwindow,outname,'Written to :',mb_ok);
  530. {$endif}
  531. end;
  532.  
  533. {-----------------------------------}
  534. procedure nnwindow.CMbuildnet(var mess : tmessage);
  535. {-----------------------------------}
  536. var
  537.    edit1, edit2, edit3, edit4    : pnumedit; {numeric edit boxes}
  538.    dlg                           : pspecdialog;
  539.    result,discard,i              : integer;
  540.  
  541. procedure builddialog;
  542. begin
  543.       new(dlg,init(@self,'netspec1'));   {init the dialog }
  544.       dlg^.transferbuffer := @initbuffer;
  545.                                          {and the controls}
  546.       new(edit1,initresource(dlg,id_netspecin,3,1,999));
  547.       new(edit2,initresource(dlg,id_netspecout,3,1,999));
  548.       new(edit3,initresource(dlg,id_netspechidden,3,1,999));
  549.                                               {execute the dialog}
  550.       result := application^.execdialog(dlg);
  551.       if result <= 0 then say('Could not open the dialog');
  552. end;
  553.  
  554. begin
  555.       if killnet then
  556.          begin
  557.          if datainopen then closedatafile;
  558.          builddialog;
  559.          if result=idok then with initbuffer do
  560.              begin
  561.              new(net,init(initbuffer.inputsize,
  562.                           initbuffer.hiddensize,
  563.                           initbuffer.outputsize,0.5,0.5));
  564.              if net <> nil then
  565.             begin
  566.         net^.shake(0.10);
  567.              report('New network created');
  568.              netok := true;
  569.                 cmsettransfer(mess);
  570.                 end;
  571.  
  572.              end;
  573.  
  574.          modified := false;
  575.          end;
  576.  
  577. end;
  578.  
  579. {--------------------------}
  580. procedure nnwindow.CMdatain(var mess : tmessage);
  581. {--------------------------}
  582. begin
  583.  
  584.      if datainopen then closedatafile;
  585.      strcopy(datainname,'*.dat');
  586.      if application^.execdialog(new(pfiledialog,init(@self,
  587.                      pchar(sd_bcfileopen), datainname))) = id_ok
  588.      then
  589.         begin
  590.         setdlgitemtext(hwindow,ed_userdatafile,datainname);
  591.         dataok := true;
  592.         report('Datafile specified');
  593.         end
  594.      else
  595.          begin
  596.          strcopy(datainname,'');
  597.          dataok := false;
  598.          report('Datafile needs to be specified');
  599.          end;
  600. end;
  601.  
  602.  
  603. {--------------------------}
  604. procedure nnwindow.CMdataout(var mess : tmessage);
  605. {--------------------------}
  606. begin
  607.     if logopen
  608.     then
  609.        if messagebox(hwindow,'Do you want to close it ?','Logfile is open !',
  610.                   mb_yesno or mb_iconhand) = id_no
  611.        then exit
  612.        else
  613.             begin
  614.             closelogfile;
  615.             logopen := false;
  616.             logok := false;
  617.             report('Logfile closed');
  618.             end;
  619.  
  620.     strcopy(logname,'*.log');
  621.     if application^.execdialog(new(pfiledialog,init(@self,
  622.                 pchar(sd_bcfileopen), logname))) = id_ok
  623.     then
  624.           begin
  625.           logok := true;
  626.           logopen := false;
  627.           setdlgitemtext(hwindow,ed_userlogfile,logname);
  628.           if chlogappend^.getcheck = bf_checked then logappend := true
  629.              else logappend := false;
  630.           Report('Logfile specified');
  631.           end;
  632.  
  633. end;
  634. {--------------------------}
  635. procedure NNWindow.SetTransferfunctions;
  636. {--------------------------}
  637. var
  638.    thefield  : neuronfield;
  639.    thefunction :  signaltype;
  640. begin
  641.  
  642.      if funcbuffer.hiddentanh    = bf_checked then thefunction := tanh;
  643.      if funcbuffer.hiddensigmoid = bf_checked then thefunction := sigmoid;
  644.      if funcbuffer.hiddenlinear  = bf_checked then thefunction := linear;
  645.      net^.setfieldsignal(net^.hiddenfield,thefunction);
  646.      if funcbuffer.outputtanh    = bf_checked then thefunction := tanh;
  647.      if funcbuffer.outputsigmoid = bf_checked then thefunction := sigmoid;
  648.      if funcbuffer.outputlinear  = bf_checked then thefunction := linear;
  649.      net^.setfieldsignal(net^.outputfield,thefunction);
  650.  
  651. end;
  652. {--------------------------}
  653. procedure NNWindow.CMSetTransfer(var mess : tmessage);
  654. {--------------------------}
  655. var
  656.    dlg         : pdialog;
  657.    dlgok     : integer;
  658.    button    : Pradiobutton;
  659. begin
  660.      if net=nil then exit;
  661. {$ifdef publicdomain}
  662.      net^.setfieldsignal(net^.outputfield,linear);
  663.      net^.setfieldsignal(net^.hiddenfield,sigmoid);
  664.      exit;
  665. {$endif}
  666.      dlg := nil;
  667.                  {init dialog and controls}
  668.      new(dlg,init(@self,'transferdlg'));
  669.      if dlg=nil then exit;
  670.      new(button,initresource(dlg,id_hiddentanh));
  671.      new(button,initresource(dlg,id_hiddensigmoid));
  672.      new(button,initresource(dlg,id_hiddenlinear));
  673.      new(button,initresource(dlg,id_outputtanh));
  674.      new(button,initresource(dlg,id_outputsigmoid));
  675.      new(button,initresource(dlg,id_outputlinear));
  676.      dlg^.transferbuffer := @funcbuffer;
  677.  
  678.      dlgok := application^.execdialog(dlg);
  679.      if dlgok <=0 then
  680.         begin
  681.         say('Could not open dialog');
  682.         exit;
  683.         end;
  684.  
  685.      if dlgok = idok then settransferfunctions;
  686.  
  687. {$IFDEF DEBUG}
  688.      printneuralerror;
  689.      writeln('Dialog returned ',dlgok);
  690. {$ENDIF}
  691.  
  692. end;
  693.  
  694.  
  695.  
  696. {--------------------------}
  697. procedure nnwindow.CMtrainparams(var mess: tmessage);
  698. {--------------------------}
  699. var
  700.    edit1, edit2, edit3, edit4 : pfloatedit; {numeric edit boxes}
  701.    edit5                      : pnumedit;
  702.    dlg                        : pspecdialog;
  703.    result,discard             : integer;
  704.  
  705. begin
  706.       new(dlg,init(@self,'trainparam'));   {init the dialog }
  707.       dlg^.transferbuffer := @learnbuffer;
  708.                                          {and the controls}
  709.       new(edit1,initresource(dlg,ed_userlearn,10,0,100));
  710.       new(edit2,initresource(dlg,ed_usermomen,10,0,100));
  711.       new(edit3,initresource(dlg,ed_userkmod,10,0,100));
  712.       new(edit4,initresource(dlg,ed_usermaxerr,10,0,10));
  713.       new(edit5,initresource(dlg,ed_usermaxiter,6,0,100000));
  714.  
  715.                                               {execute the dialog}
  716.       result := application^.execdialog(dlg);
  717.       if result <= 0 then
  718.          begin
  719.          say('Insufficient memory');
  720.          exit;
  721.          end;
  722. {      else dispose(dlg,done);}
  723.  
  724.       if (net <> nil) and (result=id_ok) then
  725.          begin
  726.          with learnbuffer do
  727.             begin
  728.             net^.learn := learnbuffer.lcoeff;    { tell the net}
  729.             net^.momen := learnbuffer.momentum;
  730.             showtrainparams;                     {tell the user}
  731.             end;
  732.           end;
  733. end;
  734.  
  735. {--------------------------}
  736. procedure nnwindow.showtrainparams;
  737. {--------------------------}
  738.                             { Redisplays current learning params }
  739. var
  740.    str1  : array[0..6] of char;
  741. begin
  742.      str1[1] := #0;
  743.      if netok then
  744.          begin
  745.          str(net^.learn:6:1,str1);
  746.          setdlgitemtext(hwindow,ed_userlearn,str1);
  747.          setdlgitemtext(hwindow,ed_infolearn,str1);
  748.  
  749.          str(net^.momen:6:1,str1);
  750.          setdlgitemtext(hwindow,ed_usermomen,str1);
  751.          setdlgitemtext(hwindow,ed_infomomen,str1);
  752.  
  753.          setdlgitemint(hwindow,ed_userkmod,0, false);
  754.          str(learnbuffer.maxerr:6:2,str1);
  755.          setdlgitemtext(hwindow,ed_usermaxerr,str1);
  756.  
  757.          setdlgitemint(hwindow,ed_usermaxiter,learnbuffer.maxiter,false);
  758.          end;
  759. end;
  760.  
  761. {--------------------------}
  762. procedure nnwindow.shownetparams;
  763. {--------------------------}
  764. begin
  765.      if net <> nil then
  766.          begin
  767.          setdlgitemint(hwindow,id_incount,net^.inputfield^.count,false);
  768.          setdlgitemint(hwindow,id_hiddencount,net^.hiddenfield^.count,false);
  769.          setdlgitemint(hwindow,id_outcount,net^.outputfield^.count,false);
  770.          end;
  771. end;
  772.  
  773. {--------------------------}
  774. procedure nnwindow.CMtrain(var mess: tmessage);
  775. {--------------------------}
  776. begin
  777.      if ((dataok) and     { If all is set up...}
  778.         (logok) and
  779.         (net <> nil) and
  780.         not training )
  781.      then
  782.        begin
  783.        training := true;             {then open the files..}
  784.  
  785.        stopped:= false;
  786.        if not datainopen then opentextfile(strpas(datainname),datainfile);
  787.                                      {check for append on logfile}
  788.  
  789.        if not logopen then
  790.           if not logappend then
  791.              createtextfile(strpas(logname),logfile)
  792.           else
  793.              appendtextfile(strpas(logname),logfile);
  794.  
  795.                                      {do some interface stuff}
  796.        logopen     := true;
  797.        datainopen  := true;
  798.        showwindow(getdlgitem(hwindow,id_readnet), sw_hide);
  799.        showwindow(getdlgitem(hwindow,id_dataopen), sw_hide);
  800.        showwindow(getdlgitem(hwindow,id_dataclose), sw_hide);
  801.        showwindow(getdlgitem(hwindow,id_logopen), sw_hide);
  802.        showwindow(getdlgitem(hwindow,id_logclose), sw_hide);
  803.        enablewindow(getdlgitem(hwindow,id_cancel),false);
  804.        enablemenuitem(getmenu(hwindow),cm_exit,mf_bycommand or mf_grayed);
  805.        enablemenuitem(getmenu(hwindow),cm_fileopen,mf_bycommand or mf_grayed);
  806.        enablemenuitem(getmenu(hwindow),cm_filenew,mf_bycommand or mf_grayed);
  807.        enablemenuitem(getmenu(hwindow),cm_netedit,mf_bycommand or mf_grayed);
  808.        drawmenubar(hwindow);
  809.        report('Training');
  810.  
  811.        trainsession;                  {and train}
  812.  
  813.        spacedline(logfile,'Final Weights');
  814.        printmattofile(logfile,net^.weights^);
  815.        spacedline(logfile,' ');
  816.        reset(datainfile);
  817.  
  818.        training:= false;
  819.        showwindow(getdlgitem(hwindow,id_readnet), sw_show);
  820.        showwindow(getdlgitem(hwindow,id_dataopen), sw_show);
  821.        showwindow(getdlgitem(hwindow,id_dataclose), sw_show);
  822.        showwindow(getdlgitem(hwindow,id_logopen), sw_show);
  823.        showwindow(getdlgitem(hwindow,id_logclose), sw_show);
  824.        enablewindow(getdlgitem(hwindow,id_cancel),true);
  825.        enablemenuitem(getmenu(hwindow),cm_exit,mf_enabled or mf_bycommand);
  826.        enablemenuitem(getmenu(hwindow),cm_filenew,mf_bycommand or mf_enabled);
  827.        enablemenuitem(getmenu(hwindow),cm_fileopen,mf_bycommand or mf_enabled);
  828.        enablemenuitem(getmenu(hwindow),cm_netedit,mf_bycommand or mf_enabled);
  829.        drawmenubar(hwindow);
  830.        end
  831.      else
  832.        begin
  833.        messagebeep(mb_iconexclamation);
  834.        report('Setup not complete !');
  835.        end;
  836.  
  837. end;
  838.  
  839. {--------------------------}
  840. procedure nnwindow.trainsession;
  841. {--------------------------}
  842. label quickstop;
  843. var
  844.    i,j                  : word;
  845.    count                : longint;
  846.    lines,linelength     : integer;
  847.    totalerror,lasterror : double;
  848.    Traindata            : Trainsteprec;
  849.    incount,outcount     : integer;
  850.    mess                 : tmsg;
  851.    dvin                 : pdynavec; { for net response after training}
  852.  
  853. begin
  854.      if net = nil then
  855.         BEGIN
  856.         messagebeep(mb_iconexclamation);
  857.         messagebox(hwindow,'','No Network defined !',mb_ok);
  858.         exit;
  859.         END
  860.      else
  861.         modified := true;
  862.  
  863.                                 { Check out datafile }
  864.      readln(datainfile); readln(datainfile);
  865.      lines := countlines(datainfile);
  866.      readln(datainfile);readln(datainfile); {position correctly...}
  867.                                             {Data interpretation determined
  868.                                              by network structure}
  869.      outcount := net^.outputfield^.count;   
  870.      incount  := net^.inputfield^.count;
  871.      linelength:= incount + outcount;
  872.  
  873.                                 { Make datastructures}
  874.      with traindata do
  875.           begin
  876.           new(DMInput,init(lines,linelength));
  877.           new(DMdesired,init(lines,outcount));
  878.           new(DVerror,init(outcount,1));
  879.                                 { Get input data}
  880.           if linestomat(datainfile,DMinput^) <> 0 then
  881.          begin
  882.              dispose(DMInput,done);
  883.              dispose(DMdesired,done);
  884.              dispose(DVerror,done);
  885.              say('Error reading datafile !');
  886.              exit;
  887.          end;;
  888.           writeln(logfile,'IO MATRIX');
  889.           printmattofile(logfile,DMinput^);
  890.           for i := 1 to lines do
  891.               for j := 1 to outcount do
  892.                  DMdesired^.put(i,j,DMinput^.get(i,incount+j));
  893.           writeln(logfile,'DESIRED MATRIX');
  894.           printmattofile(logfile,DMdesired^);
  895.  
  896.           for i := 1 to outcount do DMinput^.deletecol(incount+i);
  897.           writeln(logfile,'INPUT MATRIX');
  898.           printmattofile(logfile,DMinput^);
  899.           end;
  900.  
  901.      setupnetparams;
  902.      showtrainparams;
  903.                     { Start the training...}
  904.  
  905.      count      := 0;
  906.      totalerror :=9999;
  907.      repeat
  908.          yield(mess);
  909.          edinfocount^.transfer(@count,tf_setdata);
  910.          edinfoerror^.transfer(@totalerror,tf_setdata);
  911.  
  912.             count := count +1;
  913.             totalerror := TrainEpoch(traindata,lines); {present all data once}
  914.             edinfocount^.transfer(@count,tf_setdata);
  915.             edinfoerror^.transfer(@totalerror,tf_setdata);
  916.             if (count mod 5)=0 then
  917.                 writeln(logfile,'Event # ',count,totalerror:12:6);
  918.  
  919.          if stopped then
  920.             begin
  921.             report('Stopped');
  922.             totalerror := 0;
  923.             spacedline(logfile,' ---- Unexpected Training stop ! -----');
  924.             end;
  925.      until (totalerror < learnbuffer.maxerr) or
  926.           (count > learnbuffer.maxiter);
  927.  
  928.                               {finished Training...}
  929.  
  930.      if not stopped then report('Trained !') else report('Unexpected stop');
  931.      with traindata do
  932.        begin
  933.        spacedline(logfile,'Network response: ');
  934.        for j := 1 to lines do
  935.           begin
  936.           dminput^.getrow(j,dvin);
  937.           net^.feedforward(dvin);
  938.           write(logfile,' inputvec  :');
  939.           printvectofile(logfile,80,dvin^);
  940.           write(logfile,' response : ');
  941.           for i := 1 to net^.outputfield^.count do
  942.              write(logfile,pneuron(net^.outputfield^.at(i-1))^.output:8:3);
  943.           writeln(logfile);
  944.           end;
  945.        flush(logfile);
  946.  
  947. quickstop:
  948.        dispose(dmdesired,done);
  949.        dispose(dminput,done);
  950.        dispose(dverror,done);
  951.        end;
  952.  
  953. end;
  954.  
  955.  
  956. {----------------------------}
  957.  function nnwindow.trainepoch(var data : trainsteprec; count: word) : double;
  958. {----------------------------}
  959. var                           { Presents count I/O pairs once}
  960.    lasterror, totalerror    : double;
  961.    dvin,dvdesired           : pdynavec;
  962.    thisone                  : pneuron;
  963.    i,j                        : integer;
  964.    mess                       : tmsg;
  965. begin
  966.        for j := 1 to count do { For each training datum...}
  967.  
  968.           begin
  969.           inc(count);
  970.           data.DMdesired^.getrow(j,dvdesired); {get data}
  971.           data.DMinput^.getrow(j,dvin);
  972.           net^.feedforward(dvin);              { Feed it forward}
  973.            
  974.                                 {make error vector}
  975.           for i := 1 to net^.outputfield^.count do  {...for each output neuron}
  976.               begin
  977.               yield(mess);
  978.               thisone := net^.outputfield^.at(i-1);
  979.               lasterror := (dvdesired^.get(i) - thisone^.output);
  980.               totalerror := totalerror + abs(lasterror);
  981.               data.dverror^.put(i, lasterror);
  982.               end;              { feed error back}
  983.  
  984.           net^.train(data.dverror);
  985.           end;
  986.  
  987.        trainepoch := totalerror;
  988.  
  989. end;
  990.  
  991.  
  992. {----------------------------}
  993. procedure nnwindow.setupnetparams;
  994. {----------------------------}
  995.                               { Get data from buffers to the existing net}
  996. begin
  997.      if net <> nil then
  998.  
  999.      begin                           { Setup Backpropnet}
  1000.      net^.learn := learnbuffer.lcoeff;
  1001.      net^.momen := learnbuffer.momentum;
  1002.      end;
  1003. end;
  1004.  
  1005.  
  1006. {--------------------------}
  1007. procedure nnwindow.CMrun(var mess : tmessage);
  1008. {--------------------------}
  1009. var
  1010.    DMInput      : pdynamat;
  1011.    DVIn         : pdynavec;
  1012.    lines,i,j     : integer;
  1013. begin
  1014.    if (net <> nil) and (dataok) and (logok) then
  1015.    begin
  1016.      if not datainopen then
  1017.        if opentextfile(strpas(datainname),datainfile) <> 0 then exit;
  1018.  
  1019. {     if not logopen then
  1020.        if createtextfile(strpas(logname),logfile) <> 0 then exit;}
  1021.        if not logopen then
  1022.           if not logappend then
  1023.              begin
  1024.              if createtextfile(strpas(logname),logfile)<>0 then exit;
  1025.              end
  1026.           else
  1027.              if appendtextfile(strpas(logname),logfile)<>0 then exit;
  1028.  
  1029.      logopen     := true;
  1030.      datainopen  := true;
  1031.  
  1032.      reset(datainfile);
  1033.      readln(datainfile); readln(datainfile);
  1034.      lines := countlines(datainfile);
  1035.      readln(datainfile);readln(datainfile); {position correctly...}
  1036.      new(dminput,init(lines,net^.inputfield^.count));
  1037.  
  1038.      spacedline(logfile,'  ------ Run Start ------');
  1039.                                 { Get input data}
  1040.      linestomat(datainfile,DMinput^);
  1041.      writeln(logfile,'DATA MATRIX');
  1042.           printmattofile(logfile,DMinput^);
  1043.      spacedline(logfile,'Network response');
  1044.        for j := 1 to lines do
  1045.           begin
  1046.           dminput^.getrow(j,dvin);
  1047.           net^.feedforward(dvin);
  1048.           setdlgitemint(hwindow,ed_infocount,j,false);
  1049.           printvectofile(logfile,80,dvin^);
  1050.           for i := 1 to net^.outputfield^.count do
  1051.              write(logfile,pneuron(net^.outputfield^.at(i-1))^.output:8:3);
  1052.           writeln(logfile);
  1053.           end;
  1054.        flush(logfile);
  1055.        reset(datainfile);
  1056.  
  1057.        dispose(dminput,done);
  1058.        report('Run Complete');
  1059.        spacedline(logfile,'Run Complete');
  1060.      end
  1061.    else
  1062.        begin
  1063.        messagebeep(mb_iconexclamation);
  1064.        report('Setup not complete !');
  1065.        end;
  1066. end;
  1067. {--------------------------}
  1068. procedure nnwindow.CMdisplay(var mess : tmessage);
  1069. {--------------------------}
  1070. begin
  1071.      messagebox(hwindow,'Not implemented','Bad Luck',mb_OK);
  1072. end;
  1073.  
  1074. {----------------------------}
  1075. procedure nnwindow.BNResetweights(var mess : tmessage);
  1076. {----------------------------}
  1077.  
  1078. begin
  1079.   if (net <> nil) then
  1080.         begin
  1081.         net^.randomweights(0.5);
  1082.         report('Weights Reset to near zero');
  1083.         if datainopen then spacedline(logfile,'----- Reset ------');
  1084.         end
  1085. end;
  1086.  
  1087. {----------------------------}
  1088. procedure nnwindow.BNstopnet(var mess : tmessage);
  1089. {----------------------------}
  1090.                               { Flags the running net to stop }
  1091. begin
  1092.      if running or training then
  1093.         begin
  1094.         running   := false;
  1095.         training  := false;
  1096.         stopped   := true;
  1097.         end
  1098. end;
  1099.  
  1100. {----------------------------}
  1101. procedure nnwindow.BNsavenet(var mess : tmessage);
  1102. {----------------------------}
  1103. begin
  1104.      CMsavefile(mess);
  1105. end;
  1106.  
  1107. {----------------------------}
  1108. procedure nnwindow.BNreadnet(var mess : tmessage);
  1109. {----------------------------}
  1110. begin
  1111.  
  1112.      CMopenfile(mess);
  1113. end;
  1114.  
  1115. {----------------------------}
  1116. procedure nnwindow.BNshakenet(var mess : tmessage);
  1117. {----------------------------}
  1118. begin
  1119.      if (net <> nil) then net^.shake(1.5);
  1120. end;
  1121.  
  1122. {----------------------------}
  1123. procedure nnwindow.BNtrain(var mess : tmessage);
  1124. {----------------------------}
  1125. begin
  1126.      CMTrain(mess);
  1127. end;
  1128.  
  1129.  
  1130. {----------------------------}
  1131. procedure nnwindow.BNSettransfer(var mess : tmessage);
  1132. {----------------------------}
  1133. begin
  1134.     CMSetTransfer(mess);
  1135. end;
  1136.  
  1137. {----------------------------}
  1138. procedure nnwindow.showicon(state : word);
  1139. {----------------------------}
  1140.                              {Indicates the presence of a valid net}
  1141. begin
  1142.      if (state=sw_hide) or (state=sw_show) then
  1143.         showwindow(getdlgitem(hwindow,id_icon),state)
  1144. end;
  1145.  
  1146. {----------------------------}
  1147. procedure nnwindow.report(rep:pchar);
  1148. {----------------------------}
  1149. begin
  1150.      setdlgitemtext(hwindow,id_status,rep);
  1151. end;
  1152.  
  1153. {----------------------------}
  1154. procedure nnwindow.BNdataopen(var mess : tmessage);
  1155. {----------------------------}
  1156. begin
  1157.      cmdatain(mess);
  1158. end;
  1159.  
  1160. {----------------------------}
  1161. procedure nnwindow.BNdataclose(var mess : tmessage);
  1162. {----------------------------}
  1163. begin
  1164.      closedatafile;
  1165. end;
  1166.  
  1167.  
  1168. {----------------------------}
  1169. procedure nnwindow.BNlogopen(var mess : tmessage);
  1170. {----------------------------}
  1171. begin
  1172.      cmdataout(mess);
  1173. end;
  1174.  
  1175.  
  1176. {----------------------------}
  1177. procedure nnwindow.BNlogclose(var mess : tmessage);
  1178. {----------------------------}
  1179. begin
  1180.      closelogfile;
  1181. end;
  1182.  
  1183. {----------------------------}
  1184. procedure nnwindow.BNtrainparams(var mess : tmessage);
  1185. {----------------------------}
  1186. begin
  1187.      CMtrainparams(mess);
  1188. end;
  1189.  
  1190.  
  1191. {----------------------------}
  1192. procedure nnwindow.CMAbout(var mess : tmessage);
  1193. {----------------------------}
  1194. var
  1195.    dlg  : pdialog;
  1196. begin
  1197.      new(dlg,init(@self,'aboutdlg'));
  1198.      application^.execdialog(dlg);
  1199. end;
  1200.  
  1201. {----------------------------}
  1202. procedure nnwindow.CMSlughelp(var mess : tmessage);
  1203. {----------------------------}
  1204. begin
  1205.      winhelp(hwindow,'slughlp3.hlp',help_contents,0);
  1206. end;
  1207.  
  1208.    {---------------------- SPECDIALOG PROCEDURES ------------------------}
  1209.  
  1210. {----------------------------}
  1211. procedure specdialog.zerocounts(var mess : tmessage);
  1212. {----------------------------}
  1213. var
  1214.    zero : pchar;
  1215. begin
  1216.     zero       := '0';
  1217.     senddlgitemmsg(id_netspecin, wm_settext,0,longint(zero) );
  1218.     senddlgitemmsg(id_netspecout, wm_settext,0,longint(zero) );
  1219.     senddlgitemmsg(id_netspechidden, wm_settext,0,longint(zero) );
  1220. end;
  1221.  
  1222.  
  1223.  
  1224.  
  1225.  
  1226.    {---------------------- APPLICATION PROCEDURES -----------------------}
  1227.  
  1228. {----------------------------}
  1229. procedure ANNpgm.initmainwindow;
  1230. {----------------------------}
  1231. begin
  1232.      mainwindow := new(pNNwindow,init(nil,'ALLIN'));
  1233. end;
  1234.  
  1235.  
  1236.  
  1237. {======================================== MAIN ====================================================}
  1238. var
  1239.    demo         : ANNpgm;
  1240.    space        : longint;
  1241.    temp         : array[0..20] of char;
  1242. begin
  1243.      demo.init('ANN Program 2');
  1244.      demo.run;
  1245.      demo.done;
  1246.  
  1247. end.
  1248.  
  1249. {---------------------------------------  END  -----------------------------------------------------}
  1250.