line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package App::War; |
2
|
9
|
|
|
9
|
|
20525
|
use strict; |
|
9
|
|
|
|
|
20
|
|
|
9
|
|
|
|
|
379
|
|
3
|
9
|
|
|
9
|
|
49
|
use warnings FATAL => 'all'; |
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
450
|
|
4
|
9
|
|
|
9
|
|
16773
|
use Graph; |
|
9
|
|
|
|
|
1396973
|
|
|
9
|
|
|
|
|
535
|
|
5
|
9
|
|
|
9
|
|
87
|
use List::Util 'shuffle'; |
|
9
|
|
|
|
|
18
|
|
|
9
|
|
|
|
|
9519
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $VERSION = 0.05; |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=pod |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
=head1 NAME |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
App::War - turn one big decision into many small decisions |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
=head1 SYNOPSIS |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
use App::War; |
18
|
|
|
|
|
|
|
my $war = App::War->new; |
19
|
|
|
|
|
|
|
$war->items(qw/ this that the-other that-too /); |
20
|
|
|
|
|
|
|
$war->init; |
21
|
|
|
|
|
|
|
$war->rank; |
22
|
|
|
|
|
|
|
print $war->report; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
=head1 DESCRIPTION |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
How do you go about ranking a number of items? One way to do it is to |
27
|
|
|
|
|
|
|
compare the objects two at a time until a clear winner can be established. |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
This module does just that, using a topological sort to establish a unique |
30
|
|
|
|
|
|
|
ordering of all the "combatants" in the "war". |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
This module is modeled loosely after L, a |
33
|
|
|
|
|
|
|
crowdsourced web application for determining the cutest kitten in the |
34
|
|
|
|
|
|
|
universe. |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
=head1 METHODS |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
=head2 App::War->new() |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
Constructs a new war object. |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
=cut |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
sub new { |
45
|
8
|
|
|
8
|
1
|
6107
|
my $class = shift; |
46
|
8
|
|
|
|
|
37
|
my $self = bless { @_ }, $class; |
47
|
8
|
|
|
|
|
32
|
return $self; |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
=head2 $war->run |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
Starts the war. |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
=cut |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
sub run { |
57
|
1
|
|
|
1
|
1
|
36
|
my $self = shift; |
58
|
1
|
|
|
|
|
4
|
$self->init; |
59
|
1
|
|
|
|
|
6
|
$self->rank; |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
=head2 $war->init |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
Uses the content of C<< $self->items >> to initialize a graph containing |
65
|
|
|
|
|
|
|
only vertices, one per item. |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
=cut |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
# NOTE: calling '$self->graph->add_vertex' breaks in strange |
70
|
|
|
|
|
|
|
# and mysterious ways. Why does this fix it? |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
sub init { |
73
|
6
|
|
|
6
|
1
|
317
|
my $self = shift; |
74
|
6
|
|
|
|
|
25
|
my @items = $self->items; |
75
|
6
|
|
|
|
|
41
|
$self->_info("Ranking items: @items"); |
76
|
6
|
|
|
|
|
22
|
my $g = $self->graph; |
77
|
6
|
|
|
|
|
28
|
for my $i (0 .. $#items) { |
78
|
|
|
|
|
|
|
# Why does this not work? |
79
|
|
|
|
|
|
|
# $self->graph->add_vertex($i); |
80
|
22
|
|
|
|
|
623
|
$g->add_vertex($i); |
81
|
|
|
|
|
|
|
} |
82
|
6
|
|
|
|
|
330
|
return $self; |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
=head2 $war->report |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
Returns the current state of the war graph as a multiline string. |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=cut |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
sub report { |
92
|
3
|
|
|
3
|
1
|
49
|
my $self = shift; |
93
|
3
|
|
|
|
|
5
|
my @out; |
94
|
3
|
|
|
|
|
7
|
push @out, "graph: @{[ $self->graph ]}\n"; |
|
3
|
|
|
|
|
45
|
|
95
|
3
|
|
|
|
|
1023
|
my @items = $self->items; |
96
|
3
|
|
|
|
|
12
|
my @ts = map { $items[$_] } $self->graph->topological_sort; |
|
12
|
|
|
|
|
7310
|
|
97
|
3
|
|
|
|
|
19
|
push @out, "sort: @ts\n"; |
98
|
3
|
|
|
|
|
37
|
return join q(), @out; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
=head2 $war->graph |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
Returns the graph object that stores the user choices. |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
=cut |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
sub graph { |
108
|
51
|
|
|
51
|
1
|
180
|
my $self = shift; |
109
|
51
|
100
|
|
|
|
149
|
unless (exists $self->{graph}) { |
110
|
6
|
|
|
|
|
50
|
$self->{graph} = Graph->new(directed => 1); |
111
|
|
|
|
|
|
|
} |
112
|
51
|
|
|
|
|
1974
|
return $self->{graph}; |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
=head2 $war->items |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
Get/set the items to be ranked. It's a bad idea to modify this once the |
118
|
|
|
|
|
|
|
war has started. |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
=cut |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sub items { |
123
|
17
|
|
|
17
|
1
|
37
|
my $self = shift; |
124
|
17
|
|
100
|
|
|
99
|
$self->{items} ||= []; |
125
|
17
|
100
|
|
|
|
48
|
if (@_) { |
126
|
2
|
|
|
|
|
108
|
$self->{items} = [shuffle @_]; |
127
|
|
|
|
|
|
|
} |
128
|
17
|
|
|
|
|
24
|
return @{ $self->{items} }; |
|
17
|
|
|
|
|
86
|
|
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
=head2 $war->rank |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
Starts the process of uniquely ordering the graph vertices. This method |
134
|
|
|
|
|
|
|
calls method C until it returns false, I we have a |
135
|
|
|
|
|
|
|
unique topo sort. |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
=cut |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
sub rank { |
140
|
2
|
|
|
2
|
1
|
549
|
my $self = shift; |
141
|
2
|
|
|
|
|
10
|
while (my $v = $self->tsort_not_unique) { |
142
|
6
|
|
|
|
|
19
|
$self->compare($v->[0], $v->[1]); |
143
|
|
|
|
|
|
|
} |
144
|
2
|
|
|
|
|
11
|
return $self; |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
=head2 $war->tsort_not_unique |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
This method returns a true value (more on this later) if the graph |
150
|
|
|
|
|
|
|
currently lacks a unique topo sort. If the graph B a unique sort, the |
151
|
|
|
|
|
|
|
"war" is over, and results should be reported. |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
If the graph B a unique topological sort, this method returns an |
154
|
|
|
|
|
|
|
arrayref containing a pair of vertices that have an ambiguous ordering. |
155
|
|
|
|
|
|
|
From L: |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
=over 4 |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
If a topological sort has the property that all pairs of consecutive |
160
|
|
|
|
|
|
|
vertices in the sorted order are connected by edges, then these edges form |
161
|
|
|
|
|
|
|
a directed Hamiltonian path in the DAG. If a Hamiltonian path exists, the |
162
|
|
|
|
|
|
|
topological sort order is unique; no other order respects the edges of the |
163
|
|
|
|
|
|
|
path. |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
=back |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
This property of the topological sort is used to ensure that we have a |
168
|
|
|
|
|
|
|
unique ordering of the "combatants" in our "war". |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
=cut |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
sub tsort_not_unique { |
173
|
10
|
|
|
10
|
1
|
783
|
my $self = shift; |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
# search for unordered items by calculating the topological sort and |
176
|
|
|
|
|
|
|
# verifying that adjacent items are connected by a directed edge |
177
|
|
|
|
|
|
|
|
178
|
10
|
|
|
|
|
25
|
my @ts = $self->graph->topological_sort; |
179
|
|
|
|
|
|
|
|
180
|
10
|
|
|
|
|
17239
|
for my $i (0 .. $#ts - 1) { |
181
|
16
|
|
|
|
|
151
|
my ($u,$v) = @ts[$i,$i+1]; |
182
|
16
|
100
|
|
|
|
38
|
if (!$self->graph->has_edge($u,$v)) { |
183
|
7
|
|
|
|
|
176
|
return [$u,$v]; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
} |
186
|
3
|
|
|
|
|
68
|
return 0; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
=head2 $war->compare($index1,$index2) |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
Handles user interaction choosing one of two alternatives. Arguments |
192
|
|
|
|
|
|
|
C<$index1> and C<$index2> are indexes into the internal array of items to |
193
|
|
|
|
|
|
|
be ranked, and indicate the two items that need to have their rank |
194
|
|
|
|
|
|
|
disambiguated. |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
=cut |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
sub compare { |
199
|
4
|
|
|
4
|
1
|
8
|
my ($self,@x) = @_; |
200
|
4
|
|
|
|
|
9
|
my @items = $self->items; |
201
|
4
|
|
|
|
|
14
|
my $response = $self->_get_response(@items[@x]); |
202
|
4
|
100
|
|
|
|
29
|
if ($response =~ /1/) { |
203
|
3
|
|
|
|
|
8
|
$self->graph->add_edge($x[0],$x[1]); |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
else { |
206
|
1
|
|
|
|
|
5
|
$self->graph->add_edge($x[1],$x[0]); |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
sub _get_response { |
211
|
0
|
|
|
0
|
|
0
|
my ($self,@items) = @_; |
212
|
0
|
|
|
|
|
0
|
print "Choose one of the following:\n"; |
213
|
0
|
|
|
|
|
0
|
print "<1> $items[0]\n"; |
214
|
0
|
|
|
|
|
0
|
print "<2> $items[1]\n"; |
215
|
0
|
|
|
|
|
0
|
(my $resp = ) =~ y/12//cd; |
216
|
0
|
|
|
|
|
0
|
return $resp; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
sub _info { |
220
|
8
|
|
|
8
|
|
769
|
my $self = shift; |
221
|
8
|
100
|
|
|
|
59
|
if ($self->{verbose}) { |
222
|
1
|
|
|
|
|
11
|
warn "@_\n"; |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
=head1 AUTHOR |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
John Trammell, C<< >> |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
=head1 BUGS |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
Please report any bugs or feature requests to C
|
233
|
|
|
|
|
|
|
rt.cpan.org>, or through the web interface at |
234
|
|
|
|
|
|
|
L. I will be |
235
|
|
|
|
|
|
|
notified, and then you'll automatically be notified of progress on your bug |
236
|
|
|
|
|
|
|
as I make changes. |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
=head1 SUPPORT |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
perldoc App::War |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
Your operating system may also have installed a manual page for this |
245
|
|
|
|
|
|
|
module; it would likely be available via the command |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
man war |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
You can also look for information at: |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
=over 4 |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
=item * GitHub |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
L |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
=item * RT: CPAN's request tracker |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
L |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
=item * AnnoCPAN: Annotated CPAN documentation |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
L |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
=item * CPAN Ratings |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
L |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
=item * Search CPAN |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
L |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
=back |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
=head1 COPYRIGHT & LICENSE |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
Copyright 2009 John Trammell, all rights reserved. |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it |
280
|
|
|
|
|
|
|
under the same terms as Perl itself. |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
=cut |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
'BOOYA!'; |
285
|
|
|
|
|
|
|
|