File Coverage

blib/lib/Algorithm/Simplex/Float.pm
Criterion Covered Total %
statement 11 42 26.1
branch 2 8 25.0
condition n/a
subroutine 3 7 42.8
pod 5 5 100.0
total 21 62 33.8


line stmt bran cond sub pod time code
1             package Algorithm::Simplex::Float;
2 1     1   23835 use Moo;
  1         17408  
  1         6  
3             extends 'Algorithm::Simplex';
4             with 'Algorithm::Simplex::Role::Solve';
5 1     1   2734 use namespace::clean;
  1         14412  
  1         12  
6              
7             my $one = 1;
8             my $neg_one = -1;
9             my $EMPTY_STRING = q();
10              
11             =head1 Name
12              
13             Algorithm::Simplex::Float - Float model of the Simplex Algorithm
14              
15             =head1 Methods
16              
17             =head2 pivot
18              
19             Do the algebra of a Tucker/Bland pivot. i.e. Traverse from one node to an
20             adjacent node along the Simplex of feasible solutions.
21              
22             =cut
23              
24             sub pivot {
25              
26             my $self = shift;
27             my $pivot_row_number = shift;
28             my $pivot_column_number = shift;
29              
30             # Do tucker algebra on pivot row
31             my $scale =
32             $one / ($self->tableau->[$pivot_row_number]->[$pivot_column_number]);
33             for my $j (0 .. $self->number_of_columns) {
34             $self->tableau->[$pivot_row_number]->[$j] =
35             $self->tableau->[$pivot_row_number]->[$j] * ($scale);
36             }
37             $self->tableau->[$pivot_row_number]->[$pivot_column_number] = $scale;
38              
39             # Do tucker algebra elsewhere
40             for my $i (0 .. $self->number_of_rows) {
41             if ($i != $pivot_row_number) {
42              
43             my $neg_a_ic =
44             $self->tableau->[$i]->[$pivot_column_number] * ($neg_one);
45             for my $j (0 .. $self->number_of_columns) {
46             $self->tableau->[$i]->[$j] =
47             $self->tableau->[$i]->[$j] +
48             ($neg_a_ic * ($self->tableau->[$pivot_row_number]->[$j]));
49             }
50             $self->tableau->[$i]->[$pivot_column_number] = $neg_a_ic * ($scale);
51             }
52             }
53              
54             return;
55             }
56              
57             # Count pivots made
58             after 'pivot' => sub {
59             my $self = shift;
60              
61             # TODO: Confirm whether clear is needed or not. Appears not in testing.
62             # $self->clear_display_tableau;
63             $self->number_of_pivots_made($self->number_of_pivots_made + 1);
64             return;
65             };
66              
67             =head2 is_optimal
68              
69             Check the basement row to see if any positive entries exist. Existence of
70             a positive entry means the solution is sub-optimal and optimal otherwise.
71             This is how we decide when to stop the algorithm.
72              
73             Use EPSILON instead of zero because we're dealing with floats (imperfect numbers).
74              
75             =cut
76              
77             sub is_optimal {
78 0     0 1 0 my $self = shift;
79              
80 0         0 for my $j (0 .. $self->number_of_columns - 1) {
81 0 0       0 if ($self->tableau->[ $self->number_of_rows ]->[$j] > $self->EPSILON) {
82 0         0 return 0;
83             }
84             }
85 0         0 return 1;
86             }
87              
88             =head2 determine_simplex_pivot_columns
89              
90             Find the columns that are candiates for pivoting in. This is based on
91             their basement row value being greater than zero.
92              
93             =cut
94              
95             sub determine_simplex_pivot_columns {
96 0     0 1 0 my $self = shift;
97              
98 0         0 my @simplex_pivot_column_numbers;
99              
100             # Assumes the existence of at least one pivot (use optimality check to insure this)
101             # According to Nering and Tucker (1993) page 26
102             # "selected a column with a positive entry in the basement row."
103             # NOTE: My intuition indicates a pivot could still take place but no gains would be made
104             # when the cost is zero. This would not lead us to optimality, but if we were
105             # already in an optimal state if may (should) lead to another optimal state.
106             # This would only apply then in the optimal case, i.e. all entries non-positive.
107 0         0 for my $col_num (0 .. $self->number_of_columns - 1) {
108 0 0       0 if ($self->tableau->[ $self->number_of_rows ]->[$col_num] >
109             $self->EPSILON)
110             {
111 0         0 push(@simplex_pivot_column_numbers, $col_num);
112             }
113             }
114 0         0 return (@simplex_pivot_column_numbers);
115             }
116              
117             =head2 determine_positive_ratios
118              
119             Once a a pivot column has been chosen then we choose a pivot row based on
120             the smallest postive ration. This function is a helper to achieve that.
121              
122             =cut
123              
124             sub determine_positive_ratios {
125 0     0 1 0 my $self = shift;
126 0         0 my $pivot_column_number = shift;
127              
128             # Build Ratios and Choose row(s) that yields min for the bland simplex column as a candidate pivot point.
129             # To be a Simplex pivot we must not consider negative entries
130 0         0 my @positive_ratios;
131             my @positive_ratio_row_numbers;
132              
133             #print "Column: $possible_pivot_column\n";
134 0         0 for my $row_num (0 .. $self->number_of_rows - 1) {
135 0 0       0 if ($self->tableau->[$row_num]->[$pivot_column_number] > $self->EPSILON)
136             {
137 0         0 push(@positive_ratios,
138             $self->tableau->[$row_num]->[ $self->number_of_columns ] /
139             $self->tableau->[$row_num]->[$pivot_column_number]);
140              
141             # Track the rows that give ratios
142 0         0 push @positive_ratio_row_numbers, $row_num;
143             }
144             }
145              
146 0         0 return (\@positive_ratios, \@positive_ratio_row_numbers);
147             }
148              
149             =head2 current_solution
150              
151             Return both the primal (max) and dual (min) solutions for the tableau.
152              
153             =cut
154              
155             sub current_solution {
156 0     0 1 0 my $self = shift;
157              
158             # Report the Current Solution as primal dependents and dual dependents.
159 0         0 my @y = @{ $self->y_variables };
  0         0  
160 0         0 my @u = @{ $self->u_variables };
  0         0  
161              
162             # Dependent Primal Variables
163 0         0 my %primal_solution;
164 0         0 for my $i (0 .. $#y) {
165 0         0 $primal_solution{ $y[$i]->{generic} } =
166             $self->tableau->[$i]->[ $self->number_of_columns ];
167             }
168              
169             # Dependent Dual Variables
170 0         0 my %dual_solution;
171 0         0 for my $j (0 .. $#u) {
172 0         0 $dual_solution{ $u[$j]->{generic} } =
173             $self->tableau->[ $self->number_of_rows ]->[$j] * -1;
174             }
175              
176 0         0 return (\%primal_solution, \%dual_solution);
177             }
178              
179             =head2 is_basic_feasible_solution
180              
181             Check if we have any negative values in the right hand column.
182              
183             =cut
184              
185             sub is_basic_feasible_solution {
186 2     2 1 811 my $self = shift;
187              
188 2         31 for my $i (0 .. $self->number_of_rows - 1) {
189 3 100       1278 if ($self->tableau->[$i]->[ $self->number_of_columns ] <
190             -($self->EPSILON))
191             {
192 1         490 return 0;
193             }
194             }
195 1         59 return 1;
196             }
197              
198             1;