#!/bin/usr/perl;
# GAUSS TO MATLAB PERL SCRIPT (Ver. 1.0) - FOR GAUSS PROGRAM SCRIPTS (which
# start with the new command) OR PROCEDURES WITH A SINGLE MAIN FUNCTION
#
#
# USAGE: perl gtoml gauss_file_name > output_file_name
#
# where: gauss_file_name is the source code to translate (eg. program.g)
#        output_file_name is the m-file created
#
#
# WRITTEN BY CAMERON ROOKLEY, DEPT. OF FINANCE, UNIV. OF ARIZONA
# e-mail:    rookley@u.arizona.edu
# homepage:  http://www.goodnet.com/~dh74673/home.htm
# GTOML homepage: http://www.goodnet.com/~dh74673/gtoml.htm
#
## THE FIRST COMMENT LINE IS UNIX SPECIFIC, WINTEL SYSTEMS WILL IGNORE IT
# first check to see if gauss "new" command issued
# new indicates program is a script
# absense of new indicates it is a self-contained procedure
# also in first pass toss proc() and retp() statements into an array
# and check to see if any global declaration files are need due to a
# #include statement
$pcasedum=0;  #dummy to print main cases line by line for debugging 
$newdum=0;    #dummy to flag whether the gauss 'new' command issued
$nuke1proc=0; #dummy to deal with where 1st procedure printed
$incldum=0;   #dummy indicating whether an #include file is found
$pi=0; $ri=0;  $ei=0; #indices for number of proc,retp,endp statements
$frethit=0;   #used to help count number of retp statements in each proc
# SECTION 1  obtain key information for setting up functions
while (<>){
 if (/\s?new\;/){ $newdum=1;}
 if (/\s?proc.*\;/){
    $proc[$pi]= $_;
    ++$pi;
    }
 if (/\s?retp.*\;/ || /\s?retp\;/){
    $rets[$ri]= $_;
    if ($frethit==0){
     $mretdum[$ri]=0; # multiple return dummy
     $firstretdum[$ri]=1; # first return dummy
     }
    else{$mretdum[$ri-1]=1;
         $mretdum[$ri]=1;
         $firstretdum[$ri]=0; # first return dummy
         }
    ++$ri;
    $frethit=1;} # first return hit flag
 if (/endp/){ $frethit=0; ++$ei;};
 if (/\#include/){
        $decdum=1;
        $incfname=$_;
        $incfname =~ s/(\#include )(.*)(\;)/\2/;
        $incfname =~ s/(\#include )(.*)/\2/; # in the event ; not incl.
        # drop any path or drive letter associated with new dec filename
        if ($incfname =~ /\\/){
           $incfname =~ s/(.*)(\\)(.*)/\3/;}
        if ($incfname =~ /\:/){
           $incfname =~ s/(.*)(\:)(.*)/\3/;}
        $outfname=$incfname;
        $outfname =~ s/(.*)(\..*)/\1d\.m/;
        $outfname =~ s/\n//;
  }
 }
 close(ARGV);
 open(ARGV);
#SECTION 2
# initilize arrays for procs and rets strings
  if ($ei != $pi){
          print "Error: number of proc( ) statements ".$pi." does not match number
          of endp\n statements!!!".$ei."\n";
          exit;}
  $retind=0;
  $nrets=$ri-1;
  $i=0; $ri=0;
  while ($i <= $nrets)
  {
     $rets[$i] =~ s/retp\((.*)\,(.*)\)\;/\[\1\,\2\]/;
     $rets[$i] =~ s/retp\((.*)\)\;/\1/;
     $rets[$i] =~ s/retp\;//;
     $rets[$i] =~ s/\n//;
     $rets[$i] =~ s/\/\*.*\*\///;
     if ($rets[$i] =~ /[\(\)\~\|\+\-\*\/\^\>\<\=]/ || $mretdum[$i]==1)
     {
      if ($firstretdum[$i]==1){
        $compos=index($rets[$i],",");
        if ($compos != -1)
           {
           # grab whole string ['s and all 
           $reststring=substr($rets[$i],$compos+1,length($reststring)-1);
           # first chunk up to first comma
           $retarg="ret".$retind."=".substr($rets[$i],0,$compos);
           $newretarg=&transproc($retarg);
           $spec[$i]=$newretarg;
           $retind=$retind+1;
           $compos=index($reststring,",");
           while ($compos !=-1)
                {
                $retarg="ret".$retind."=".substr($rets[$i],0,$compos);
                $newretarg=&transproc($retarg);
                $spec[$i]=$spec[$i].$newretarg;
                $reststring=substr($reststring,$compos+1);
                $compos=index($reststring[$i],",");
                $retind=$retind+1;
                }
           $retarg="ret".$retind."=".$reststring;
           $newretarg=&transproc($retarg);
           $spec[$i]=$spec[$i].$newretarg;
           $spec[$i]=~ s/\[//;
           $spec[$i]=~ s/\]//;
           $rets[$i]="["."ret".$ri.",";
           $ri=$ri+1;
           while ($ri<($retind))
                {
                $rets[$i]=$rets[$i]."ret".$ri.",";
                $ri=$ri+1;
                }
           $rets[$i]=$rets[$i]."ret"."$ri"."]";
        }
        else{
             $spec[$i]="ret".$retind."=".$rets[$i].";\n";
             $rets[$i]="ret".$ri;}
             $retind=$retind+1; $ri=$ri+1;
             $lastspec=$spec[$i];
             $lastret=$rets[$i];
       }
       else{ $spec[$i]=$lastspec;
             $rets[$i]=$lastret;}

     }
     else{$spec[$i] = "";}
     $i=$i+1;
     }

 $i=0; $fni=0;
 #SECTION 3
 while ($i <= $nrets){
    $proc[$i] =~ s/proc\(.*\)\=(.*\(.*\))\;/\1/;
    $proc[$i] =~ s/proc(.*\(.*\))\;/\1/;
    $proc[$i] =~ s/proc\(.*\)\=(\w.*)\;/\1/;
    $proc[$i] =~ s/proc\s*(\w*)\;/\1/;
    # remove and identify any function names passed as arguments
    # start mining for &'s 
    if ($proc[$i] =~ /\&/){
     $nfnames[$i]=0;
     while ($proc[$i] =~ /\&/){
      if ($proc[$i] =~ /\,\&(\w*)(\)|\,)/){
       $proc[$i] =~ s/\,\&(\w*)(\)|\,)/\,\1\2/;
       $fnamestr[$fni]=$1;
       if ($nfnames[$i]==0){
        $prfnames[$i]=$1;}
       else{$prfnames[$i]=$prfnames[$i]." and ".$1;}
       $nfnames[$i]=$nfnames[$i]+1;
       $fni=$fni+1;}
      elsif ($proc[$i] =~ /\(\&(\w*)(\)|\,)/){
       $proc[$i] =~ s/\(\&(\w*)(\)|\,)/\(\1\2/;
       $fnamestr[$fni]=$1;
       $prfnames[$i]=" ".$prfnames[$i].$1;
       $fni=$fni+1;}
      }
    }
    else{$prfnames[$i]="";
         $nfnames[$i]=0;}
    $proc[$i] =~ s/proc\(.*\)\=(.*\(.*\))\;/\1/;
    $proc[$i] =~ s/proc (.*\(.*\))\;/\1/;
    $proc[$i] =~ s/proc\(.*\)\=(\w*)\;/\1/;
    $proc[$i] =~ s/proc\s*(\w*)\;/\1/;
    # purge line feed on procedure declaration
    $proc[$i] =~ s/\n//;
    # purge comments attached to procedure declaration
    $proc[$i] =~ s/\/\*.*\*\///;
    $i=$i+1;
   }
  # if newdum=0 assume code is a procedure and write main function call line
  # also write Matlab specific messages to file header in comments
 if ($newdum == 0){
  if ($proc[0] =~ /\(.*\)/){
   print "function ".$rets[0]."=".$proc[0]."\n";
   print "%  ".$rets[0]."=".$proc[0]."\n";
  }else{
   print "function ".$proc[0]."\n";
   print "%  ".$proc[0]."\n";
  }
  print "%\n";
  print "%  Add brief description for function in line above for Matlab help searches\n";
  if ($prfnames[$0] ne ""){
   if ($nfnames[$0]>1){
   print "% Note:  ".$prfnames[$0]." are function names and must be passed as strings\n";
   }else{
   $prfnames[$0]=~ s/and//;
   print "% Note:  ".$prfnames[$0]." is a function name and must be passed as a string\n";
   }
  }
  if ($decdum==1){
  $outfname=~ s/\n//;
  print "%\n";
  print "% NOTE: YOU MUST ISSUE THE COMMAND: \"run ".$outfname."\"\n";
  print "%       TO INITIALIZE GLOBAL VARIABLES BEFORE CALLING THIS PROCEDURE!!! \n";
  print "%\n";}
  $procind=1;
  $nuke1proc=1;}
  $retind=0;
  $j=0; $k=0;
  # set up a main return index
  while ($j<$ri+1){
    if ($firstretdum[$j]==1)
    { $mainret[$k]=$rets[$j];
      ++$k;
      ++$j;}
    else{++$j;}}

###################################################################
# START OF MAIN PROCEDURE IS HERE - GO THROUGH COMMENTS AND CODE ONE
# LINE AT A TIME, SEPERATING CODE AND COMMENT FRAGMENTS
# CALLING TRANSCODE TO TRANSLATE CODE TO GAUSS ETC.

$comflag=0; # open comment flag
while (<>){
 if ($newdum==0)
 {
  if ($nuke1proc==1) #nuke1proc is a dummy to nuke 1st proc & do nothing
                     #as replacement already taken care of in header
  {
    if (/proc.*\;/)
     {
     s/proc\(.*\)\=(.*\(.*\))\;//;
     s/proc (.*\(.*\))\;//;
     s/proc\(.*\)\=(\w*)\;//;
     s/proc\s*(\w*)\;//;
     $nuke1proc=0;}
  }
  else{
     if (/proc.*\;/)
     {
     print "function ".$mainret[$procind]."=".$proc[$procind]."\n";
     if ($prfnames[$procind] ne ""){
        if ($nfnames[$procind]>1){
          print "% Note:  ".$prfnames[$procind]." are function names and must be passed as strings\n";
        }else{
          $prfnames[$procind]=~ s/and//;
           print "% Note:  ".$prfnames[$procind]." is a function name and must be passed as strings\n";
           }
     }
     s/proc\(.*\)\=(.*\(.*\))\;//;
     s/proc (.*\(.*\))\;//;
     s/proc\(.*\)\=(\w*)\;//;
     s/proc\s*(\w*)\;//;
     $procind=$procind+1;
     }
  }
 }
 if (/retp/)
     {
     print $spec[$retind];
     s/\s?retp\(.*\).*//;
     s/\s?retp\;//;
     $retind=$retind+1;
     }
 s/\s?endp\s?\;/\/\* End of function \*\//;
 if ( /^(\/\*|\s \/\*|\s\/\*|\s *\/\*)/ && (/(\*\/\s |\*\/)$/) && (/;/==0) &&
  ($comflag==0)) {
  #closed comment
  if ($pcasedum==1){ print "case1: \n"; }
  $opcomind=index($_,"/*");
  $chcom=substr($_,$opcomind+3);
  $clcomind=index($chcom,"*/");
  $chcom=substr($chcom,0,$clcomind-1);
  print "% ".$chcom;
  print "\n";
  $comflag=0;
  }
 elsif (/^(\/\*|\s \/\*|\s\/\*|\s *\/\*)/ && ((/;/)==0) && ($comflag==0))  {
  #open left comment
  if ($pcasedum==1){ print "case2: \n";}
  $opcomind=index($_,"/*");
  $chcom=substr($_,$opcomind+3);
  print "% ".$chcom;
  $comflag=1;
  }                        
 elsif ((/(\*\/\s |\*\/)$/)  && /\/\*/==0 && /;/==0 && ($comflag==1))  {
  # closing right comment
  if ($pcasedum==1){ print "case3: \n";}
  $opcomind=index($_,"*/");
  if (opcomind>2){
     $chcom=substr($_,$opcomind-2);
     print "% ".$chcom;}
  else {
     print "% "; }
     print "\n";
  $comflag=0;
  }                     
 elsif (/\/\*/ && (/(\*\/\s |\*\/)$/) && (/;/ == 1) && ($comflag==0)){
  #code-closed comment
  if ($pcasedum==1){ print "case4: \n";}
  $comflag=0;
  $comind=index($_,"/*");
  $code=substr($_,0,$comind-1);
  $comm=substr($_,$comind,length($_));
  $comm =~ s/\/\*/\%/g; 
  $comm =~ s/\*\///g;
  $newcode=&transproc($code);
  print $newcode.$comm;
  }
 elsif (/\/\*/ && (/\*\//==0) && (/;/ == 1) and ($comflag==0))  {
  #code followed by open left comment
  if ($pcasedum==1){ print "case5: \n";}
  $comflag=1;
  $comind=index($_,"/*");
  $code=substr($_,0,$comind-1);
  $comm=substr($_,$comind,length($_));
  $comm=~s/\/\*/\%/g;
  $comm=~s/\*\\//g;
  $newcode=&transproc($code);
  print $newcode.$comm;
  }
 elsif ((/\/\*/==0) && (/\*\//==1) && (/;$/==1) and ($comflag==0))  {
  #closing right comment followed by completed code 
  if ($pcasedum==1){ print "case6: \n";}
  $comflag=0;
  $comind=index($_,"/*");
  $comm=substr($_,0,$comind-1);
  $comm=~s/\/\*/\%/g;
  $comm=~s/\*\\//g;
  $code=substr($_,$comind+2,length($_)-length($comm));
  $newcode=&transproc($code);
  print $comm;
  print "\n";
  print $newcode;
  }
 elsif ((/\/\*/==0) && (/\*\//==0) && (/(;\s |;)$/) && ($comflag==0))  {
  if ($pcasedum==1){ print "case7: \n";}
  #single line of code
  $comflag=0;
  $newcode=&transproc($_);
  print $newcode;
  }
 elsif ((/\/\*/==0) && (/\*\//==0) && (/;/==0) && ($comflag==0) && ($_ ne "\n")
    && ($_ ne ""))
  {
  if ($pcasedum==1){ print "case8: \n";}
  #incomplete line of code continued on next line 
  $comflag=0;
  $newcode=&transproc($_);
  $newcode =~ s/\n//;
  if ($newcode =~ /\;/){
    print $newcode;}
  else{
   if ($newcode =~ /\w/){
    print $newcode."...";
    print "\n";}}
  }
 elsif ($_ eq ""){
  if ($pcasedum==1){ print "case9: \n";}
  if ($comflag==1){
     print "% \n";}
  else {
     print "\n";}
  }                         
 elsif ((/\*\//==0) && ($comflag==1))
  {#continuation of a comment
  if ($pcasedum==1){ print "case10: \n";}
  print "% ".$_;
  $comflag=1;
  }
 elsif ((/\*\//==1) && (/\/\*/==1) && index($_,"/*")<index($_,"*/") &&
      ($comflag==1))
  {#continuation of comment in the presense of nested comment
  if ($pcasedum==1){ print "case11: \n";}
  print "% ".$_;
  $comflag=1;
  }
 elsif ((/\/\*/==0) && (/\*\//==0) && (/;/==0) && ($comflag==0)){
  #completion of code from previous line
  if ($pcasedum==1){ print "case12: \n";}
  $newcode=&transproc($_);
  print $newcode;
  $comflag=0;
  }
 else {
  if ($pcasedum==1){ print "case13: \n";}
  print "% UNKNOWN LINE STRUCTURE ENCOUNTERED THE FOLLOWING\n";
  print "% LINE OF CODE WAS NOT TRANSLATED:\n";
  print $_;
  }
}
close(ARGV); # close standard input file
exit;

################################################################
# MAIN ENGINE TO TRANSLATE GAUSS CODE TO MATLAB
# SEVERAL SIMPLE SEARCH AND REPLACES
# FOLLOWED BY AN UGLY SECTION WHICH DEALS WITH VERT. AND HORIZ.
# CONCATINATION

sub transproc{
    #purge extraneous spaces
    $thiscode=@_[0];
    if ($thiscode =~ /^\s/==1){
     $initspace=$thiscode;
     $initspace =~ s/(^\s?)(\S*)/\1/g;}
    else{
     $initspace="";
     }
    while ($thiscode =~/\W\s/){
         $thiscode =~ s/(\W)(\s)/\1/;
         }
    while ($thiscode =~/\s\W/){
         $thiscode =~ s/\s(\W)/\1/;
         }
    $initspace =~ s/\n//g;
    $initspace =~ s/\S*//g;
    $thiscode= $initspace.$thiscode;
    $thiscode = $thiscode."\n";
    # convert code fragments to lower case
    $thiscode =~ tr/A-Z/a-z/;
    #nuke local declarations with and without carriage returns
    $thiscode =~ s/local .*;\n//ig;
    $thiscode =~ s/local .*;//ig;
    # search for any include (global declaration) files
    if (/\#include/){
        $incfname=$_;
        $incfname =~ s/(\#include\;)(.*)(\;)/\2/;
        $incfname =~ s/(\#include)(.*)/\2/; # in the event ; not incl.
        $decline=&decproc($incfname);
        $thiscode=$decline;
        #if (($thiscode=~ /\n/)==0){ $thiscode=$thiscode."\n";}
        }
    if ($fni>0)
     {
     $i=0;
     while ($i <= $fni-1){
      $thiscode =~s/($fnamestr[$i])\(/feval\(\1\,/;
      $i=$i+1;
      }
    }
    # change function names passed to functions to strings
    if ($thiscode =~ /\w\(.*\&\w*\W?\)/){
       $thiscode =~ s/(\w\(.*)(\&)(\w*)(\W?\))/\1\'\3\'\4/;
     }
    # change square brackets to round for matrix indexing
    # do this before {'s changed to ]
    $thiscode =~ s/\[/\(/g;
    $thiscode =~ s/\]/\)/g;
    #change notation for matrix assignments
    $thiscode =~ s/\{(.*)\}\s?\=/\[\1\]\=/;
    if ($thiscode =~ /\=\s?\{(.*)\}/){
       $lbind=index($thiscode,"{");
       $rbind=index($thiscode,"}");
       $argum=substr($thiscode,$lbind+1,$rbind-$lbind);
       $argum =~ s/\,/\;/;
       $thiscode=substr($thiscode,0,$lbind)."[".$argum."]".
                 substr($thiscode,$rbind+1);
       print "newline:";
       }
    #simple search and replacements
    # FEEL FREE TO ADD YOUR OWN REPLACEMENTS IN THIS SECTION
    $thiscode =~ s/sumc/sum/ig;
    $thiscode =~ s/prodc/prod/ig;
    $thiscode =~ s/meanc/mean/ig;
    $thiscode =~ s/dos\s?\^(\w*)\;/dos\(\1\)\;/ig;
    $thiscode =~ s/dos\s?\"(.*)\"\;/dos \(\'\1\'\)\;/ig;
    $thiscode =~ s/seqa\((.*)\,(.*)\,(.*)\)/\(\1\:\2:\3\)/ig;
    $thiscode =~ s/cumsumc/cumsum/ig;
    $thiscode =~ s/cumprodc/cumprod/ig;
    $thiscode =~ s/meanc/mean/ig;
    $thiscode =~ s/stdc/std/ig;
    $thiscode =~ s/minc/min/ig;
    $thiscode =~ s/maxc/max/ig;
    $thiscode =~ s/sortc/sortrows/ig;
    $thiscode =~ s/rndu/rand/ig;
    $thiscode =~ s/eigv/eig/ig;
    $thiscode =~ s/maxc/max/ig;
    $thiscode =~ s/cdfn\((.*)/normcdf\(\1,0,1/ig;
    $thiscode =~ s/pdfn\((.*)/normpdf\(\1,0,1/ig;
    $thiscode =~ s/title\(\"(.*)\"\)/title\(\'\1\')/ig;
    $thiscode =~ s/xlabel\(\"(.*)\"\)/xtitle\(\'\1\')/ig;
    $thiscode =~ s/ylabel\(\"(.*)\"\)/ytitle\(\'\1\')/ig;
    $thiscode =~ s/zlabel\(\"(.*)\"\)/ztitle\(\'\1\')/ig;
    $thiscode =~ s/title\((.*)\)/title\(\1\)/ig;
    $thiscode =~ s/xlabel\((.*)\)/xtitle\(\1\)/ig;
    $thiscode =~ s/ylabel\((.*)\)/ytitle\(\1\)/ig;
    $thiscode =~ s/zlabel\((.*)\)/ztitle\(\1\)/ig;
    $thiscode =~ s/(\s*)(xy)(\(.*)/plot\3/ig;
    $thiscode =~ s/(\s*)(xyz)(\(.*)/plot3\3/ig;
    $thiscode =~ s/^(xy)(\(.*)/plot\2/ig;
    $thiscode =~ s/^(xyz)(\(.*)/plot3\2/ig;
    $thiscode =~ s/(surface)(\(.*)/surf\2/ig;
    $thiscode =~ s/zlabel\((.*)\)/ztitle\(\1\)/ig;
    $thiscode =~ s/\[\.,/\[:,/g;
    $thiscode =~ s/\,\.\]/\,\:\]/g;
    $thiscode =~ s/endif/end/ig;
    $thiscode =~ s/endo/end/ig;
    $thiscode =~ s/do while/while/ig;
    $thiscode =~ s/and/&/ig;
    $thiscode =~ s/\Wor\W/\|/ig;
    $thiscode =~ s/\!\=/~=/ig;
    $thiscode =~ s/\.</</ig;
    $thiscode =~ s/\.>/>/ig;
    $thiscode =~ s/\.\=\=/\=\=/ig;
    $thiscode =~ s/(\W)(le)(\W)/\1\<\=\3/ig;
    $thiscode =~ s/(\W)(ge)(\W)/\1\>\=\3/ig;
    $thiscode =~ s/(\W)(\.le)(\W)/\1\<\=\3/ig;
    $thiscode =~ s/(\W)(\.ge)(\W)/\1\>\=\3/ig;

 #### CONCATINATION SECTION
 # find the index of any |'s if they exist
 $pos=index($thiscode,"|");
 while ($pos != -1) # if |'s exist continue
 {
     $lbpos=$pos-1; # initialize left [ bracket to fall to left of |
     # if position to immed. left of | is a ) or ")'" start counting L&R )'s
   if ( (substr($thiscode,$lbpos,1) eq ")") ||
        (substr($thiscode,$lbpos-1,2) eq ")'")){
        if (substr($thiscode,$lbpos,1) eq ")"){
           $nrb=1;
           $lbpos=$lbpos-1;}
        elsif (substr($thiscode,$lbpos,1) eq "'"  &&
               substr($thiscode,$lbpos-1,1)){
           $nrb=1;
           $lbpos=$lbpos-2;
           }
         else{$lbpos=$lbpos-1;}
         $nlb=0;
      while ($nrb>$nlb){
         if (substr($thiscode,$lbpos,1) eq ")"){
            $nrb=$nrb+1; }
         if (substr($thiscode,$lbpos,1) eq "("){
            $nlb=$nlb+1; }
         $lbpos=$lbpos-1;
       }
   }
     # once [ position pushed beyond last bracket match start looking for
     # first non-word to the left
   $cont=1;
   while ($cont==1){
         if ((substr($thiscode,$lbpos,1) =~/\W/)
             && (substr($thiscode,$lbpos,1) ne "'"))
         {
            $cont=0;}
         else{
            $lbpos=$lbpos-1;}
    }
     # insert left bracket at appropriate position, truncate "newstring" to first |
     # create reststring which consists of what follows
    if (substr($thiscode,$lbpos,1) eq "("){
       #start counting brackets and drop ] immediately before match
       $newstring=substr($thiscode,0,$lbpos+1)."[";
       $reststring=substr($thiscode,$lbpos+1);
       $nlb=1; $nrb=0;
       $cont=1;
       while ($cont==1){
          if (substr($reststring,0,1) eq ")"){$nrb=$nrb+1;}
          if (substr($reststring,0,1) eq "("){$nlb=$nlb+1;}
          if (substr($reststring,0,1) eq "|"){
             $newstring=$newstring.";";
             $reststring=substr($reststring,1);}
          else{
             $newstring=$newstring.substr($reststring,0,1);
             $reststring=substr($reststring,1);}
          if ($nlb==$nrb){$thiscode=substr($newstring,0,length($newstring)-1)
           ."]".substr($newstring,length($newstring)-1,1).$reststring;
                       $cont=0;}
       }
       $pos=index($thiscode,"|"); # check for more | left off by ~
       }
    else{
    $newstring=substr($thiscode,0,$lbpos+1)."[".substr($thiscode,$lbpos+1,$pos-$lbpos-1).";";
    $reststring=substr($thiscode,$pos+1);
   
 $cont=1;
   $rbpos=0;
 while ($cont==1)
   {
   # check to see if any more |'s exist before next ~ or terminating ;
   $pos=index($reststring,"|");
   # if not, initialize right bracket position for ] to immed. right last |
   if ($pos==-1){
      $cont=0;}
   else{
      # if more |'s exist, check to see if ~ exist
      if ( (index($reststring,"~")<index($reststring,"|"))
        && index($reststring,"~") != -1)
      {
      $cont=0;}
      else{
      # if not keep adding chunks to "newstring"
      $newstring=$newstring.substr($reststring,0,$pos).";";
      $reststring=substr($reststring,$pos+1);
    }}}
   $rbpos=0;
   $nrb=0; $nlb=0;
   # ] position is currently to immediate right of last |
   # check to see if this position is a left bracket
   if (substr($reststring,$rbpos,1) eq "("){
      # if it is, count brackets and push ] position to right
      $nrb=0; $nlb=1; $rbpos=$rbpos+1;
      while ($nlb>$nrb){
         if (substr($reststring,$rbpos,1) eq ")"){
            $nrb=$nrb+1; 
            }
         if (substr($reststring,$rbpos,1) eq "("){
            $nlb=$nlb+1; 
            }
         $rbpos=$rbpos+1
       }
       if (substr($reststring,$rbpos,1) eq "'"){
         $rbpos=$rbpos+1;}
       
   }
   $cont=1;
   while ($cont==1){
            # if non-word hit piece everything together
         if (substr($reststring,$rbpos,1) =~ /\(/){
             $rbpos=$rbpos+1;
             $nlb=$nlb+1;}
         if (substr($reststring,$rbpos,1) =~ /\)/){
             $rbpos=$rbpos+1;
             $nrb=$nrb+1;}
         if (substr($reststring,$rbpos,1) =~/\W/){
               if ($nlb==$nrb){
                 $cont=0;
                 if (substr($reststring,$rbpos,1) eq "'"){
                    $rbpos=$rbpos+1;}
                 $thiscode=$newstring.substr($reststring,0,$rbpos).
                "]".substr($reststring,$rbpos);
                }
               else{$rbpos=$rbpos+1;}
             }
            # else keep sliding right
         else{
            $rbpos=$rbpos+1;}
         }
    
    } # this ends bracket searching branch
    $pos=index($thiscode,"|"); # check for more | left off by ~
}

# now do horizontal concatination
# may have to count square brackets as well
 # find the index of any ~'s if they exist
 $pos=index($thiscode,"~");
 while ($pos != -1) # if ~'s exist continue
 {
     $lbpos=$pos-1; # initialize left [ bracket to fall to left of ~
     # if position to immed. left of ~ is a ) start counting L&R )'s
   if ( (substr($thiscode,$lbpos,1) eq ")") ||
        (substr($thiscode,$lbpos-1,2) eq ")'")){
        if (substr($thiscode,$lbpos,1) eq ")"){
           $nrb=1;
           $lbpos=$lbpos-1;}
        elsif (substr($thiscode,$lbpos,1) eq "'"  &&
               substr($thiscode,$lbpos-1,1)){
           $nrb=1;
           $lbpos=$lbpos-2;
           }
         else{$lbpos=$lbpos-1;}
         $nlb=0;
       while ($nrb>$nlb){
         if (substr($thiscode,$lbpos,1) eq ")"){
            $nrb=$nrb+1; }
         if (substr($thiscode,$lbpos,1) eq "("){
            $nlb=$nlb+1; }
         $lbpos=$lbpos-1;
       }
   }
     # once [ position pushed beyond last bracket match start looking for
     # first non-word to the left
   $cont=1;
   while ($cont==1){
         if ((substr($thiscode,$lbpos,1) =~/\W/)
             && (substr($thiscode,$lbpos,1) ne "'")){
            $cont=0;}
         else{
            $lbpos=$lbpos-1;}
    }
     # insert left bracket at appropriate position, truncate "newstring" to first ~
     # create reststring which consists of what follows
    if (substr($thiscode,$lbpos,1) eq "("){
       #start counting brackets and drop ] immediately before match
       $newstring=substr($thiscode,0,$lbpos+1)."[";
       $reststring=substr($thiscode,$lbpos+1);
       $nlb=1; $nrb=0;
       $cont=1;
       while ($cont==1){
          if (substr($reststring,0,1) eq ")"){$nrb=$nrb+1;}
          if (substr($reststring,0,1) eq "("){$nlb=$nlb+1;}
          if (substr($reststring,0,1) eq "~"){
             $newstring=$newstring." ";
             $reststring=substr($reststring,1);}
          else{
             $newstring=$newstring.substr($reststring,0,1);
             $reststring=substr($reststring,1);}
          if ($nlb==$nrb){$thiscode=substr($newstring,0,length($newstring)-1)
           ."]".substr($newstring,length($newstring)-1,1).$reststring;
                       $cont=0;}
       }                                                                
       $pos=index($thiscode,"~"); # check for more ~ left off by ~
       }
    else{
    $newstring=substr($thiscode,0,$lbpos+1)."[".substr($thiscode,$lbpos+1,$pos-$lbpos-1)." ";
    $reststring=substr($thiscode,$pos+1);


 $cont=1;
   $rbpos=0;
 while ($cont==1)
   {
   # check to see if any more ~'s exist before next ~ or terminating ;
   $pos=index($reststring,"~");
   # if not, initialize right bracket position for ] to immed. right last ~
   if ($pos==-1){
      $cont=0;}
   else{
      # if more ~'s exist, check to see if ~ exist
      if ( (index($reststring,"~")<index($reststring,"~"))
        && index($reststring,"~") != -1)
      {
      $cont=0;}
      else{
      # if not keep adding chunks to "newstring"
      $newstring=$newstring.substr($reststring,0,$pos)." ";
      $reststring=substr($reststring,$pos+1);
    }}}
   # ] position is currently to immediate right of last ~
   # check to see if this position is a left bracket
   $rbpos=0;
   $nrb=0; $nlb=0;
   if (substr($reststring,$rbpos,1) eq "("){
      # if it is, count brackets and push ] position to right
      $nrb=0; $nlb=1; $rbpos=$rbpos+1;
      while ($nlb>$nrb){
         if (substr($reststring,$rbpos,1) eq ")"){
            $nrb=$nrb+1; 
            }
         if (substr($reststring,$rbpos,1) eq "("){
            $nlb=$nlb+1; 
            }
         $rbpos=$rbpos+1
       }
       if (substr($reststring,$rbpos,1) eq "'"){
         $rbpos=$rbpos+1;}
   }
   # search for first non-word to right of ~_, or last matching )
   $cont=1;
   while ($cont==1){
            # if non-word hit piece everything together
         if (substr($reststring,$rbpos,1) =~ /\(/){
             $rbpos=$rbpos+1;
             $nlb=$nlb+1;}
         if (substr($reststring,$rbpos,1) =~ /\)/){
             $rbpos=$rbpos+1;
             $nrb=$nrb+1;}
         if (substr($reststring,$rbpos,1) =~/\W/){
               if ($nlb==$nrb){
                 $cont=0;
                 if (substr($reststring,$rbpos,1) eq "'"){
                    $rbpos=$rbpos+1;}
                 $thiscode=$newstring.substr($reststring,0,$rbpos).
                "]".substr($reststring,$rbpos);
                }
               else{$rbpos=$rbpos+1;}
             }
            # else keep sliding right
         else{
            $rbpos=$rbpos+1;}
         }
   
    } # this ends bracket searching branch
    $pos=index($thiscode,"~"); # check for more ~ left off by ~
}
# convert != to ~= after concat. section for obvious reasons
$thiscode =~ s/\!\=/\~\=/;
# convert double qutoes strings to single quote
# do last to avoid transpose confusion
$thiscode =~ s/\"/\'/g;
return $thiscode;}

############################################################
# declaration file subroutine
############################################################
sub decproc{
 $incfname=@_[0];
 # CONVERT DECLARATION FILES INTO A SERIES OF GLOBAL DECLARATIONS
 # USE global var; within code, and global var; var=value within
 # new dec file named {origname}d.m"
 $incfname =~s/;//;
 open (DECIN,$incfname);
 # drop any path or drive letter associated with new dec filename
 if ($incfname =~ /\\/){
   $incfname =~ s/(.*)(\\)(.*)/\3/;}
 if ($incfname =~ /\:/){
   $incfname =~ s/(.*)(\:)(.*)/\3/;}
 # change the file extension and drop any line feed
 $outfname=$incfname;
 $outfname =~ s/(.*)(\..*)/\1d\.m/;
 open (DECOUT,">".$outfname);
 $decline="";
 while (<DECIN>){
    $thisdecline=$_;
    if (/declare/){
     $fileline =~ s/declare matrix//;
     $fileline =~ s/declare string//;
     s/(\/\*)(.*)(\*\/)(\n)/% \2\4/;
     if (/\s?\w*\s?\!\=\s?\.*/){
       /(\s?)(\w*)(\s?\!\=)(.*)/;
       $fileline="global ".$2."; ".$2."=".$4."\n";
       $thisdecline="global ".$2.";\n";}
     elsif (/\s?\w*\s?\=\s?\.*/){
       /(\s?)(\w*)(\s?\=)(.*)/;
       $fileline="global ".$2."; ".$2."=".$4."\n";
       $thisdecline="global ".$2.";\n";}
     elsif (/\s?\w*\s?\?\=\s?\.*/){
       /(\s?)(\w*)(\s?\?\=)(.*)/;
       $fileline="global ".$2."; ".$2."=".$4."\n";
       $fileline =~ s/\n//;
       $thisdecline="global ".$2.";\n";}
       print DECOUT $fileline;
       $decline=$decline.$thisdecline;
    }
    else{s/\/\*//;
         s/\*\///;
         # change file extensions in declaration header
         s/\.dec/d\.m/;
         s/(\w)\.g/\1\.m/;
         s/\.DEC/d\.m/;
         s/(\w)\.G/\1\.m/;
         print DECOUT "%".$_;}

    }
 close(DECOUT);
   if (($decline =~ /\;/)==0){
      $decline=$decline.";";}
 return $decline;}