chiark / gitweb /
normalise: Support tie
[appendix-a6.git] / normalise
1 #!/usr/bin/perl -w
2 #
3 # usage:
4 #  normalise [NORM-OPTIONS...] [--] INPUT-FILES...
5 #
6 # NORM-OPTIONS are
7 #   +OPTNAME[=OPTVAL]           Election option
8 #   CAND=[DESCRIPTION]
9 #   +CAND+OPTNAME[=OPTVAL]      Candidate option
10 #   --                          End of options to normalise
11 #   -...                        Reserved for future options to normalise
12
13 use strict;
14
15 our @options;
16 our %candidates; # $candidates{CAND}{Desc}, {Opts}[]
17 our %candref; # $candref{CAND} => msg of why needed
18 our @ballots;
19
20 my $candvoter_re = '\w+';
21 my $cands_re = '\w+(?,\w+)*';
22 my $opt_re = '\w+(?:=\S*)?';
23
24 sub badinput ($) {
25     die "bad input: $_[0]";
26 }
27
28 sub normalise_opts_list ($$) {
29     # $ctx is one of Election Candidate Ballot
30     my ($os,$ctx) = @_;
31     $os //= '';
32     my @o;
33     foreach my $o (split /\s+/, $os) {
34         if ($o =~ m/^\w+$/) {
35             push @o, $&;
36         } elsif ($o =~ s/^_[Tt]ie\=//) {
37             $o =~ m/^($cands_re)([<>])($cands_re)$/
38                 or badinput "bad value \`$_' for tie option";
39             my ($l,$op,$r) = ($1,$2,$3);
40             ($l,$op,$r) = ($r,'>',$l) if $op eq '<';
41             $candref{$_} = "tie break spec" foreach $o =~ m/\w+/g;
42             $l = join ',', sort split /\,/, $l;
43             $r = join ',', sort split /\,/, $r;
44             $l =~ m/\b$_\b/ and badinput "reflexive tie"
45                 foreach split /\,/, $r;
46             push @o, "$l$op$r";
47         } elsif ($o =~ m/^\w+\=\S+$/) {
48             push @o, $&;
49         } elsif ($o !~ m/\S/) {
50         } else {
51             badinput "bad option \`$o'";
52         }
53     }
54     return @o;
55 }
56
57 sub normalise_opts ($$) {
58     my ($os,$ctx) = @_;
59     my @o = normalise_opts_list $os, $ctx;
60     return " | @o";
61 }
62
63 sub setcanddesc ($$) {
64     my ($cand,$desc) = @_;
65
66     if (length $desc) {
67         badinput "multiple descriptions for $cand" if
68             defined $candidates{$cand}{Desc};
69         $candidates{$cand}{Desc} = $desc;
70     }
71 }
72
73 while (@ARGV) {
74     $_ = shift @ARGV;
75     if (m/^--$/) {
76         last;
77     } elsif (m/^(\w+)=([^|]+)$/) {
78         setcanddesc $1, $2;
79     } elsif (m/^\+($opt_re)$/) {
80         push @options, $1;
81     } elsif (m/^\+(\w+)\+($opt_re)$/) {
82         push @{ $candidates{$1}{Opts} }, $2;
83     } elsif (m/^-/) {
84         die "unknown normalise option \`$_'\n";
85     } else {
86         # oh!
87         unshift @ARGV, $_;
88         last;
89     }
90 }
91
92 while (<>) {
93     next unless m/\S/;
94     next if m/^\#/;
95     s/^\s+//;
96     s/\s+$//;
97     if (m/^\|/) {
98         push @options, normalise_opts_list $', 'Election';
99     } elsif (m/^($candvoter_re?)\s*=\s*([^|]+?)\s*\|(.*)?$/o) {
100         use Data::Dumper;
101 print STDERR Dumper($1,$2,$3);
102         my ($cand,$desc,$opts) = ($1,$2,$3);
103         push @{ $candidates{$cand}{Opts} }, normalise_opts $opts, 'Candidate';
104         setcanddesc $cand, $desc;
105     } elsif (m/^($candvoter_re?)?\s*\:([^|]*)(?:\|(.*))?$/) {
106         my ($voter,$opts) = ($1,$3);
107         my @p;
108         foreach my $p (split /\s+/, $2) {
109             if ($p =~ m/^\w+(?:\=\w+)*$/) {
110                 push @p, $&;
111                 $candidates{$_} //= { } foreach $p =~ m/\w+/g;
112             } elsif ($p eq '') {
113                 # empty entry can only happen if voter casts no prefs at all
114             } else {
115                 badinput "bad vote preference \`$p'";
116             }
117         }
118         push @ballots, "$voter : @p".normalise_opts $opts, 'Ballot';
119     } elsif (m/^\.$/) {
120     } else {
121         badinput "unknown line format \`$_'";
122     }
123 }
124
125 print "| @options\n" or die $!;
126
127 foreach my $cand (sort keys %candref) {
128     badinput "missing candidate $cand (ref. by $candref{$cand}"
129         unless defined $candidates{$cand};
130 }
131
132 foreach my $cand (sort keys %candidates) {
133     my $c = $candidates{$cand};
134     $c->{Desc} //= $cand;
135     $c->{Opts} //= [ ];
136     my $opts = $c->{Opts};
137     print "$cand = $c->{Desc} | @$opts\n" or die $!;
138 }
139
140 sub vsortkey { $_[0] =~ m/:/; return "$' : $`"; }
141
142 print $_,"\n" or die $! foreach
143     sort { vsortkey($a) cmp vsortkey($b) } @ballots;
144
145 print ".\n" or die $!;