File Coverage

blib/lib/Algorithm/Simplex/Rational.pm
Criterion Covered Total %
statement 29 72 40.2
branch 1 6 16.6
condition n/a
subroutine 7 12 58.3
pod 6 6 100.0
total 43 96 44.7


line stmt bran cond sub pod time code
1             package Algorithm::Simplex::Rational;
2 2     2   766 use Moo;
  2         4  
  2         26  
3             extends 'Algorithm::Simplex';
4             with 'Algorithm::Simplex::Role::Solve';
5 2     2   511 use MooX::Types::MooseLike::Base qw( InstanceOf ArrayRef Str );
  2         5  
  2         117  
6 2     2   742 use Math::Cephes::Fraction qw(:fract);
  2         11972  
  2         204  
7 2     2   1094 use Math::BigRat;
  2         149048  
  2         10  
8 2     2   1833 use namespace::clean;
  2         3  
  2         17  
9              
10             my $one = fract(1, 1);
11             my $neg_one = fract(1, -1);
12              
13             has '+tableau' => (
14             isa => ArrayRef [ ArrayRef [ InstanceOf ['Math::Cephes::Fraction'] ] ],
15             coerce => sub { &make_fractions($_[0]) },
16             );
17              
18             has '+display_tableau' => (
19             isa => ArrayRef [ ArrayRef [Str] ],
20             coerce => sub { &display_fractions($_[0]) },
21             );
22              
23             sub _build_objective_function_value {
24 0     0   0 my $self = shift;
25 0         0 return $self->tableau->[ $self->number_of_rows ]
26             ->[ $self->number_of_columns ]->rmul($neg_one)->as_string;
27             }
28              
29             =head1 Name
30              
31             Algorithm::Simplex::Rational - Rational model of the Simplex Algorithm
32              
33             =head1 Methods
34              
35             =head2 pivot
36              
37             Do the algebra of a Tucker/Bland Simplex pivot. i.e. Traverse from one node
38             to an adjacent node along the Simplex of feasible solutions.
39              
40             =cut
41              
42             sub pivot {
43              
44             my $self = shift;
45             my $pivot_row_number = shift;
46             my $pivot_column_number = shift;
47              
48             # Do tucker algebra on pivot row
49             my $scale =
50             $one->rdiv($self->tableau->[$pivot_row_number]->[$pivot_column_number]);
51             for my $j (0 .. $self->number_of_columns) {
52             $self->tableau->[$pivot_row_number]->[$j] =
53             $self->tableau->[$pivot_row_number]->[$j]->rmul($scale);
54             }
55             $self->tableau->[$pivot_row_number]->[$pivot_column_number] = $scale;
56              
57             # Do tucker algebra elsewhere
58             for my $i (0 .. $self->number_of_rows) {
59             if ($i != $pivot_row_number) {
60              
61             my $neg_a_ic =
62             $self->tableau->[$i]->[$pivot_column_number]->rmul($neg_one);
63             for my $j (0 .. $self->number_of_columns) {
64             $self->tableau->[$i]->[$j] =
65             $self->tableau->[$i]->[$j]->radd(
66             $neg_a_ic->rmul($self->tableau->[$pivot_row_number]->[$j]));
67             }
68             $self->tableau->[$i]->[$pivot_column_number] =
69             $neg_a_ic->rmul($scale);
70             }
71             }
72              
73             return;
74             }
75             after 'pivot' => sub {
76             my $self = shift;
77             $self->number_of_pivots_made($self->number_of_pivots_made + 1);
78             return;
79             };
80              
81             =head2 determine_simplex_pivot_columns
82              
83             Look at the basement row to see where positive entries exists.
84             Columns with positive entries in the basement row are pivot column candidates.
85              
86             Should run optimality test, is_optimal, first to insure
87             at least one positive entry exists in the basement row which then
88             means we can increase the objective value for the maximization problem.
89              
90             =cut
91              
92             sub determine_simplex_pivot_columns {
93 0     0 1 0 my $self = shift;
94              
95 0         0 my @simplex_pivot_column_numbers;
96 0         0 for my $col_num (0 .. $self->number_of_columns - 1) {
97 0         0 my $bottom_row_fraction =
98             $self->tableau->[ $self->number_of_rows ]->[$col_num];
99             my $bottom_row_numeric =
100 0         0 $bottom_row_fraction->{n} / $bottom_row_fraction->{d};
101 0 0       0 if ($bottom_row_numeric > 0) {
102 0         0 push(@simplex_pivot_column_numbers, $col_num);
103             }
104             }
105 0         0 return (@simplex_pivot_column_numbers);
106             }
107              
108             =head2 determine_positive_ratios
109              
110             Starting with the pivot column find the entry that yields the lowest
111             positive b to entry ratio that has lowest bland number in the event of ties.
112              
113             =cut
114              
115             sub determine_positive_ratios {
116 0     0 1 0 my $self = shift;
117 0         0 my $pivot_column_number = shift;
118              
119             # Build Ratios and Choose row(s) that yields min for the bland simplex column as a candidate pivot point.
120             # To be a Simplex pivot we must not consider negative entries
121 0         0 my @positive_ratios;
122             my @positive_ratio_row_numbers;
123              
124             #print "Column: $possible_pivot_column\n";
125 0         0 for my $row_num (0 .. $self->number_of_rows - 1) {
126 0         0 my $bottom_row_fraction =
127             $self->tableau->[$row_num]->[$pivot_column_number];
128             my $bottom_row_numeric =
129 0         0 $bottom_row_fraction->{n} / $bottom_row_fraction->{d};
130              
131 0 0       0 if ($bottom_row_numeric > 0) {
132             push(
133             @positive_ratios,
134             (
135             $self->tableau->[$row_num]->[ $self->number_of_columns ]
136             ->{n} *
137             $self->tableau->[$row_num]->[$pivot_column_number]->{d}
138             ) / (
139             $self->tableau->[$row_num]->[$pivot_column_number]->{n} *
140             $self->tableau->[$row_num]->[ $self->number_of_columns ]
141             ->{d}
142             )
143 0         0 );
144              
145             # Track the rows that give ratios
146 0         0 push @positive_ratio_row_numbers, $row_num;
147             }
148             }
149 0         0 return (\@positive_ratios, \@positive_ratio_row_numbers);
150             }
151              
152             =head2 is_optimal
153              
154             Return 1 if the current solution is optimal, 0 otherwise.
155              
156             Check basement row for having all non-positive entries which
157             would => optimal (while in phase 2).
158              
159             =cut
160              
161             sub is_optimal {
162 12     12 1 2745 my $self = shift;
163              
164 12         241 for my $j (0 .. $self->number_of_columns - 1) {
165 40         1302 my $basement_row_fraction =
166             $self->tableau->[ $self->number_of_rows ]->[$j];
167             my $basement_row_numeric =
168 40         1439 $basement_row_fraction->{n} / $basement_row_fraction->{d};
169 40 50       739 if ($basement_row_numeric > 0) {
170 0         0 return 0;
171             }
172             }
173 12         45 return 1;
174             }
175              
176             =head2 current_solution
177              
178             Return both the primal (max) and dual (min) solutions for the tableau.
179              
180             =cut
181              
182             sub current_solution {
183 0     0 1 0 my $self = shift;
184              
185             # Report the Current Solution as primal dependents and dual dependents.
186 0         0 my @y = @{ $self->y_variables };
  0         0  
187 0         0 my @u = @{ $self->u_variables };
  0         0  
188              
189             # Dependent Primal Variables
190 0         0 my %primal_solution;
191 0         0 for my $i (0 .. $#y) {
192 0         0 my $rational = $self->tableau->[$i]->[ $self->number_of_columns ];
193 0         0 $primal_solution{ $y[$i]->{generic} } = $rational->as_string;
194             }
195              
196             # Dependent Dual Variables
197 0         0 my %dual_solution;
198 0         0 for my $j (0 .. $#u) {
199 0         0 my $rational =
200             $self->tableau->[ $self->number_of_rows ]->[$j]->rmul($neg_one);
201 0         0 $dual_solution{ $u[$j]->{generic} } = $rational->as_string;
202             }
203              
204 0         0 return (\%primal_solution, \%dual_solution);
205             }
206              
207             =head2 Coercions
208              
209             =head3 make_fractions
210              
211             Make each rational entry a Math::Cephes::Fraction object
212             with the help of Math::BigRat
213              
214             =cut
215              
216             sub make_fractions {
217 12     12 1 25 my $tableau = shift;
218              
219 12         20 for my $i (0 .. scalar @{$tableau} - 1) {
  12         39  
220 62         7381 for my $j (0 .. scalar @{ $tableau->[0] } - 1) {
  62         151  
221              
222             # Using Math::BigRat to make fraction from decimal
223 276         35848 my $x = Math::BigRat->new($tableau->[$i]->[$j]);
224 276         195626 $tableau->[$i]->[$j] = fract($x->numerator, $x->denominator);
225             }
226             }
227 12         2165 return $tableau;
228             }
229              
230             =head3 display_fractions
231              
232             Convert each fraction object entry into a string.
233              
234             =cut
235              
236             sub display_fractions {
237 0     0 1   my $fraction_tableau = shift;
238              
239 0           my $display_tableau;
240 0           for my $i (0 .. scalar @{$fraction_tableau} - 1) {
  0            
241 0           for my $j (0 .. scalar @{ $fraction_tableau->[0] } - 1) {
  0            
242 0           $display_tableau->[$i]->[$j] =
243             $fraction_tableau->[$i]->[$j]->as_string;
244             }
245             }
246 0           return $display_tableau;
247              
248             }
249              
250             1;