lib/model/problem/init_record_subs.pm

   1 # {{{ include statements
   2
   3 start include statements
   4 use model::problem::record::init_option;
   5 end include statements
   6
   7 # }}} include statements
   8
   9 # {{{ restore_inits
  10
  11 start restore_inits
  12       {
  13         if ( defined $self -> options ) {
  14           foreach my $option ( @{$self -> options} ){
  15             $option -> restore_init;
  16           }
  17         }
  18       }
  19 end restore_inits
  20
  21 # }}} restore_inits
  22
  23 # {{{ set_random_inits
  24 start set_random_inits
  25       {
  26         if ( defined $self -> options and not $self -> {'same'} and
  27              not $self -> {'fix'} ) {
  28           foreach my $option ( @{$self -> options} ){
  29             $option -> set_random_init( degree => $degree );
  30           }
  31         }
  32       }
  33 end set_random_inits
  34 # }}} set_random_inits
  35
  36 # {{{ store_inits
  37 start store_inits
  38       {
  39         if ( defined $self -> options ) {
  40           foreach my $option ( @{$self -> options} ){
  41             if( $option -> can( 'store_init' ) ){
  42               $option -> store_init;
  43             }
  44           }
  45         }
  46       }
  47 end store_inits
  48 # }}} store_inits
  49
  50 # {{{ _add_option
  51
  52 start _add_option
  53       {
  54         my $opt_obj =
  55           model::problem::record::init_option ->
  56               new ( option_string => $option_string,
  57                     on_diagonal   => $on_diagonal,
  58                     sd            => $sd,
  59                     corr          => $corr,
  60                     fix           => $fix );
  61         push( @{$self -> {'options'}}, $opt_obj ) if( $opt_obj );
  62       }
  63 end _add_option
  64
  65 # }}} _add_option
  66
  67 # {{{ _format_record
  68
  69 start _format_record
  70       {
  71         my @class_names = split('::',ref($self));
  72         my $fname = uc(pop(@class_names));
  73         $formatted[0] = "\$".$fname." ";
  74         my $len;
  75
  76         my $otype = $self -> {'type'};
  77         my $same  = $self -> {'same'};
  78         my $fix   = $self -> {'fix'};
  79         my $size  = $self -> {'size'};
  80
  81         if ( defined $otype ) {
  82           $formatted[0] = $formatted[0]." $otype";
  83           if ( defined $size ) {
  84             $formatted[0] = $formatted[0]."($size)";
  85           }
  86           if ( $self -> sd() ) {
  87             $formatted[0] = $formatted[0]." SD";
  88           }
  89           if ( $self -> corr() ) {
  90             $formatted[0] = $formatted[0]." CORRELATION";
  91           }
  92           if ( $fix) {
  93             $formatted[0] = $formatted[0]." FIX";
  94           }
  95           if ( $same) {
  96             $formatted[0] = $formatted[0]." SAME\n";
  97           }
  98         }
  99         my $i = 0;
 100         $len = length $formatted[0];
 101         if ( defined $self -> {'options'} ) {
 102           foreach my $option ( @{$self -> {'options'}} ) {
 103             $len = 0 if $i++;
 104             $formatted[0] = $formatted[0].' '.
 105               $option -> _format_option( len => $len)."\n";
 106           }
 107         } else {
 108           $formatted[0] = $formatted[0]."\n";
 109         }
 110
 111         if ( defined $self -> {'comment'} ) {
 112           push( @formatted, @{$self -> {'comment'}} );
 113           $formatted[$#formatted] = $formatted[$#formatted];
 114         }
 115       }
 116 end _format_record
 117
 118 # }}} _format_record
 119
 120 # {{{ _read_options
 121 start _read_options
 122       {
 123         my @inits = ();
 124         my @row   = ();
 125         my @digits = ();
 126         my @fix = ();
 127         my @sds = ();
 128         my @corrs = ();
 129         my @comments = ();
 130         my ( $any_fixed, $any_sd, $any_corr, $block_sd, $block_corr, $block_fixed ) = ( 0, 0, 0, 0, 0, 0 );
 131         if ( defined $self -> {'record_arr'} ) {
 132           my ( $digit, $comment, $fixed, $sd, $corr ) = ( undef, undef, 0, 0, 0 );
 133           for ( @{$self -> {'record_arr'}} ) {
 134             chomp;
 135             s/^\s+//;
 136             s/\s+$//;
 137             s/^\s*\$\w+//;
 138             next unless( length($_) > 0 );
 139             if( /^\s*\;/ ) {
 140               # This is a comment row
 141               push( @{$self -> {'comment'}}, $_ . "\n" );
 142             } else {
 143               # Make sure that the labels and units are in one string
 144               s/\;\s+/\;/g;
 145               # Get rid of unwanted spaces
 146 #             s/\s*\,\s*/\,/g;
 147 #             s/\s+FIX/FIX/g;
 148               s/\s*\)/\)/g;
 149               s/\(\s*/\(/g;
 150               my ( $line, $line_comment ) = split( ";", $_, 2 );
 151               $_ = $line;
 152               $any_fixed++ if /FIX/;
 153               $any_sd++    if /SD/;
 154               $any_sd++    if /STANDARD/;
 155               $any_corr++  if /CORRELATION/;
 156               $self -> {'type'} = 'DIAGONAL' if /DIAG\w*/;
 157               $self -> {'type'} = 'BLOCK'    if /BLOCK/;
 158               $self -> {'size'}  = $2
 159                 if s/^\s*(BLOCK|DIAG\w*)\s*\((\d+)\)\s*//;
 160
 161               # If we have a "BLOCK SAME" the regexp above wont remove
 162               # 'BLOCK' and we do it here:
 163               s/BLOCK//;
 164
 165               $self -> {'same'}  = 1         if s/SAME//;
 166               push ( @inits, $_ );
 167               while( s/\(([\w ]*)\)// ) {
 168                 # We should (if the file is correctly formatted) only
 169                 # find parentheses if the record is NOT of a BLOCK()
 170                 # type. In this code we find all records code like
 171                 # (init options) or (options init)
 172                 my @opt = split( " ",$1 );
 173                 my ( $digit, $fixed, $sd, $corr ) = ( undef, 0, 0, 0 );
 174                 for ( my $i = 0; $i <= $#opt; $i++ ) {
 175                   if ( $opt[$i] =~ /\d+/ ) {
 176                     $digit = $opt[$i];
 177                   } elsif ( $opt[$i] =~ /FIX/ ) {
 178                     $fixed = 1;
 179                   } elsif ( $opt[$i] =~ /SD/ or $opt[$i] =~ /STANDARD/ ) {
 180                     $sd = 1;
 181                   } elsif ( $opt[$i] =~ /CORRELATION/ ) {
 182                     $corr = 1;
 183                   } else {
 184                     'debug' -> die( message => "init_record_subs -> _read_options: Unknown option $_" );
 185                   }
 186                 }
 187                 if ( defined $digit ) {
 188                   $self -> _add_option( option_string => $digit,
 189                                         fix           => $fixed,
 190                                         sd            => $sd,
 191                                         corr          => $corr,
 192                                         on_diagonal   => 1 );
 193                 }
 194               }
 195               @row = split( " ", $_ );
 196               for ( my $i = 0; $i <= $#row; $i++ ) {
 197                 # In this code we find all records coded like: init options init options ...
 198                 $_ = $row[$i];
 199                 if ( /\d+/ ) {
 200                   if ( defined $digit ) {
 201                     push( @digits, $digit );
 202                     push( @fix   , $fixed );
 203                     push( @sds    , $sd );
 204                     push( @corrs  , $corr );
 205                     push( @comments, $comment );
 206                   }
 207                   ( $fixed, $sd, $corr ) = ( 0, 0, 0 );
 208                   $digit = $_;
 209                 } elsif ( /FIX/ and not $fixed ) {
 210                   $fixed = 1;
 211                 } elsif ( /SD/ or /STANDARD/ ) {
 212                   $sd = 1;
 213                 } elsif ( /CORRELATION/ ) {
 214                   $corr = 1;
 215                 } else {
 216                   'debug' -> die( message => "init_record_subs -> _read_options: Unknown option $_" );
 217                 }
 218                 $comment = $i == $#row ? $line_comment : undef;
 219               }
 220             }
 221           }
 222           if ( defined $digit ) {
 223             push( @digits, $digit );
 224             push( @fix   , $fixed );
 225             push( @sds    , $sd );
 226             push( @corrs  , $corr );
 227             push( @comments, $comment );
 228           }
 229         }
 230
 231         if( $self -> {'type'} eq 'BLOCK' ) {
 232           $self -> fix(1)  if ($any_fixed);
 233           $self -> sd(1)   if ($any_sd);
 234           $self -> corr(1) if ($any_corr);
 235         }
 236
 237         my $row = 1;
 238         for ( my $i = 0; $i <= $#digits; $i++ ) {
 239           my $com_str = defined $comments[$i] ? ';'.$comments[$i] : '';
 240           if ( $self -> {'type'} eq 'BLOCK' ) {
 241             if ( $i+1 == $row*($row+1)/2 ) {
 242               $row++;
 243               $self -> _add_option( option_string => $digits[$i].$com_str,
 244                                     on_diagonal   => 1 );
 245             } else {
 246               $self -> _add_option( option_string => $digits[$i].$com_str,
 247                                     on_diagonal   => 0 );
 248             }
 249           } else {
 250             $self -> _add_option( option_string => $digits[$i].$com_str,
 251                                   fix           => $fix[$i],
 252                                   sd            => $sds[$i],
 253                                   corr          => $corrs[$i],
 254                                   on_diagonal   => 1 );
 255           }
 256         }
 257
 258 #       if ( defined $self -> {'record_arr'} ) {
 259 #         for ( @{$self -> {'record_arr'}} ) {
 260 #       for ( @inits ) {
 261 #         next unless( length($_) > 0 );
 262 #         # Split inits and labels/units
 263 #         my ( $line, $comment ) = split( ";", $_, 2 );
 264 #         # Split the init string to see if we have more than one init.
 265 #         @row = split( " ",$line );
 266 #         if ( $#row <=0 ) {
 267 #           # If we only have one init, send the whole row to option
 268 #           $self -> _add_option( option_string => $_ );
 269 #           print "LINE: $_\n";
 270 #           print "adding one init\n";
 271 #           # if ( $self -> {'debug'} );
 272 #         } else {
 273 #           # If we have more than one init, send one init at a time to option
 274 #           print "LINE: $_\n";
 275 #           print "adding ",$#row+1," inits\n";
 276 #           # if ( $self -> {'debug'} );
 277 #           for ( @row ) {
 278 #             $self -> _add_option( option_string => $_ );
 279 #           }
 280 #         }
 281 #       }
 282       }
 283 end _read_options
 284 # }}} _read_options
 285