bin/gam42toconf

   1 #!/usr/bin/perl
   2
   3 use FindBin qw($Bin);
   4 use lib "$Bin/../lib";
   5
   6 # Don't edit the line below, it must look exactly like this.
   7 # Everything above this line will be replaced #
   8
   9 use PsN;
  10 use Getopt::Long;
  11 use Config::Tiny;
  12 use debug;
  13
  14 sub split_parm_cov {
  15   my $params = shift;
  16   my @parameters = @{$params};
  17   my $parmcov = shift;
  18
  19   foreach my $parm ( @parameters ){
  20     if( $parmcov =~ /^$parm(.*)/ ){
  21       return ($parm,$1);
  22     }
  23   }
  24   return;
  25 }
  26
  27 my %options;
  28
  29 my $res = GetOptions( \%options,
  30                       "parameters:s");
  31
  32 exit unless $res;
  33
  34 my $self = Config::Tiny -> new();
  35
  36 open(OLDFILE, "<" . $ARGV[0] ) ||
  37     die "Unable to open oldstyle file".$ARGV[0]."for parsing\n";
  38
  39
  40 my @parameters = split( /,/ , $options{"parameters"} );
  41 my %covariates;
  42 my %test_relations;
  43 my %unknowns;
  44
  45 while ( <OLDFILE> ) {
  46   chomp;
  47   if ( /^\s*;;;\s*DECL:\s*(.*)\s*$/ ) { # Find DECL lines, $1 is string of covs
  48     my @parmcovs = split(/\s+/,$1);
  49     foreach my $parmcov ( @parmcovs ){
  50       my ($parm, $cov) = split_parm_cov(\@parameters, $parmcov);
  51       if( length( $cov ) > 0 ){
  52         $covariates{$cov} = 1;
  53         push( @{$test_relations{$parm}}, $cov );
  54       }
  55     }
  56   } elsif ( /^\s*;;;\s*BOUNDS:\s*(.*)\s*;\s*(.*)\s*$/ ) {
  57     my $label = $2;
  58     my $bound = $1;
  59     my ($parm,$cov) = split_parm_cov(\@parameters, $label);
  60     $bound =~ /\((.*),(.*),(.*)\)/;
  61     my $upper = $3;
  62     my $init = $2;
  63     my $lower = $1;
  64
  65     if( length( $upper ) > 0 ){
  66       $self -> {'upper_bounds'} -> {"$parm:$cov-2"} = "$upper";
  67       $self -> {'upper_bounds'} -> {"$parm:$cov-3"} = "$upper,$upper";
  68     }
  69
  70     if( length( $init ) > 0 ){
  71       $self -> {'inits'} -> {"$parm:$cov-2"} = "$init";
  72       $self -> {'inits'} -> {"$parm:$cov-3"} = "$init,$init";
  73     }
  74
  75     if( length( $lower ) > 0 ){
  76       $self -> {'lower_bounds'} -> {"$parm:$cov-2"} = "$lower";
  77       $self -> {'lower_bounds'} -> {"$parm:$cov-3"} = "$lower,$lower";
  78     }
  79
  80   } elsif (/^\s*;;;\s*GLOBAL_INIT:\s*(.*)\s*$/) {
  81     $self -> {_} ->  {'global_init'} = $1;
  82   } elsif ( /^\s*;;;\s*DYNAMIC_INIT\s*$/) {
  83     $self -> {_} ->  {'dynamic_init'} = 1;
  84   } elsif ( /^\s*;;;\s*MISS:\s*(.*)\s*/) {
  85     $self -> {_} -> {'missing_data_token'} = $1;
  86   } elsif ( /^\s*;;;\s*GOF:\s*(.*)\s*/) {
  87     $self -> {_} ->  {'gof'} = $1;
  88   } elsif ( /^\s*;;;\s*TASK:\s*(.*)\s*/) {
  89     $self -> {_} ->  {'search_direction'} = $1;
  90   } elsif ( /^\s*;;;\s*FIX:\s*(.*)\s*/) {
  91     $self -> {_} ->  {'fix'} = $1;
  92   } elsif ( /^\s*;;;\s*(\w+)(\d+)\s*START/ ) {
  93     my $label = $1;
  94     my $level = $2;
  95     my @code_array;
  96
  97     while (<OLDFILE>) {
  98       chomp;
  99       my $line = $_;
 100       last if( $line =~ /\s*;;;\s*.*\s*END\s*/ );
 101       if( $line =~ /\s*;;;(.*)/ ){
 102         $line = $1;
 103       }
 104       push( @code_array, $line );
 105     }
 106
 107     my ($parm, $cov) = split_parm_cov( \@parameters, $label );
 108
 109     for( my $i = 0; $i < $#code_array; $i++ ){
 110       if( $i > 0 ){
 111         $self -> {'specific_code'}{"$parm:$cov-$level"} .= ' ' x (1+length( "$parm:$cov-$level" ));
 112       }
 113       $self -> {'specific_code'}{"$parm:$cov-$level"} .= $code_array[$i] . " \\\n";
 114     }
 115     if( $#code_array > 0 ){
 116       $self -> {'specific_code'}{"$parm:$cov-$level"} .= ' ' x (1+length( "$parm:$cov-$level" ));
 117     }
 118     $self -> {'specific_code'}{"$parm:$cov-$level"} .= $code_array[$#code_array] . "\n";
 119
 120   } elsif ( /^\s*;;;\s*PFORW:\s*(\d+)/ ) {
 121     $self -> {_} -> {'p_forward'} = $1;
 122   } elsif ( /^\s*;;;\s*PBACK:\s*(\d+)/ ) {
 123     $self -> {_} -> {'p_backward'} = $1;
 124   } elsif ( /^\s*;;;\s*LST:\s*(.*)\s*$/ ) {
 125
 126     print( "LST option ignored.\n" )
 127
 128     #$self -> {_} ->  {'listfile'} = $1;
 129   }
 130 }
 131
 132 foreach my $cov ( keys %covariates ) {
 133   $self -> {_} -> {'covariates'} .= "$cov,";
 134 }
 135
 136 foreach my $parm ( keys %test_relations ){
 137   foreach my $cov ( @{$test_relations{$parm}} ){
 138     $self -> {'test_relations'} -> {$parm} .= "$cov,";
 139   }
 140 }
 141
 142 # if ( defined $self -> {'models'} and
 143 #      scalar @{$self -> {'models'}} > 0 ) {
 144 #   die "Error in scm -> _read_scm_file: You can't ",
 145 #   "specify both a modelobject and a scm modelfile\n";
 146 # } else {
 147 #   my $scm_model = model -> new( 'filename' => $self -> {'scm_file'},
 148 #                               'outputfile' => $self -> {'listfile'},
 149 #                               'target' => 'disk',
 150 #                               'ignore_missing_files' => 1 );
 151
 152 #   my @code_block = @{$scm_model -> pk};
 153 #   my @new_code_block;
 154 #   my $prev_code_row = '';
 155 #   my $in_block = 0;
 156 #   foreach my $code_row ( @code_block ) {
 157 #     if ( $code_row =~ /^\s*;;;\s*(\w+)(\d+)\s*START/ ) {
 158 #       $in_block = 1;
 159 #     }
 160 #     if ( $in_block and $code_row =~ /\s*;;;\s*.*\s*END\s*/ ) {
 161 #       $in_block = 0;
 162 #     }
 163 #     unless( ($prev_code_row =~ /^$/ and $code_row =~ /^$/) ){
 164 #       unless( $code_row =~ /^\s*;;;/ or $in_block ){
 165 #       push(@new_code_block, $code_row);
 166 #       $prev_code_row = $code_row;
 167 #       }
 168 #     }
 169 #   }
 170 #   $scm_model -> pk( 'new_pk' => \@new_code_block);
 171 #   push( @{$self -> {'models'}}, $scm_model);
 172 # }
 173
 174 $self -> write( $ARGV[1] );
 175
 176 print( "Configuration file written to $ARGV[1]\n" );