Implemented the Rank Cases dialog
[pspp-builds.git] / 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 }