tests/expressions/randist/randist.pl

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