view release on metacpan or  search on metacpan

lib/Math/LP.pm  view on Meta::CPAN

    # 3. copy the results to the appropriate Math::LP objects
    $this->update_variable_values($lprec);
    $this->update_slacks($lprec);
    $this->update_dual_values($lprec);

    ### 4. delete the lprec struct
    ##Math::LP::Solve::delete_lp($lprec);

    # 5. return true iff succeeded
    return $this->{solver_status} == $OPTIMAL; 
        # I am not sure whether this is the wanted behaviour for $lag_solve == 1
}
sub make_coeff_array {
    my Math::LP                    $this = shift;
    my Math::LP::LinearCombination $lc   = shift;

    # get a zero-initialized coefficient buffer
    my $array = $this->get_dbuf($this->nr_cols() + 1, 0.0); 
        # +1 for the 0'th column, which does not represent a variable

    # fill out the coefficients
    Math::LP::Solve::ptrset($array,$_->{coeff},$_->{var}->{col_index}) foreach values %{$lc->get_entries()};

    return $array;
}
sub make_lprec { # construct an lprec struct for the LP
    my Math::LP $this = shift;
    my $lprec = Math::LP::Solve::make_lp(0,$this->nr_cols()); # no constraints yet, correct nr. of variables
    
    # process all constraints
    foreach my $constr (@{$this->{constraints}}) {
        Math::LP::Solve::add_constraint($lprec,$this->make_coeff_array($constr->{lhs}),$constr->{type},$constr->{rhs});

	# Setting of the row name is disabled: it is not needed
        #Math::LP::Solve::lprec_row_name_set($lprec,$constr->{index},$constr->{name})
	#    if defined $constr->{name};
    }

    # process all variables 
    foreach my $var (values %{$this->{variables}}) {
	&Math::LP::Solve::set_int($lprec,$var->{col_index},1) if $var->{is_int};
	&Math::LP::Solve::set_upbo($lprec,$var->{col_index},$var->{upper_bound});
	&Math::LP::Solve::set_lowbo($lprec,$var->{col_index},$var->{lower_bound});
	# Setting of the col name is disabled: it is not needed and triggered a bug I still do not understand
	#Math::LP::Solve::lprec_col_name_set($lprec,$var->{col_index},$var->{name});
    }

    # set the objective function
    if(defined($this->{objective_function})) {
        Math::LP::Solve::set_obj_fn($lprec,$this->make_coeff_array($this->{objective_function}));
	if   ($this->{type} == $MAX) { Math::LP::Solve::set_maxim($lprec); }
	elsif($this->{type} == $MIN) { Math::LP::Solve::set_minim($lprec); }
	else {
	    $this->croak('No objective function type ($MAX or $MIN) set for solving');
	}
    }
    
    return $lprec;
}
sub update_variable_values { # copies the variable values to the variable objects
    my Math::LP $this = shift;
    my $lprec = shift;
    
    # the variable values are found in the solution vector
    my $solution = Math::LP::Solve::lprec_best_solution_get($lprec);

    # The index offset is explained as follows
    #   + 1          because of the objective function value
    #   + nr_rows()  because of the slacks
    #   - 1          because the 1st variable has index 1, not 0
    my $offset = $this->nr_rows(); 

    # copy the appropriate value for each variable
    foreach(values %{$this->{variables}}) {
	my $var_index = $_->{col_index};
	$_->{value} = Math::LP::Solve::ptrvalue($solution,$offset+$var_index);
    }
}
sub update_slacks {
    my Math::LP $this = shift;
    my $lprec = shift;
    
    # the slacks are fetched from the solution vector
    my $solution = Math::LP::Solve::lprec_best_solution_get($lprec);

    # copy the appropriate slack for each constraint
    foreach(@{$this->{constraints}}) {
	my $row_index = $_->{row_index};

	# The net offset used for fetching the row slack is calculated as follows:
	#   + 1 because of the objective function value
	#   - 1 because the 1st row has index 1, not 0
	my $buggy_slack = Math::LP::Solve::ptrvalue($solution,$row_index);

	# Due to a bug (?), lp_solve does not return the slack for each
	# constraint, but the evaluation of the lhs for the optimal variable
	# values.
	$_->{lhs}->{value} = $buggy_slack;

        # The real slack is easily derived from the lhs value.
	$_->{slack} = $_->{rhs} - $buggy_slack;
    }

    # Also fetch the objective function value
    if(defined($this->{objective_function})) {
	$this->{objective_function}->{value} = Math::LP::Solve::ptrvalue($solution,0);
    }
}
sub update_dual_values {
    my Math::LP $this = shift;
    my $lprec = shift;

    # the dual values are fetched from the duals vector
    my $duals = Math::LP::Solve::lprec_duals_get($lprec);

    # copy the appropriate dual value for each constraint
    foreach(@{$this->{constraints}}) {
	my $row_index = $_->{row_index};
	$_->{dual_value} = Math::LP::Solve::ptrvalue($duals,$row_index)
    }
}

### Queries
sub optimum {
    my Math::LP $this = shift;
    return undef if !defined($this->{objective_function});
    return $this->{objective_function}->{value};
}

sub get_constraints {
    my Math::LP $this = shift;
    wantarray ? @{$this->{constraints}} : $this->{constraints};
}

sub get_variables {
    my Math::LP $this = shift;
    my $rh_v = $this->{variables};
    my @vars = map { $rh_v->{$_} } sort keys %$rh_v;
    wantarray ? @vars : \@vars;
}

### IO
sub stringify_lindo {
    my Math::LP $this = shift;
    my $str;

    # the objective function
    my $type = $this->{type};
    if($type == $MAX) {
	$str = 'max ';
    }
    elsif($type == $MIN) {
	$str = 'min ';
    }
    else {
	die "Found LP with unrecognized type. Stopped";
    }
    $str .= $this->{objective_function}->stringify() . "\n";

    # the constraints
    $str .= "subject to\n";
    foreach(@{$this->{constraints}}) {
	$str .= "  " . $_->stringify() . "\n";
    }
    $str .= "end\n";

    # declaration of integer variables
    foreach(grep { $_->{is_int} } @{$this->get_variables()}) {
	$str .= "gin " . $_->{name} . "\n";