chiark / gitweb /
8828deec85ee3542e80421a56ce13d2a3a034a6e
[appendix-a6.git] / parse
1 #!/usr/bin/perl -w
2 use strict;
3 use utf8;
4
5 use Data::Printer;
6
7 binmode STDIN, 'encoding(UTF-8)' or die;
8 binmode STDOUT, 'encoding(UTF-8)' or die;
9 binmode STDERR, 'encoding(UTF-8)' or die;
10
11 our @choices;
12 our %choices;
13 our @invotes;
14 our $defcho;
15 our $quorum = 0;
16
17 sub addchoice {
18     my $choname = shift @_;
19     my $cho = $choices{$choname} = { @_, Index => (scalar @choices) };
20     push @choices, $choname;
21     return $cho;
22 }
23
24 while (<>) {
25     s/\s+$//;
26     next if m/^\s*\#/;
27     next unless m/\S/;
28     if (m/^([A-Z]+)\s*\=\s*(\S.*)$/) {
29         my ($choname, $desc) = ($1,$2);
30         my $cho = addchoice($choname, Desc => $desc);
31         if ($desc =~ m/\[(\d+):(\d+)\]/) {
32             $cho->{Smaj} = [$1,$2];
33         } elsif ($desc =~ m/\[default\]/) {
34             $defcho = $cho;
35         }
36     } elsif (m/^V:\s+(\S+)\s+(\S.*)/) {
37         push @invotes, [ $1, $2 ];
38     } elsif (m/^quorum = ([0-9.]+)$/) {
39         $quorum = $1+0.0;
40     } else {
41         die "invalid input";
42     }
43 }
44
45 $defcho ||= $choices{FD};
46 if (!$defcho) {
47     $defcho = addchoice('FD', Desc => "Further Discussion");
48 }
49 my $defi = $defcho->{Index};
50 die "FD has smaj?!" if $defcho->{Smaj};
51
52 our @vab; # $vab[$ia][$ib] = V(A,B)
53
54 foreach my $iv (@invotes) {
55     my ($votestr,$voter) = @$iv;
56     eval {
57         length $votestr eq @choices or die "wrong vote vector length";
58         my @vs = split //, $votestr;
59         foreach my $ix (0..$#vs) {
60             my $vchr = $vs[$ix];
61             if ($vchr eq '-') {
62                 $vs[$ix] = 1000;
63             } elsif ($vchr =~ m/[0-9a-z]/) {
64                 $vs[$ix] = ord($vchr);
65             } else {
66                 die "bad vote char";
67             }
68         }
69         foreach my $ia (0..$#vs) {
70             foreach my $ib ($ia+1..$#vs) {
71                 my $va = $vs[$ia];
72                 my $vb = $vs[$ib];
73                 if ($va < $vb) { push @{ $vab[$ia][$ib] }, $voter }
74                 elsif ($vb < $va) { push @{ $vab[$ib][$ia] }, $voter }
75             }
76         }
77     };
78     die "voter $voter $@" if $@;
79 }
80
81 our @ch = map { $choices{$_} } @choices;
82
83 foreach my $iy (-2..$#ch) {
84     foreach my $ix (-2..$#ch) {
85         if ($iy==-1) {
86             if ($ix==-1) {
87                 printf "+" or die;
88             } else {
89                 printf "------" or die;
90             }
91         } elsif ($ix==-1) {
92             printf "|" or die;
93         } elsif ($ix==-2 && $iy==-2) {
94             printf "V(Y,X)" or die;
95         } elsif ($iy==-2) {
96             printf "%5s ", $choices[$ix] or die $!;
97         } elsif ($ix==-2) {
98             printf "%5s ", $choices[$iy] or die $!;
99         } else {
100             my $v = \( $vab[$iy][$ix] );
101             $$v ||= [ ];
102             if (@$$v) {
103                 printf "%5d ", (scalar @$$v) or die $!;
104             } else {
105                 printf "%5s ", "" or die $!;
106             }
107         }
108     }
109     printf "\n" or die $!;
110 }
111
112 sub drop ($$) {
113     my ($i,$why) = @_;
114     print "dropping $choices[$i]: $why\n";
115     $ch[$i]{Dropped} = $why;
116 }
117
118 print "# quorum\n" or die;
119
120 foreach my $i (0..$#choices) {
121     next if $ch[$i]{Dropped};
122     next if $i == $defi;
123     my $v = $vab[$i][$defi];
124     next if $v >= $quorum;
125     drop $i, "quorum ($v < $quorum)";
126 }
127
128 print "# maj. ratio\n" or die;
129
130 foreach my $i (0..$#choices) {
131     next if $ch[$i]{Dropped};
132     next if $i == $defi;
133     my $majr = $ch[$i]{Smaj};
134     $majr ||= [1,1];
135     my $vad = scalar @{ $vab[$i][$defi] };
136     my $vda = scalar @{ $vab[$defi][$i] };
137     next if $vad * $majr->[1] > $vda * $majr->[0];
138     drop $i, "majority ratio ($vad * $majr->[1] <= $vda * $majr->[0])";
139 }
140
141
142 #p %choices;
143 #p @vab;