tests/expressions/randist/randist.pl

   1 use warnings;
   2
   3 our (@funcs);
   4 our (@vars);
   5 our (%values);
   6
   7 while (<>) {
   8     chomp;
   9     s/#.*//;
  10     next if /^\s*$/;
  11     my ($dist) = /^(.+):\s*$/ or die;
  12
  13     @funcs = ();
  14     @vars = ();
  15     %values = ('P' => [.01, .1, .2, .3, .4, .5, .6, .7, .8, .9, .99]);
  16     while (<>) {
  17         last if /^\s*$/;
  18
  19         my ($key, $value) = /^\s*(\w+)\s*=\s*(.*)$/;
  20         my (@values);
  21         foreach my $s (split (/\s+/, $value)) {
  22             if (my ($from, $to, $by) = $s =~ /^(.*):(.*):(.*)$/) {
  23                 for (my ($x) = $from; $x <= $to; $x += $by) {
  24                     push (@values, sprintf ("%.2f", $x) + 0);
  25                 }
  26             } else {
  27                 push (@values, $s);
  28             }
  29         }
  30
  31         if ($key eq 'funcs') {
  32             @funcs = @values;
  33         } else {
  34             push (@vars, $key);
  35             $values{$key} = \@values;
  36         }
  37     }
  38
  39     print "DATA LIST LIST/", join (' ', 'P', @vars), ".\n";
  40     print "NUMERIC ", join (' ', 'x', @funcs), " (F10.4)\n";
  41     print "COMPUTE x = IDF.$dist (", join (', ', 'P', @vars), ").\n";
  42     foreach my $func (@funcs) {
  43         print "COMPUTE $func = $func.$dist (",
  44           join (', ', 'x', @vars), ").\n";
  45     }
  46     my (@print) = ('P', @vars, 'x', @funcs);
  47     print "DO IF \$CASENUM = 1.\n";
  48     print "PRINT OUTFILE='$dist.out'/'", heading (@print), "'\n";
  49     print "END IF.\n";
  50     print "PRINT OUTFILE='$dist.out'/",
  51       join (' ', @print), ".\n";
  52     print "BEGIN DATA.\n";
  53     print_all_values (['P', @vars], []);
  54     print "END DATA.\n";
  55 }
  56
  57 sub print_all_values {
  58     my (@vars) = @{$_[0]};
  59     my (@assign) = @{$_[1]};
  60     if (@vars == @assign) {
  61         print join (' ', @assign), "\n";
  62     } else {
  63         push (@assign, 0);
  64         my ($var) = $vars[$#assign];
  65         foreach my $value (@{$values{$var}}) {
  66             $assign[$#assign] = $value;
  67             print_all_values (\@vars, \@assign);
  68         }
  69     }
  70 }
  71
  72 sub heading {
  73     my (@names) = @_;
  74     my ($out);
  75     $out .= pad_to (shift (@names), 8) while $names[0] ne 'x';
  76     $out .= pad_to (shift (@names), 10) while @names;
  77     return $out;
  78 }
  79
  80 sub pad_to {
  81     my ($s, $n) = @_;
  82     return (' ' x ($n - length ($s))) . $s . ' ';
  83 }