#!/bin/usr/perl;
# GAUSS TO MATLAB PERL SCRIPT (Ver. 1.0) - CASE OF MULTIPLE FUNCTIONS
# IN SOURCE
#
# USAGE: perl gtomlmf gauss_file_name > output_file_name
#
# where "> output_file_name" is optional as individual m-files will be created
# for each individual function contained in the gauss input file name,
# with names given as function_name.m
#
# 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
#
#
#
# SEPERATE M FILES WILL BE CREATED FOR EACH FUNCTION FOUND
# WITHIN THE INPUT FILE
# SEE GTOML FOR SINGLE M-FILE CREATION
#######################################################
# the first comment line is Unix specific, Wintel systems will ignore it
# do a first pass and toss proc() and retp() statements into an array
# also check to see if any global declaration files are needed due to a
# #include statement
$pcasedum=0; # used to print main cases line by line for debuggin 
$pi=0; $ri=0; $ei=0; #indices for number of procs,retps,endp
$frethit=0;  # dummy for first retp encountered
$wrdecafn=0; # dummy indicating whether to write global dec's after fns
$decline=""; # line to write after function dec. if $wrdecafn=1
# SECTION 1  # do a first pass through source and get key info
while (<>){
 if (/\s?new\;/){ print "use gtoml perl script for processing Gauss scripts";
                  exit;}
 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/){
        $wrdecafn=1; # write global declaration after function dummy
        $decdum=1;
        $incfname=$_;
        $incfname =~ s/(\#include )(.*)(\;)/\2/;
        $incfname =~ s/(\#include )(.*)/\2/;
        # drop any path or drive letter associated with new dec filename
        if ($incfname =~ /\\/){
           $incfname =~ s/(.*)(\\)(.*)/\3/;}
        if ($incfname =~ /\:/){
           $incfname =~ s/(.*)(\:)(.*)/\3/;}
        $decline=&decproc($incfname);
        $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
           $spec[$i]="ret".$retind."=".substr($rets[$i],0,$compos).";\n";
           $retind=$retind+1;
           $compos=index($reststring,",");
           while ($compos !=-1)
                {
                $spec[$i]=$spec[$i]."ret".$retind."=".substr($reststring,0,$compos).";\n";
                $reststring=substr($reststring,$compos+1);
                $compos=index($reststring[$i],",");
                $retind=$retind+1;
                }
           $spec[$i]=$spec[$i]."ret".$retind."=".$reststring.";\n";
           $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;
       $nfnames[$i]=0;}
      }
    }
    else{$prfnames[$i]="";}
    $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;
   }
  $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.

$moutfname=$proc[0];
$moutfname =~ s/(\w*)(\(.*\))(.*)/\1/;
$moutfname = $moutfname.".m";
open (MAINOUT,">".$moutfname);

$comflag=0; # open comment flag
$procind=0;
$wrfundum=1;
while (<>){
  if (/#include/){ $_="";};
  # write main function call line and Matlab specific messages to file header in comments
 if ($wrfundum==1){
  print MAINOUT "function ".$mainret[$procind]."=".$proc[$procind]."\n";
  print MAINOUT "%  ".$mainret[$procind]."=".$proc[$procind]."\n";
  print MAINOUT "%\n";
  print MAINOUT "%  Add brief description for function in line above for Matlab help searches\n";
  if ($prfnames[$procind] ne ""){
   if ($nfnames[$procind]>1){
   print MAINOUT "% Note:  ".$prfnames[$procind]." are function names and must be passed as strings\n";
   }else{
   $prfnames[$0]=~ s/and//;
   print MAINOUT "% Note:  ".$prfnames[$procind]." is a function name and must be passed as a string\n";
   }
  }
  if ($decdum==1){
  $outfname=~ s/\n//;
  print MAINOUT "%\n";
  print MAINOUT "% NOTE: YOU MUST ISSUE THE COMMAND: run ".$outfname."\n";
  print MAINOUT "%       TO INITIALIZE GLOBAL VARIABLES BEFORE CALLING THIS PROCEDURE!!! \n";
  print MAINOUT "%\n";
  print MAINOUT $decline;
  $wrfundum=0;
  }
 }
 if (/retp/)
     {
     print MAINOUT $spec[$retind];
     s/\s?retp\(.*\).*//;
     s/\s?retp\;//;
     $retind=$retind+1;
     }
 if (/endp/){
    s/.*//;
    print MAINOUT "% End of function\n";
    close(MAINOUT);
    if ($procind<$nrets){
    $moutfname=$proc[$procind+1];
    $moutfname =~ s/(\w*)(\(.*\))(.*)/\1/;
    $moutfname = $moutfname.".m";
    open (MAINOUT,">".$moutfname);
    }
    $procind=$procind+1;
    $wrfundum=1;
    }
   s/proc\(.*\)\=(.*\(.*\))\;//;
   s/proc (.*\(.*\))\;//;
   s/proc\(.*\)\=(\w*)\;//;
   s/proc\s*(\w*)\;//;
 if ( /^(\/\*|\s \/\*|\s\/\*|\s *\/\*)/ && (/(\*\/\s |\*\/)$/) && (/;/==0) &&
  ($comflag==0)) {
  #closed comment
  if ($pcasedum==1){ print MAINOUT "case1: \n"; }
  $opcomind=index($_,"/*");
  $chcom=substr($_,$opcomind+3);
  $clcomind=index($chcom,"*/");
  $chcom=substr($chcom,0,$clcomind-1);
  print MAINOUT "% ".$chcom;
  print MAINOUT "\n";
  $comflag=0;
  }
 elsif (/^(\/\*|\s \/\*|\s\/\*|\s *\/\*)/ && ((/;/)==0) && ($comflag==0))  {
  #open left comment
  if ($pcasedum==1){ print MAINOUT "case2: \n";}
  $opcomind=index($_,"/*");
  $chcom=substr($_,$opcomind+3);
  print MAINOUT "% ".$chcom;
  $comflag=1;
  }                        
 elsif ((/(\*\/\s |\*\/)$/)  && /\/\*/==0 && /;/==0 && ($comflag==1))  {
  # closing right comment
  if ($pcasedum==1){ print MAINOUT "case3: \n";}
  $opcomind=index($_,"*/");
  if (opcomind>2){
     $chcom=substr($_,$opcomind-2);
     print MAINOUT "% ".$chcom;}
  else {
     print MAINOUT "% "; }
     print MAINOUT "\n";
  $comflag=0;
  }                     
 elsif (/\/\*/ && (/(\*\/\s |\*\/)$/) && (/;/ == 1) && ($comflag==0)){
  #code-closed comment
  if ($pcasedum==1){ print MAINOUT "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 MAINOUT $newcode.$comm;
  }
 elsif (/\/\*/ && (/\*\//==0) && (/;/ == 1) and ($comflag==0))  {
  #code followed by open left comment
  if ($pcasedum==1){ print MAINOUT "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 MAINOUT $newcode.$comm;
  }
 elsif ((/\/\*/==0) && (/\*\//==1) && (/;$/==1) and ($comflag==0))  {
  #closing right comment followed by completed code 
  if ($pcasedum==1){ print MAINOUT "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 MAINOUT $comm;
  print MAINOUT "\n";
  print MAINOUT $newcode;
  }
 elsif ((/\/\*/==0) && (/\*\//==0) && (/(;\s |;)$/) && ($comflag==0))  {
  if ($pcasedum==1){ print MAINOUT "case7: \n";}
  #single line of code
  $comflag=0;
  $newcode=&transproc($_);
  print MAINOUT $newcode;
  }
 elsif ((/\/\*/==0) && (/\*\//==0) && (/;/==0) && ($comflag==0) && ($_ ne "\n")
    && ($_ ne ""))
  {
  if ($pcasedum==1){ print MAINOUT "case8: \n";}
  #incomplete line of code continued on next line 
  $comflag=0;
  $newcode=&transproc($_);
  $newcode =~ s/\n//;
  if ($newcode =~ /\w/){
   print MAINOUT $newcode."...";
   print MAINOUT "\n";}
  }
 elsif ($_ eq ""){
  if ($pcasedum==1){ print MAINOUT "case9: \n";}
  if ($comflag==1){
     print MAINOUT "% \n";}
  else {
     print MAINOUT "\n";}
  }                         
 elsif ((/\*\//==0) && ($comflag==1))
  {#continuation of a comment
  if ($pcasedum==1){ print MAINOUT "case10: \n";}
  print MAINOUT "% ".$_;
  $comflag=1;
  }
 elsif ((/\*\//==1) && (/\/\*/==1) && index($_,"/*")<index($_,"*/") &&
      ($comflag==1))
  {#continuation of comment in the presense of nested comment
  if ($pcasedum==1){ print MAINOUT "case11: \n";}
  print MAINOUT "% ".$_;
  $comflag=1;
  }
 elsif ((/\/\*/==0) && (/\*\//==0) && (/;/==0) && ($comflag==0)){
  #completion of code from previous line
  if ($pcasedum==1){ print MAINOUT "case12: \n";}
  $newcode=&transproc($_);
  print $newcode;
  print MAINOUT $newcode;
  $comflag=0;
  }
 else {
  if ($pcasedum==1){ print MAINOUT "case13: \n";}
  print MAINOUT "% UNKNOWN LINE STRUCTURE ENCOUNTERED THE FOLLOWING\n";
  print MAINOUT "% LINE OF CODE WAS NOT TRANSLATED:\n";
  print MAINOUT $_;
  }
}
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];
    $origcode=$thiscode;
    if ($thiscode =~ /^\s/==1){
     $initspace=$thiscode;
     $initspace =~ s/(^\s*)(\S*)/\1/g;}
    else{
     $initspace="";
     }
    $thiscode =~ s/(^\s*)(\S*)/\2/g;
    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 = $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 ($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);
       }
    #simple search and replacements
    # FEEL FREE TO ADD YOUR OWN REPLACEMENTS IN THIS SECTION
    #replace open fh=fname for append; with fh=openfa('fname')
    $thiscode =~ s/(open)\s(\w*)\s?(\=)(\^)(.*)\sfor\sappend\s?(\;)/\2\=openfa\(\5\)\;/;
    $thiscode =~ s/(open)\s(\w*)\s?(\=)(.*)\sfor\sappend\s?(\;)/\2\=openfa\(\'\4\'\)\;/;
    #replace open fh=fname; with fh=open('fname')
    # note the Gauss file handling m-files must be used for these
    # translations to be valid
    $thiscode =~ s/(open)\s(.*)\s?(\=)(\^)(.*)\s?(\;)/\2\=open\(\5\)\;/;
    $thiscode =~ s/(open)\s(.*)\s?(\=)\s?(.*)\s?(\;)/\2\=open\(\'\4\'\)\;/;
    $thiscode =~ s/(create)\s(.*)\s?(\=)\s?(\^)(.*)\s(with)\s*(.*)\,(.*)\,(.*)\s?\;/\2\=\1\(\5\,\8,\9\,\7\)\;/;
    $thiscode =~ s/(create)\s(.*)\s?(\=)\s?(.*)\s(with)\s*(.*)\,(.*)\,(.*)\s?\;/\2\=\1\(\4\,\7\,\8\,\6\)\;/;
    $thiscode =~ s/ln\(/log\(/ig;
    $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
$vercdone=0; # dummy for being done with vert. concat's
$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) eq ")"){
           $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;
           if ($lbpos<0){
              print "Bracket error in original code, could not translate\n";
              print "the following code:".$origcode."\n";
              exit;}              
         } # ends while for nrb>nlb
    } # ends if on ) and )' to left of first |
    # once [ position pushed beyond last bracket match start looking for
    # first non-word to the left eg want: [sin(..)| or [-(..)| or
    # [-x|..  or [-sin(x)|... 
    $cont=1;
    while ($cont==1){
         if (substr($thiscode,$lbpos,1) =~/\W/ &&
            substr($thiscode,$lbpos,1) ne "-"){
             if (($lbpos==$pos-1) && (substr($thiscode,$lbpos,1) eq "'"))
                   {$lbpos=$lbpos-1;}
             else  {$cont=0;}
             #$cont=0;
         }
         elsif (substr($thiscode,$lbpos,1) eq "-")
              {$cont=0; $lbpos=$lbpos-1;}
         else
              {$lbpos=$lbpos-1;}
         if ($lbpos<0){
            print "Bracket error in original code, could not translate\n";
            print "the following code:".$origcode."\n";
            exit;}              
    } #ends while statement on $cont==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;
            $vercdone=1;  }
        } #ends while for cont==1
    }  # ends initial check for ) left of |
    else{
    $newstring=substr($thiscode,0,$lbpos+1)."[".substr($thiscode,$lbpos+1,$pos-$lbpos-1).";";
    $reststring=substr($thiscode,$pos+1);
         }  # ends else on initial check for ) left of |
    $cont=1;
    $rbpos=0;
    while ($cont==1)
    {
    # check to see if any more |'s exist before next ~ or terminating ;
    $pos=index($reststring,"|");
    # if not, & vercdone=0 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);}
     } #ends else statement
     } #ends while statement
   $rbpos=0;
   $nrb=0; $nlb=0;
   # ] position is currently to immediate right of last | unless vercdone=1
   # check to see if this position is a left bracket
   if ($vercdone==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 ($rbpos>200){
              print "Bracket error in original code, could not translate\n";
              print "the following code:".$origcode."\n";
              exit;}              
       }  # ends while nlb>nrb
       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) =~ /\)/){
             if ($nlb>0){
                $rbpos=$rbpos+1;
                $nrb=$nrb+1;}
             else{
                $cont=0;
                 $thiscode=$newstring.substr($reststring,0,$rbpos).
                "]".substr($reststring,$rbpos);}
             } 
         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;}
         if ($rbpos>200){
              print "Bracket error in original code, could not translate\n";
              print "the following code:".$origcode."\n";
              exit;}              
     } # this ends while cont=1 (bracket searching branch)
    } #this ends if vercdone=1
    $pos=index($thiscode,"|"); # check for more | left off by ~
} #this ends vert. concat section

##################################################
# now do horizontal concatination
# may have to count square brackets as well
# find the index of any ~'s if they exist
$horcdone=0;
$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) eq ")"){
           $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;
         if ($lbpos<0){
              print "Bracket error in original code, could not translate\n";
              print "the following code:".$origcode."\n";
              exit;}              

       } # ends while
    }  # ends if ) to left of ~
     # 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 "-")){
           if ($lbpos==$pos-1 && substr($thiscode,$lbpos,1) eq "'")
                 {$lbpos=$lbpos-1;}
           else  {$cont=0;}
       }
       elsif (substr($thiscode,$lbpos,1) eq "-"){$cont=0;
                                                 $lbpos=$lbpos-1;}
       else{
            $lbpos=$lbpos-1;}
       if ($lbpos<0){
           print "Bracket error in original code, could not translate\n";
           print "the following code:".$origcode."\n";
           exit;}              
    }  # this ends while for cont=1
     # insert left bracket at appropriate position, truncate "newstring" to
     # first ~ and create reststring which consists of what follows
    if (substr($thiscode,$lbpos,1) eq "("){
       #start counting brackets and drop ] immediately before final 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;
            $horcdone=1}
       }  #ends while for cont=1                                                              
       } #ends initial check for ) left of ~
    else{
    $newstring=substr($thiscode,0,$lbpos+1)."[".substr($thiscode,$lbpos+1,$pos-$lbpos-1)." ";
    $reststring=substr($thiscode,$pos+1);
    } # ends else on initial check for ) left of ~

 $cont=1;
   $rbpos=0;
 while ($cont==1)
   {
   # check to see if any more ~'s
   $pos=index($reststring,"~");
   # if not, initialize right bracket position for ] to immed. right last ~
   if ($pos==-1){
      $cont=0;}
   else{
      # if not keep adding chunks to "newstring"
      $newstring=$newstring.substr($reststring,0,$pos)." ";
      $reststring=substr($reststring,$pos+1);
      } #ends else statement
   } #ends while statement
  
   # ] 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 ($horcdone==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 ($rbpos>200){
              print "Bracket error in original code, could not translate\n";
              print "the following code:".$origcode."\n";
              exit;}              
       }
    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;}    # ends if ) branch
         if (substr($reststring,$rbpos,1) =~ /\)/){
             if ($nlb>0){
                $rbpos=$rbpos+1;
                $nrb=$nrb+1;}
             else{
                $cont=0;
                 $thiscode=$newstring.substr($reststring,0,$rbpos-1).
                "]".substr($reststring,$rbpos-1);}
             } #ends if ) branch
         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;}
             } #ends non-word branch
            # else keep sliding right
         else{
            $rbpos=$rbpos+1;}
         if ($rbpos>200){
              print "Bracket error in original code, could not translate\n";
              print "the following code:".$origcode."\n";
              exit;}              
      }  #ends while
  } #this ends if horcdate=1; 
    $pos=index($thiscode,"~"); # check for more ~ left off by ~
} #this ends horiz concat section


# convert != to ~= after concat. section for so that new ~s not misinterp'ed
$thiscode =~ s/\!\=/\~\=/;
# convert double qutoes strings to single quote
# do last to avoid transpose confusion
$thiscode =~ s/\"/\'/g;
$thiscode= $initspace.$thiscode; #add initial spacing back in
return $thiscode;} #end of tranproc procedure

############################################################
# 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;}