1371 lines
46 KiB
Prolog
1371 lines
46 KiB
Prolog
/* $Id$
|
|
|
|
Part of SWI-Prolog
|
|
|
|
Author: Markus Triska
|
|
E-mail: triska@gmx.at
|
|
WWW: http://www.swi-prolog.org
|
|
Copyright (C): 2005-2009, Markus Triska
|
|
|
|
This program is free software; you can redistribute it and/or
|
|
modify it under the terms of the GNU General Public License
|
|
as published by the Free Software Foundation; either version 2
|
|
of the License, or (at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU Lesser General Public
|
|
License along with this library; if not, write to the Free Software
|
|
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
|
|
|
As a special exception, if you link this library with other files,
|
|
compiled with a Free Software compiler, to produce an executable, this
|
|
library does not by itself cause the resulting executable to be covered
|
|
by the GNU General Public License. This exception does not however
|
|
invalidate any other reasons why the executable file might be covered by
|
|
the GNU General Public License.
|
|
*/
|
|
|
|
|
|
:- module(simplex,
|
|
[
|
|
assignment/2,
|
|
constraint/3,
|
|
constraint/4,
|
|
constraint_add/4,
|
|
gen_state/1,
|
|
gen_state_clpr/1,
|
|
gen_state_clpr/2,
|
|
maximize/3,
|
|
minimize/3,
|
|
objective/2,
|
|
shadow_price/3,
|
|
transportation/4,
|
|
variable_value/3
|
|
]).
|
|
|
|
:- use_module(library(clpr)).
|
|
:- use_module(library(assoc)).
|
|
:- use_module(library(pio)).
|
|
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
CLP(R) bindings
|
|
the (unsolved) state is stored as a structure of the form
|
|
clpr_state(Options, Cs, Is)
|
|
Options: list of Option=Value pairs, currently only eps=Eps
|
|
Cs: list of constraints, i.e., structures of the form
|
|
c(Name, Left, Op, Right)
|
|
anonymous constraints have Name == 0
|
|
Is: list of integral variables
|
|
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
gen_state_clpr(State) :- gen_state_clpr([], State).
|
|
|
|
gen_state_clpr(Options, State) :-
|
|
( memberchk(eps=_, Options) -> Options1 = Options
|
|
; Options1 = [eps=1e-6|Options]
|
|
),
|
|
State = clpr_state(Options1, [], []).
|
|
|
|
clpr_state_options(clpr_state(Os, _, _), Os).
|
|
clpr_state_constraints(clpr_state(_, Cs, _), Cs).
|
|
clpr_state_integrals(clpr_state(_, _, Is), Is).
|
|
clpr_state_add_integral(I, clpr_state(Os, Cs, Is), clpr_state(Os, Cs, [I|Is])).
|
|
clpr_state_add_constraint(C, clpr_state(Os, Cs, Is), clpr_state(Os, [C|Cs], Is)).
|
|
clpr_state_set_constraints(Cs, clpr_state(Os,_,Is), clpr_state(Os, Cs, Is)).
|
|
|
|
clpr_constraint(Name, Constraint, S0, S) :-
|
|
( Constraint = integral(Var) -> clpr_state_add_integral(Var, S0, S)
|
|
; Constraint =.. [Op,Left,Right],
|
|
coeff_one(Left, Left1),
|
|
clpr_state_add_constraint(c(Name, Left1, Op, Right), S0, S)
|
|
).
|
|
|
|
clpr_constraint(Constraint, S0, S) :-
|
|
clpr_constraint(0, Constraint, S0, S).
|
|
|
|
clpr_shadow_price(clpr_solved(_,_,Duals,_), Name, Value) :-
|
|
memberchk(Name-Value0, Duals),
|
|
Value is Value0.
|
|
%( var(Value0) ->
|
|
% Value = 0
|
|
%;
|
|
% Value is Value0
|
|
%).
|
|
|
|
|
|
|
|
clpr_make_variables(Cs, Aliases) :-
|
|
clpr_constraints_variables(Cs, Variables0, []),
|
|
sort(Variables0, Variables1),
|
|
clpr_aliases(Variables1, Aliases).
|
|
|
|
clpr_constraints_variables([]) --> [].
|
|
clpr_constraints_variables([c(_, Left, _, _)|Cs]) -->
|
|
variables(Left),
|
|
clpr_constraints_variables(Cs).
|
|
|
|
clpr_aliases([], []).
|
|
clpr_aliases([Var|Vars], [Var-_|Rest]) :-
|
|
clpr_aliases(Vars, Rest).
|
|
|
|
clpr_set_up([], _).
|
|
clpr_set_up([C|Cs], Aliases) :-
|
|
C = c(_Name, Left, Op, Right),
|
|
clpr_translate_linsum(Left, Aliases, LinSum),
|
|
CLPRConstraint =.. [Op, LinSum, Right],
|
|
clpr:{ CLPRConstraint },
|
|
clpr_set_up(Cs, Aliases).
|
|
|
|
clpr_set_up_noneg([], _).
|
|
clpr_set_up_noneg([Var|Vs], Aliases) :-
|
|
memberchk(Var-CLPVar, Aliases),
|
|
{ CLPVar >= 0 },
|
|
clpr_set_up_noneg(Vs, Aliases).
|
|
|
|
clpr_translate_linsum([], _, 0).
|
|
clpr_translate_linsum([Coeff*Var|Ls], Aliases, LinSum) :-
|
|
memberchk(Var-CLPVar, Aliases),
|
|
LinSum = Coeff*CLPVar + LinRest,
|
|
clpr_translate_linsum(Ls, Aliases, LinRest).
|
|
|
|
clpr_dual(Objective0, S0, DualValues) :-
|
|
clpr_state_constraints(S0, Cs0),
|
|
clpr_constraints_variables(Cs0, Variables0, []),
|
|
sort(Variables0, Variables1),
|
|
clpr_standard_form(Cs0, Cs1),
|
|
clpr_include_all_vars(Cs1, Variables1, Cs2),
|
|
clpr_merge_into(Variables1, Objective0, Objective, []),
|
|
clpr_unique_names(Cs2, 0, Names),
|
|
clpr_constraints_coefficients(Cs2, Coefficients),
|
|
transpose(Coefficients, TCs),
|
|
clpr_dual_constraints(TCs, Objective, Names, DualConstraints),
|
|
clpr_nonneg_constraints(Cs2, Names, DualNonNeg, []),
|
|
append(DualConstraints, DualNonNeg, DualConstraints1),
|
|
clpr_dual_objective(Cs2, Names, DualObjective),
|
|
clpr_make_variables(DualConstraints1, Aliases),
|
|
clpr_set_up(DualConstraints1, Aliases),
|
|
clpr_translate_linsum(DualObjective, Aliases, LinExpr),
|
|
minimize(LinExpr),
|
|
Aliases = DualValues.
|
|
|
|
|
|
|
|
clpr_dual_objective([], _, []).
|
|
clpr_dual_objective([C|Cs], [Name|Names], [Right*Name|Os]) :-
|
|
C = c(_, _, _, Right),
|
|
clpr_dual_objective(Cs, Names, Os).
|
|
|
|
clpr_nonneg_constraints([], _, Nons, Nons).
|
|
clpr_nonneg_constraints([C|Cs], [Name|Names], Nons0, Nons) :-
|
|
C = c(_, _, Op, _),
|
|
( Op == (=<) -> Nons0 = [c(0, [1*Name], (>=), 0)|Rest]
|
|
; Nons0 = Rest
|
|
),
|
|
clpr_nonneg_constraints(Cs, Names, Rest, Nons).
|
|
|
|
|
|
clpr_dual_constraints([], [], _, []).
|
|
clpr_dual_constraints([Coeffs|Cs], [O*_|Os], Names, [Constraint|Constraints]) :-
|
|
clpr_dual_linsum(Coeffs, Names, Linsum),
|
|
Constraint = c(0, Linsum, (>=), O),
|
|
clpr_dual_constraints(Cs, Os, Names, Constraints).
|
|
|
|
|
|
clpr_dual_linsum([], [], []).
|
|
clpr_dual_linsum([Coeff|Coeffs], [Name|Names], [Coeff*Name|Rest]) :-
|
|
clpr_dual_linsum(Coeffs, Names, Rest).
|
|
|
|
|
|
clpr_constraints_coefficients([], []).
|
|
clpr_constraints_coefficients([C|Cs], [Coeff|Coeffs]) :-
|
|
C = c(_, Left, _, _),
|
|
all_coeffs(Left, Coeff),
|
|
clpr_constraints_coefficients(Cs, Coeffs).
|
|
|
|
all_coeffs([], []).
|
|
all_coeffs([Coeff*_|Cs], [Coeff|Rest]) :-
|
|
all_coeffs(Cs, Rest).
|
|
|
|
|
|
clpr_unique_names([], _, []).
|
|
clpr_unique_names([C0|Cs0], Num, [N|Ns]) :-
|
|
C0 = c(Name, _, _, _),
|
|
( Name == 0 -> N = Num, Num1 is Num + 1
|
|
; N = Name, Num1 = Num
|
|
),
|
|
clpr_unique_names(Cs0, Num1, Ns).
|
|
|
|
clpr_include_all_vars([], _, []).
|
|
clpr_include_all_vars([C0|Cs0], Variables, [C|Cs]) :-
|
|
C0 = c(Name, Left0, Op, Right),
|
|
clpr_merge_into(Variables, Left0, Left, []),
|
|
C = c(Name, Left, Op, Right),
|
|
clpr_include_all_vars(Cs0, Variables, Cs).
|
|
|
|
clpr_merge_into([], _, Ls, Ls).
|
|
clpr_merge_into([V|Vs], Left, Ls0, Ls) :-
|
|
( member(Coeff*V, Left) ->
|
|
Ls0 = [Coeff*V|Rest]
|
|
;
|
|
Ls0 = [0*V|Rest]
|
|
),
|
|
clpr_merge_into(Vs, Left, Rest, Ls).
|
|
|
|
|
|
|
|
|
|
clpr_maximize(Expr0, S0, S) :-
|
|
coeff_one(Expr0, Expr),
|
|
clpr_state_constraints(S0, Cs),
|
|
clpr_make_variables(Cs, Aliases),
|
|
clpr_set_up(Cs, Aliases),
|
|
clpr_constraints_variables(Cs, Variables0, []),
|
|
sort(Variables0, Variables1),
|
|
clpr_set_up_noneg(Variables1, Aliases),
|
|
clpr_translate_linsum(Expr, Aliases, LinExpr),
|
|
clpr_state_integrals(S0, Is),
|
|
( Is == [] ->
|
|
maximize(LinExpr),
|
|
Sup is LinExpr,
|
|
clpr_dual(Expr, S0, DualValues),
|
|
S = clpr_solved(Sup, Aliases, DualValues, S0)
|
|
;
|
|
clpr_state_options(S0, Options),
|
|
memberchk(eps=Eps, Options),
|
|
clpr_fetch_vars(Is, Aliases, Vars),
|
|
bb_inf(Vars, -LinExpr, Sup, Vertex, Eps),
|
|
clpr_merge_vars(Is, Vertex, Values),
|
|
% what about the dual in MIPs?
|
|
Sup1 is -Sup,
|
|
S = clpr_solved(Sup1, Values, [], S0)
|
|
).
|
|
|
|
clpr_minimize(Expr0, S0, S) :-
|
|
coeff_one(Expr0, Expr1),
|
|
clpr_all_negate(Expr1, Expr2),
|
|
clpr_maximize(Expr2, S0, S1),
|
|
S1 = clpr_solved(Sup, Values, Duals, S0),
|
|
Inf is -Sup,
|
|
S = clpr_solved(Inf, Values, Duals, S0).
|
|
|
|
clpr_merge_vars([], [], []).
|
|
clpr_merge_vars([I|Is], [V|Vs], [I-V|Rest]) :-
|
|
clpr_merge_vars(Is, Vs, Rest).
|
|
|
|
clpr_fetch_vars([], _, []).
|
|
clpr_fetch_vars([Var|Vars], Aliases, [X|Xs]) :-
|
|
memberchk(Var-X, Aliases),
|
|
clpr_fetch_vars(Vars, Aliases, Xs).
|
|
|
|
clpr_variable_value(clpr_solved(_, Aliases, _, _), Variable, Value) :-
|
|
memberchk(Variable-Value0, Aliases),
|
|
Value is Value0.
|
|
%( var(Value0) ->
|
|
% Value = 0
|
|
%;
|
|
% Value is Value0
|
|
%).
|
|
|
|
clpr_objective(clpr_solved(Obj, _, _, _), Obj).
|
|
|
|
clpr_standard_form([], []).
|
|
clpr_standard_form([c(Name, Left, Op, Right)|Cs], [S|Ss]) :-
|
|
clpr_standard_form_(Op, Name, Left, Right, S),
|
|
clpr_standard_form(Cs, Ss).
|
|
|
|
clpr_standard_form_((=), Name, Left, Right, c(Name, Left, (=), Right)).
|
|
clpr_standard_form_((>=), Name, Left, Right, c(Name, Left1, (=<), Right1)) :-
|
|
Right1 is -Right,
|
|
clpr_all_negate(Left, Left1).
|
|
clpr_standard_form_((=<), Name, Left, Right, c(Name, Left, (=<), Right)).
|
|
|
|
clpr_all_negate([], []).
|
|
clpr_all_negate([Coeff0*Var|As], [Coeff1*Var|Ns]) :-
|
|
Coeff1 is -Coeff0,
|
|
clpr_all_negate(As, Ns).
|
|
|
|
|
|
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
General Simplex Algorithm
|
|
Structures used:
|
|
|
|
tableau(Objective, Variables, Indicators, Constraints)
|
|
*) objective function, represented as row
|
|
*) list of variables corresponding to columns
|
|
*) indicators denoting which variables are still active
|
|
*) constraints as rows
|
|
|
|
row(Var, Left, Right)
|
|
*) the basic variable corresponding to this row
|
|
*) coefficients of the left-hand side of the constraint
|
|
*) right-hand side of the constraint
|
|
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
|
|
find_row(Variable, [Row|Rows], R) :-
|
|
Row = row(V, _, _),
|
|
( V == Variable -> R = Row
|
|
; find_row(Variable, Rows, R)
|
|
).
|
|
|
|
|
|
variable_value(State, Variable, Value) :-
|
|
functor(State, F, _),
|
|
( F == solved ->
|
|
solved_tableau(State, Tableau),
|
|
tableau_rows(Tableau, Rows),
|
|
( find_row(Variable, Rows, Row) -> Row = row(_, _, Value)
|
|
; Value = 0
|
|
)
|
|
; F == clpr_solved -> clpr_variable_value(State, Variable, Value)
|
|
).
|
|
|
|
all_vars_zero([], _).
|
|
all_vars_zero([_Coeff*Var|Vars], State) :-
|
|
variable_value(State, Var, 0),
|
|
all_vars_zero(Vars, State).
|
|
|
|
list_first(Ls, F, Index) :- once(nth0(Index, Ls, F)).
|
|
|
|
shadow_price(State, Name, Value) :-
|
|
functor(State, F, _),
|
|
( F == solved ->
|
|
solved_tableau(State, Tableau),
|
|
tableau_objective(Tableau, row(_,Left,_)),
|
|
tableau_variables(Tableau, Variables),
|
|
solved_names(State, Names),
|
|
memberchk(user(Name)-Var, Names),
|
|
list_first(Variables, Var, Nth0),
|
|
nth0(Nth0, Left, Value)
|
|
; F == clpr_solved -> clpr_shadow_price(State, Name, Value)
|
|
).
|
|
|
|
objective(State, Obj) :-
|
|
functor(State, F, _),
|
|
( F == solved ->
|
|
solved_tableau(State, Tableau),
|
|
tableau_objective(Tableau, Objective),
|
|
Objective = row(_, _, Obj)
|
|
; clpr_objective(State, Obj)
|
|
).
|
|
|
|
% interface functions that access tableau components
|
|
|
|
tableau_objective(tableau(Obj, _, _, _), Obj).
|
|
tableau_rows(tableau(_, _, _, Rows), Rows).
|
|
tableau_indicators(tableau(_, _, Inds, _), Inds).
|
|
tableau_variables(tableau(_, Vars, _, _), Vars).
|
|
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
interface functions that access and modify state components
|
|
|
|
state is a structure of the form
|
|
state(Num, Names, Cs, Is)
|
|
Num: used to obtain new unique names for slack variables in a side-effect
|
|
free way (increased by one and threaded through)
|
|
Names: list of Name-Var, correspondence between constraint-names and
|
|
names of slack/artificial variables to obtain shadow prices later
|
|
Cs: list of constraints
|
|
Is: list of integer variables
|
|
|
|
constraints are initially represented as c(Name, Left, Op, Right),
|
|
and after normalizing as c(Var, Left, Right). Name of unnamed constraints
|
|
is 0. The distinction is important for merging constraints (mainly in
|
|
branch and bound) with existing ones.
|
|
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
|
|
constraint_name(c(Name, _, _, _), Name).
|
|
constraint_op(c(_, _, Op, _), Op).
|
|
constraint_left(c(_, Left, _, _), Left).
|
|
constraint_right(c(_, _, _, Right), Right).
|
|
|
|
gen_state(state(0,[],[],[])).
|
|
|
|
state_add_constraint(C, S0, S) :-
|
|
( constraint_name(C, 0), constraint_left(C, [_Coeff*_Var]) ->
|
|
state_merge_constraint(C, S0, S)
|
|
; state_add_constraint_(C, S0, S)
|
|
).
|
|
|
|
state_add_constraint_(C, state(VID,Ns,Cs,Is), state(VID,Ns,[C|Cs],Is)).
|
|
|
|
state_merge_constraint(C, S0, S) :-
|
|
constraint_left(C, [Coeff0*Var0]),
|
|
constraint_right(C, Right0),
|
|
constraint_op(C, Op),
|
|
( Coeff0 =:= 0 ->
|
|
( Op == (=) -> Right0 =:= 0, S0 = S
|
|
; Op == (=<) -> S0 = S
|
|
; Op == (>=) -> Right0 =:= 0, S0 = S
|
|
)
|
|
; Coeff0 < 0 -> state_add_constraint_(C, S0, S)
|
|
; Right is Right0 rdiv Coeff0,
|
|
state_constraints(S0, Cs),
|
|
( select(c(0, [1*Var0], Op, CRight), Cs, RestCs) ->
|
|
( Op == (=) -> CRight =:= Right, S0 = S
|
|
; Op == (=<) ->
|
|
NewRight is min(Right, CRight),
|
|
NewCs = [c(0, [1*Var0], Op, NewRight)|RestCs],
|
|
state_set_constraints(NewCs, S0, S)
|
|
; Op == (>=) ->
|
|
NewRight is max(Right, CRight),
|
|
NewCs = [c(0, [1*Var0], Op, NewRight)|RestCs],
|
|
state_set_constraints(NewCs, S0, S)
|
|
)
|
|
; state_add_constraint_(c(0, [1*Var0], Op, Right), S0, S)
|
|
)
|
|
).
|
|
|
|
|
|
state_add_name(Name, Var), [state(VID,[Name-Var|Ns],Cs,Is)] -->
|
|
[state(VID,Ns,Cs,Is)].
|
|
|
|
state_add_integral(Var, state(VID,Ns,Cs,Is), state(VID,Ns,Cs,[Var|Is])).
|
|
|
|
state_constraints(state(_, _, Cs, _), Cs).
|
|
state_names(state(_,Names,_,_), Names).
|
|
state_integrals(state(_,_,_,Is), Is).
|
|
state_set_constraints(Cs, state(VID,Ns,_,Is), state(VID,Ns,Cs,Is)).
|
|
state_set_integrals(Is, state(VID,Ns,Cs,_), state(VID,Ns,Cs,Is)).
|
|
|
|
|
|
state_next_var(VarID0), [state(VarID1,Names,Cs,Is)] -->
|
|
[state(VarID0,Names,Cs,Is)],
|
|
{ VarID1 is VarID0 + 1 }.
|
|
|
|
solved_tableau(solved(Tableau, _, _), Tableau).
|
|
solved_names(solved(_, Names,_), Names).
|
|
solved_integrals(solved(_,_,Is), Is).
|
|
|
|
% User-named constraints are wrapped with user/1 to also allow "0" in
|
|
% constraint names.
|
|
|
|
constraint(C, S0, S) :-
|
|
functor(S0, F, _),
|
|
( F == state ->
|
|
( C = integral(Var) -> state_add_integral(Var, S0, S)
|
|
; constraint_(0, C, S0, S)
|
|
)
|
|
; F == clpr_state -> clpr_constraint(C, S0, S)
|
|
).
|
|
|
|
constraint(Name, C, S0, S) :- constraint_(user(Name), C, S0, S).
|
|
|
|
constraint_(Name, C, S0, S) :-
|
|
functor(S0, F, _),
|
|
( F == state ->
|
|
( C = integral(Var) -> state_add_integral(Var, S0, S)
|
|
; C =.. [Op, Left0, Right0],
|
|
coeff_one(Left0, Left),
|
|
Right0 >= 0,
|
|
Right is rationalize(Right0),
|
|
state_add_constraint(c(Name, Left, Op, Right), S0, S)
|
|
)
|
|
; F == clpr_state -> clpr_constraint(Name, C, S0, S)
|
|
).
|
|
|
|
constraint_add(Name, A, S0, S) :-
|
|
functor(S0, F, _),
|
|
( F == state ->
|
|
state_constraints(S0, Cs),
|
|
add_left(Cs, user(Name), A, Cs1),
|
|
state_set_constraints(Cs1, S0, S)
|
|
; F == clpr_state ->
|
|
clpr_state_constraints(S0, Cs),
|
|
add_left(Cs, Name, A, Cs1),
|
|
clpr_state_set_constraints(Cs1, S0, S)
|
|
).
|
|
|
|
|
|
add_left([c(Name,Left0,Op,Right)|Cs], V, A, [c(Name,Left,Op,Right)|Rest]) :-
|
|
( Name == V -> append(A, Left0, Left), Rest = Cs
|
|
; Left0 = Left, add_left(Cs, V, A, Rest)
|
|
).
|
|
|
|
branching_variable(State, Variable) :-
|
|
solved_integrals(State, Integrals),
|
|
member(Variable, Integrals),
|
|
variable_value(State, Variable, Value),
|
|
\+ integer(Value).
|
|
|
|
|
|
worth_investigating(ZStar0, _, _) :- var(ZStar0).
|
|
worth_investigating(ZStar0, AllInt, Z) :-
|
|
nonvar(ZStar0),
|
|
( AllInt =:= 1 -> Z1 is floor(Z)
|
|
; Z1 = Z
|
|
),
|
|
Z1 > ZStar0.
|
|
|
|
|
|
branch_and_bound(Objective, Solved, AllInt, ZStar0, ZStar, S0, S, Found) :-
|
|
objective(Solved, Z),
|
|
( worth_investigating(ZStar0, AllInt, Z) ->
|
|
( branching_variable(Solved, BrVar) ->
|
|
variable_value(Solved, BrVar, Value),
|
|
Value1 is floor(Value),
|
|
Value2 is Value1 + 1,
|
|
constraint([BrVar] =< Value1, S0, SubProb1),
|
|
( maximize_(Objective, SubProb1, SubSolved1) ->
|
|
Sub1Feasible = 1,
|
|
objective(SubSolved1, Obj1)
|
|
; Sub1Feasible = 0
|
|
),
|
|
constraint([BrVar] >= Value2, S0, SubProb2),
|
|
( maximize_(Objective, SubProb2, SubSolved2) ->
|
|
Sub2Feasible = 1,
|
|
objective(SubSolved2, Obj2)
|
|
; Sub2Feasible = 0
|
|
),
|
|
( Sub1Feasible =:= 1, Sub2Feasible =:= 1 ->
|
|
( Obj1 >= Obj2 ->
|
|
First = SubProb1,
|
|
Second = SubProb2,
|
|
FirstSolved = SubSolved1,
|
|
SecondSolved = SubSolved2
|
|
; First = SubProb2,
|
|
Second = SubProb1,
|
|
FirstSolved = SubSolved2,
|
|
SecondSolved = SubSolved1
|
|
),
|
|
branch_and_bound(Objective, FirstSolved, AllInt, ZStar0, ZStar1, First, Solved1, Found1),
|
|
branch_and_bound(Objective, SecondSolved, AllInt, ZStar1, ZStar2, Second, Solved2, Found2)
|
|
; Sub1Feasible =:= 1 ->
|
|
branch_and_bound(Objective, SubSolved1, AllInt, ZStar0, ZStar1, SubProb1, Solved1, Found1),
|
|
Found2 = 0
|
|
; Sub2Feasible =:= 1 ->
|
|
Found1 = 0,
|
|
branch_and_bound(Objective, SubSolved2, AllInt, ZStar0, ZStar2, SubProb2, Solved2, Found2)
|
|
; Found1 = 0, Found2 = 0
|
|
),
|
|
( Found1 =:= 1, Found2 =:= 1 -> S = Solved2, ZStar = ZStar2
|
|
; Found1 =:= 1 -> S = Solved1, ZStar = ZStar1
|
|
; Found2 =:= 1 -> S = Solved2, ZStar = ZStar2
|
|
; S = S0, ZStar = ZStar0
|
|
),
|
|
Found is max(Found1, Found2)
|
|
; S = Solved, ZStar = Z, Found = 1
|
|
)
|
|
; ZStar = ZStar0, S = S0, Found = 0
|
|
).
|
|
|
|
maximize(Z0, S0, S) :-
|
|
coeff_one(Z0, Z1),
|
|
functor(S0, F, _),
|
|
( F == state -> maximize_mip(Z1, S0, S)
|
|
; F == clpr_state -> clpr_maximize(Z1, S0, S)
|
|
).
|
|
|
|
maximize_mip(Z, S0, S) :-
|
|
maximize_(Z, S0, Solved),
|
|
state_integrals(S0, Is),
|
|
( Is == [] -> S = Solved
|
|
; % arrange it so that branch and bound branches on variables
|
|
% in the same order the integrality constraints were stated in
|
|
reverse(Is, Is1),
|
|
state_set_integrals(Is1, S0, S1),
|
|
( all_integers(Z, Is1) -> AllInt = 1
|
|
; AllInt = 0
|
|
),
|
|
branch_and_bound(Z, Solved, AllInt, _, _, S1, S, 1)
|
|
).
|
|
|
|
all_integers([], _).
|
|
all_integers([Coeff*V|Rest], Is) :-
|
|
integer(Coeff),
|
|
memberchk(V, Is),
|
|
all_integers(Rest, Is).
|
|
|
|
|
|
minimize(Z0, S0, S) :-
|
|
coeff_one(Z0, Z1),
|
|
functor(S0, F, _),
|
|
( F == state ->
|
|
linsum_negate(Z1, Z2),
|
|
maximize_mip(Z2, S0, S1),
|
|
solved_tableau(S1, tableau(Obj, Vars, Inds, Rows)),
|
|
solved_names(S1, Names),
|
|
Obj = row(z, Left0, Right0),
|
|
all_times(Left0, -1, Left),
|
|
Right is -Right0,
|
|
Obj1 = row(z, Left, Right),
|
|
state_integrals(S0, Is),
|
|
S = solved(tableau(Obj1, Vars, Inds, Rows), Names, Is)
|
|
; F == clpr_state -> clpr_minimize(Z1, S0, S)
|
|
).
|
|
|
|
op_pendant(>=, =<).
|
|
op_pendant(=<, >=).
|
|
|
|
constraints_collapse([], []).
|
|
constraints_collapse([C|Cs], Colls) :-
|
|
C = c(Name, Left, Op, Right),
|
|
( Name == 0, Left = [1*Var], op_pendant(Op, P) ->
|
|
Pendant = c(0, [1*Var], P, Right),
|
|
( select(Pendant, Cs, Rest) ->
|
|
Colls = [c(0, Left, (=), Right)|CollRest],
|
|
CsLeft = Rest
|
|
; Colls = [C|CollRest],
|
|
CsLeft = Cs
|
|
)
|
|
; Colls = [C|CollRest],
|
|
CsLeft = Cs
|
|
),
|
|
constraints_collapse(CsLeft, CollRest).
|
|
|
|
% solve a (relaxed) LP in standard form
|
|
|
|
maximize_(Z, S0, S) :-
|
|
state_constraints(S0, Cs0),
|
|
constraints_collapse(Cs0, Cs1),
|
|
phrase(constraints_normalize(Cs1, Cs, As0), [S0], [S1]),
|
|
flatten(As0, As1),
|
|
( As1 == [] ->
|
|
make_tableau(Z, Cs, Tableau0),
|
|
simplex(Tableau0, Tableau),
|
|
state_names(S1, Names),
|
|
state_integrals(S1, Is),
|
|
S = solved(Tableau, Names, Is)
|
|
; state_names(S1, Names),
|
|
state_integrals(S1, Is),
|
|
two_phase_simplex(Z, Cs, As1, Names, Is, S)
|
|
).
|
|
|
|
make_tableau(Z, Cs, Tableau) :-
|
|
ZC = c(_, Z, _),
|
|
phrase(constraints_variables([ZC|Cs]), Variables0),
|
|
sort(Variables0, Variables),
|
|
constraints_rows(Cs, Variables, Rows),
|
|
linsum_row(Variables, Z, Objective1),
|
|
all_times(Objective1, -1, Obj),
|
|
length(Variables, LVs),
|
|
length(Ones, LVs),
|
|
all_one(Ones),
|
|
Tableau = tableau(row(z, Obj, 0), Variables, Ones, Rows).
|
|
|
|
all_one([]).
|
|
all_one([1|Os]) :- all_one(Os).
|
|
|
|
proper_form([], _, _, Obj, Obj).
|
|
proper_form([_Coeff*A|As], Variables, Rows, Obj0, Obj) :-
|
|
( find_row(A, Rows, PivotRow) ->
|
|
list_first(Variables, A, Col),
|
|
row_eliminate(Obj0, PivotRow, Col, Obj1)
|
|
; Obj1 = Obj0
|
|
),
|
|
proper_form(As, Variables, Rows, Obj1, Obj).
|
|
|
|
|
|
two_phase_simplex(Z, Cs, As, Names, Is, S) :-
|
|
% phase 1: minimize sum of articifial variables
|
|
make_tableau(As, Cs, Tableau0),
|
|
Tableau0 = tableau(Obj0, Variables, Inds, Rows),
|
|
proper_form(As, Variables, Rows, Obj0, Obj),
|
|
simplex(tableau(Obj, Variables, Inds, Rows), Tableau1),
|
|
all_vars_zero(As, solved(Tableau1, _, _)),
|
|
% phase 2: remove artificial variables and solve actual LP.
|
|
tableau_rows(Tableau1, Rows2),
|
|
eliminate_artificial(As, As, Variables, Rows2, Rows3),
|
|
list_nths(As, Variables, Nths0),
|
|
nths_to_zero(Nths0, Inds, Inds1),
|
|
linsum_row(Variables, Z, Objective),
|
|
all_times(Objective, -1, Objective1),
|
|
proper_form(Z, Variables, Rows3, row(z, Objective1, 0), ObjRow),
|
|
simplex(tableau(ObjRow, Variables, Inds1, Rows3), Tableau),
|
|
S = solved(Tableau, Names, Is).
|
|
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
If artificial variables are still in the basis, replace them with
|
|
non-artificial variables if possible. If that is not possible, the
|
|
constraint is ignored because it is redundant.
|
|
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
eliminate_artificial([], _, _, Rows, Rows).
|
|
eliminate_artificial([_Coeff*A|Rest], As, Variables, Rows0, Rows) :-
|
|
( select(row(A, Left, 0), Rows0, Others) ->
|
|
( nth0(Col, Left, Coeff),
|
|
Coeff =\= 0,
|
|
nth0(Col, Variables, Var),
|
|
\+ memberchk(_*Var, As) ->
|
|
row_divide(row(A, Left, 0), Coeff, Row),
|
|
gauss_elimination(Rows0, Row, Col, Rows1),
|
|
swap_basic(Rows1, A, Var, Rows2)
|
|
; Rows2 = Others
|
|
)
|
|
; Rows2 = Rows0
|
|
),
|
|
eliminate_artificial(Rest, As, Variables, Rows2, Rows).
|
|
|
|
nths_to_zero([], Inds, Inds).
|
|
nths_to_zero([Nth|Nths], Inds0, Inds) :-
|
|
nth_to_zero(Inds0, 0, Nth, Inds1),
|
|
nths_to_zero(Nths, Inds1, Inds).
|
|
|
|
nth_to_zero([], _, _, []).
|
|
nth_to_zero([I|Is], Curr, Nth, [Z|Zs]) :-
|
|
( Curr =:= Nth -> [Z|Zs] = [0|Is]
|
|
; Z = I,
|
|
Next is Curr + 1,
|
|
nth_to_zero(Is, Next, Nth, Zs)
|
|
).
|
|
|
|
|
|
list_nths([], _, []).
|
|
list_nths([_Coeff*A|As], Variables, [Nth|Nths]) :-
|
|
list_first(Variables, A, Nth),
|
|
list_nths(As, Variables, Nths).
|
|
|
|
|
|
linsum_negate([], []).
|
|
linsum_negate([Coeff0*Var|Ls], [Coeff*Var|Ns]) :-
|
|
Coeff is Coeff0 * (-1),
|
|
linsum_negate(Ls, Ns).
|
|
|
|
|
|
linsum_row([], _, []).
|
|
linsum_row([V|Vs], Ls, [C|Cs]) :-
|
|
( member(Coeff*V, Ls) -> C is rationalize(Coeff)
|
|
; C = 0
|
|
),
|
|
linsum_row(Vs, Ls, Cs).
|
|
|
|
constraints_rows([], _, []).
|
|
constraints_rows([C|Cs], Vars, [R|Rs]) :-
|
|
C = c(Var, Left0, Right),
|
|
linsum_row(Vars, Left0, Left),
|
|
R = row(Var, Left, Right),
|
|
constraints_rows(Cs, Vars, Rs).
|
|
|
|
constraints_normalize([], [], []) --> [].
|
|
constraints_normalize([C0|Cs0], [C|Cs], [A|As]) -->
|
|
{ constraint_op(C0, Op),
|
|
constraint_left(C0, Left),
|
|
constraint_right(C0, Right),
|
|
constraint_name(C0, Name),
|
|
Con =.. [Op, Left, Right] },
|
|
constraint_normalize(Con, Name, C, A),
|
|
constraints_normalize(Cs0, Cs, As).
|
|
|
|
constraint_normalize(As0 =< B0, Name, c(Slack, [1*Slack|As0], B0), []) -->
|
|
state_next_var(Slack),
|
|
state_add_name(Name, Slack).
|
|
constraint_normalize(As0 = B0, Name, c(AID, [1*AID|As0], B0), [-1*AID]) -->
|
|
state_next_var(AID),
|
|
state_add_name(Name, AID).
|
|
constraint_normalize(As0 >= B0, Name, c(AID, [-1*Slack,1*AID|As0], B0), [-1*AID]) -->
|
|
state_next_var(Slack),
|
|
state_next_var(AID),
|
|
state_add_name(Name, AID).
|
|
|
|
coeff_one([], []).
|
|
coeff_one([L|Ls], [Coeff*Var|Rest]) :-
|
|
( L = A*B -> Coeff = A, Var = B
|
|
; Coeff = 1, Var = L
|
|
),
|
|
coeff_one(Ls, Rest).
|
|
|
|
|
|
tableau_optimal(Tableau) :-
|
|
tableau_objective(Tableau, Objective),
|
|
tableau_indicators(Tableau, Indicators),
|
|
Objective = row(_, Left, _),
|
|
all_nonnegative(Left, Indicators).
|
|
|
|
all_nonnegative([], []).
|
|
all_nonnegative([Coeff|As], [I|Is]) :-
|
|
( I =:= 0 -> true
|
|
; Coeff >= 0
|
|
),
|
|
all_nonnegative(As, Is).
|
|
|
|
pivot_column(Tableau, PCol) :-
|
|
tableau_objective(Tableau, row(_, Left, _)),
|
|
tableau_indicators(Tableau, Indicators),
|
|
first_negative(Left, Indicators, 0, Index0, Val, RestL, RestI),
|
|
Index1 is Index0 + 1,
|
|
pivot_column(RestL, RestI, Val, Index1, Index0, PCol).
|
|
|
|
first_negative([L|Ls], [I|Is], Index0, N, Val, RestL, RestI) :-
|
|
Index1 is Index0 + 1,
|
|
( I =:= 0 -> first_negative(Ls, Is, Index1, N, Val, RestL, RestI)
|
|
; ( L < 0 -> N = Index0, Val = L, RestL = Ls, RestI = Is
|
|
; first_negative(Ls, Is, Index1, N, Val, RestL, RestI)
|
|
)
|
|
).
|
|
|
|
|
|
pivot_column([], _, _, _, N, N).
|
|
pivot_column([L|Ls], [I|Is], Coeff0, Index0, N0, N) :-
|
|
( I =:= 0 -> Coeff1 = Coeff0, N1 = N0
|
|
; ( L < Coeff0 -> Coeff1 = L, N1 = Index0
|
|
; Coeff1 = Coeff0, N1 = N0
|
|
)
|
|
),
|
|
Index1 is Index0 + 1,
|
|
pivot_column(Ls, Is, Coeff1, Index1, N1, N).
|
|
|
|
|
|
pivot_row(Tableau, PCol, PRow) :-
|
|
tableau_rows(Tableau, Rows),
|
|
pivot_row(Rows, PCol, false, _, 0, 0, PRow).
|
|
|
|
pivot_row([], _, Bounded, _, _, Row, Row) :- Bounded.
|
|
pivot_row([Row|Rows], PCol, Bounded0, Min0, Index0, PRow0, PRow) :-
|
|
Row = row(_Var, Left, B),
|
|
nth0(PCol, Left, Ae),
|
|
( Ae > 0 ->
|
|
Bounded1 = true,
|
|
Bound is B rdiv Ae,
|
|
( Bounded0 ->
|
|
( Bound < Min0 -> Min1 = Bound, PRow1 = Index0
|
|
; Min1 = Min0, PRow1 = PRow0
|
|
)
|
|
; Min1 = Bound, PRow1 = Index0
|
|
)
|
|
; Bounded1 = Bounded0, Min1 = Min0, PRow1 = PRow0
|
|
),
|
|
Index1 is Index0 + 1,
|
|
pivot_row(Rows, PCol, Bounded1, Min1, Index1, PRow1, PRow).
|
|
|
|
|
|
row_divide(row(Var, Left0, Right0), Div, row(Var, Left, Right)) :-
|
|
all_divide(Left0, Div, Left),
|
|
Right is Right0 rdiv Div.
|
|
|
|
|
|
all_divide([], _, []).
|
|
all_divide([R|Rs], Div, [DR|DRs]) :-
|
|
DR is R rdiv Div,
|
|
all_divide(Rs, Div, DRs).
|
|
|
|
gauss_elimination([], _, _, []).
|
|
gauss_elimination([Row0|Rows0], PivotRow, Col, [Row|Rows]) :-
|
|
PivotRow = row(PVar, _, _),
|
|
Row0 = row(Var, _, _),
|
|
( PVar == Var -> Row = PivotRow
|
|
; row_eliminate(Row0, PivotRow, Col, Row)
|
|
),
|
|
gauss_elimination(Rows0, PivotRow, Col, Rows).
|
|
|
|
row_eliminate(row(Var, Ls0, R0), row(_, PLs, PR), Col, row(Var, Ls, R)) :-
|
|
nth0(Col, Ls0, Coeff),
|
|
( Coeff =:= 0 -> Ls = Ls0, R = R0
|
|
; MCoeff is -Coeff,
|
|
all_times_plus([PR|PLs], MCoeff, [R0|Ls0], [R|Ls])
|
|
).
|
|
|
|
all_times_plus([], _, _, []).
|
|
all_times_plus([A|As], T, [B|Bs], [AT|ATs]) :-
|
|
AT is A * T + B,
|
|
all_times_plus(As, T, Bs, ATs).
|
|
|
|
all_times([], _, []).
|
|
all_times([A|As], T, [AT|ATs]) :-
|
|
AT is A * T,
|
|
all_times(As, T, ATs).
|
|
|
|
simplex(Tableau0, Tableau) :-
|
|
( tableau_optimal(Tableau0) -> Tableau0 = Tableau
|
|
; pivot_column(Tableau0, PCol),
|
|
pivot_row(Tableau0, PCol, PRow),
|
|
Tableau0 = tableau(Obj0,Variables,Inds,Matrix0),
|
|
nth0(PRow, Matrix0, Row0),
|
|
Row0 = row(Leaving, Left0, _Right0),
|
|
nth0(PCol, Left0, PivotElement),
|
|
row_divide(Row0, PivotElement, Row1),
|
|
gauss_elimination([Obj0|Matrix0], Row1, PCol, [Obj|Matrix1]),
|
|
nth0(PCol, Variables, Entering),
|
|
swap_basic(Matrix1, Leaving, Entering, Matrix),
|
|
simplex(tableau(Obj,Variables,Inds,Matrix), Tableau)
|
|
).
|
|
|
|
swap_basic([Row0|Rows0], Old, New, Matrix) :-
|
|
Row0 = row(Var, Left, Right),
|
|
( Var == Old -> Matrix = [row(New, Left, Right)|Rows0]
|
|
; Matrix = [Row0|Rest],
|
|
swap_basic(Rows0, Old, New, Rest)
|
|
).
|
|
|
|
constraints_variables([]) --> [].
|
|
constraints_variables([c(_,Left,_)|Cs]) -->
|
|
variables(Left),
|
|
constraints_variables(Cs).
|
|
|
|
variables([]) --> [].
|
|
variables([_Coeff*Var|Rest]) --> [Var], variables(Rest).
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
A dual algorithm ("algorithm alpha-beta" in Papadimitriou and
|
|
Steiglitz) is used for transportation and assignment problems. The
|
|
arising max-flow problem is solved with Edmonds-Karp, itself a dual
|
|
algorithm.
|
|
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
An attributed variable is introduced for each node. Attributes:
|
|
node: Original name of the node.
|
|
edges: arc_to(To,F,Capacity) (F has an attribute "flow") or
|
|
arc_from(From,F,Capacity)
|
|
parent: used in breadth-first search
|
|
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
arcs([], Assoc, Assoc).
|
|
arcs([arc(From0,To0,C)|As], Assoc0, Assoc) :-
|
|
( get_assoc(From0, Assoc0, From) -> Assoc1 = Assoc0
|
|
; put_assoc(From0, Assoc0, From, Assoc1),
|
|
put_attr(From, node, From0)
|
|
),
|
|
( get_attr(From, edges, Es) -> true
|
|
; Es = []
|
|
),
|
|
put_attr(F, flow, 0),
|
|
put_attr(From, edges, [arc_to(To,F,C)|Es]),
|
|
( get_assoc(To0, Assoc1, To) -> Assoc2 = Assoc1
|
|
; put_assoc(To0, Assoc1, To, Assoc2),
|
|
put_attr(To, node, To0)
|
|
),
|
|
( get_attr(To, edges, Es1) -> true
|
|
; Es1 = []
|
|
),
|
|
put_attr(To, edges, [arc_from(From,F,C)|Es1]),
|
|
arcs(As, Assoc2, Assoc).
|
|
|
|
|
|
edmonds_karp(Arcs0, Arcs) :-
|
|
empty_assoc(E),
|
|
arcs(Arcs0, E, Assoc),
|
|
get_assoc(s, Assoc, S),
|
|
get_assoc(t, Assoc, T),
|
|
maximum_flow(S, T),
|
|
% fetch attvars before deleting visited edges
|
|
term_attvars(S, AttVars),
|
|
phrase(flow_to_arcs(S), Ls),
|
|
arcs_assoc(Ls, Arcs),
|
|
maplist(del_attrs, AttVars).
|
|
|
|
flow_to_arcs(V) -->
|
|
( { get_attr(V, edges, Es) } ->
|
|
{ del_attr(V, edges),
|
|
get_attr(V, node, Name) },
|
|
flow_to_arcs_(Es, Name)
|
|
; []
|
|
).
|
|
|
|
flow_to_arcs_([], _) --> [].
|
|
flow_to_arcs_([E|Es], Name) -->
|
|
edge_to_arc(E, Name),
|
|
flow_to_arcs_(Es, Name).
|
|
|
|
edge_to_arc(arc_from(_,_,_), _) --> [].
|
|
edge_to_arc(arc_to(To,F,C), Name) -->
|
|
{ get_attr(To, node, NTo),
|
|
get_attr(F, flow, Flow) },
|
|
[arc(Name,NTo,Flow,C)],
|
|
flow_to_arcs(To).
|
|
|
|
arcs_assoc(Arcs, Hash) :-
|
|
empty_assoc(E),
|
|
arcs_assoc(Arcs, E, Hash).
|
|
|
|
arcs_assoc([], Hs, Hs).
|
|
arcs_assoc([arc(From,To,F,C)|Rest], Hs0, Hs) :-
|
|
( get_assoc(From, Hs0, As) -> Hs1 = Hs0
|
|
; put_assoc(From, Hs0, [], Hs1),
|
|
empty_assoc(As)
|
|
),
|
|
put_assoc(To, As, arc(From,To,F,C), As1),
|
|
put_assoc(From, Hs1, As1, Hs2),
|
|
arcs_assoc(Rest, Hs2, Hs).
|
|
|
|
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
Strategy: Breadth-first search until we find a free right vertex in
|
|
the value graph, then find an augmenting path in reverse.
|
|
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
maximum_flow(S, T) :-
|
|
( augmenting_path([[S]], Levels, T) ->
|
|
phrase(augmenting_path(S, T), Path),
|
|
Path = [augment(_,First,_)|Rest],
|
|
path_minimum(Rest, First, Min),
|
|
% format("augmenting path: ~w\n", [Min]),
|
|
maplist(augment(Min), Path),
|
|
maplist(maplist(clear_parent), Levels),
|
|
maximum_flow(S, T)
|
|
; true
|
|
).
|
|
|
|
clear_parent(V) :- del_attr(V, parent).
|
|
|
|
augmenting_path(Levels0, Levels, T) :-
|
|
Levels0 = [Vs|_],
|
|
Levels1 = [Tos|Levels0],
|
|
phrase(reachables(Vs), Tos),
|
|
Tos = [_|_],
|
|
( member(To, Tos), To == T -> Levels = Levels1
|
|
; augmenting_path(Levels1, Levels, T)
|
|
).
|
|
|
|
reachables([]) --> [].
|
|
reachables([V|Vs]) -->
|
|
{ get_attr(V, edges, Es) },
|
|
reachables_(Es, V),
|
|
reachables(Vs).
|
|
|
|
reachables_([], _) --> [].
|
|
reachables_([E|Es], V) -->
|
|
reachable(E, V),
|
|
reachables_(Es, V).
|
|
|
|
reachable(arc_from(V,F,_), P) -->
|
|
( { \+ get_attr(V, parent, _),
|
|
get_attr(F, flow, Flow),
|
|
Flow > 0 } ->
|
|
{ put_attr(V, parent, P-augment(F,Flow,-)) },
|
|
[V]
|
|
; []
|
|
).
|
|
reachable(arc_to(V,F,C), P) -->
|
|
( { \+ get_attr(V, parent, _),
|
|
get_attr(F, flow, Flow),
|
|
( C == inf ; Flow < C )} ->
|
|
{ ( C == inf -> Diff = inf
|
|
; Diff is C - Flow
|
|
),
|
|
put_attr(V, parent, P-augment(F,Diff,+)) },
|
|
[V]
|
|
; []
|
|
).
|
|
|
|
|
|
path_minimum([], Min, Min).
|
|
path_minimum([augment(_,A,_)|As], Min0, Min) :-
|
|
( A == inf -> Min1 = Min0
|
|
; Min1 is min(Min0,A)
|
|
),
|
|
path_minimum(As, Min1, Min).
|
|
|
|
augment(Min, augment(F,_,Sign)) :-
|
|
get_attr(F, flow, Flow0),
|
|
flow_(Sign, Flow0, Min, Flow),
|
|
put_attr(F, flow, Flow).
|
|
|
|
flow_(+, F0, A, F) :- F is F0 + A.
|
|
flow_(-, F0, A, F) :- F is F0 - A.
|
|
|
|
augmenting_path(S, V) -->
|
|
( { V == S } -> []
|
|
; { get_attr(V, parent, V1-Augment) },
|
|
[Augment],
|
|
augmenting_path(S, V1)
|
|
).
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
naive_init(Supplies, _, Costs, Alphas, Betas) :-
|
|
length(Supplies, LAs),
|
|
length(Alphas, LAs),
|
|
maplist(=(0), Alphas),
|
|
transpose(Costs, TCs),
|
|
naive_init_betas(TCs, Betas).
|
|
|
|
naive_init_betas([], []).
|
|
naive_init_betas([Ls|Lss], [B|Bs]) :-
|
|
list_min(Ls, B),
|
|
naive_init_betas(Lss, Bs).
|
|
|
|
list_min([F|Rest], Min) :-
|
|
list_min(Rest, F, Min).
|
|
|
|
list_min([], Min, Min).
|
|
list_min([L|Ls], Min0, Min) :-
|
|
Min1 is min(L,Min0),
|
|
list_min(Ls, Min1, Min).
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
transpose(Ms, Ts) :- Ms = [F|_], transpose(F, Ms, Ts).
|
|
|
|
transpose([], _, []).
|
|
transpose([_|Rs], Ms, [Ts|Tss]) :-
|
|
lists_firsts_rests(Ms, Ts, Ms1),
|
|
transpose(Rs, Ms1, Tss).
|
|
|
|
lists_firsts_rests([], [], []).
|
|
lists_firsts_rests([[F|Os]|Rest], [F|Fs], [Os|Oss]) :-
|
|
lists_firsts_rests(Rest, Fs, Oss).
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
TODO: use attributed variables throughout
|
|
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
transportation(Supplies, Demands, Costs, Transport) :-
|
|
length(Supplies, LAs),
|
|
length(Demands, LBs),
|
|
naive_init(Supplies, Demands, Costs, Alphas, Betas),
|
|
network_head(Supplies, 1, SArcs, []),
|
|
network_tail(Demands, 1, DArcs, []),
|
|
numlist(1, LAs, Sources),
|
|
numlist(1, LBs, Sinks0),
|
|
maplist(make_sink, Sinks0, Sinks),
|
|
append(SArcs, DArcs, Torso),
|
|
alpha_beta(Torso, Sources, Sinks, Costs, Alphas, Betas, Flow),
|
|
flow_transport(Supplies, 1, Demands, Flow, Transport).
|
|
|
|
flow_transport([], _, _, _, []).
|
|
flow_transport([_|Rest], N, Demands, Flow, [Line|Lines]) :-
|
|
transport_line(Demands, N, 1, Flow, Line),
|
|
N1 is N + 1,
|
|
flow_transport(Rest, N1, Demands, Flow, Lines).
|
|
|
|
transport_line([], _, _, _, []).
|
|
transport_line([_|Rest], I, J, Flow, [L|Ls]) :-
|
|
( get_assoc(I, Flow, As), get_assoc(p(J), As, arc(I,p(J),F,_)) -> L = F
|
|
; L = 0
|
|
),
|
|
J1 is J + 1,
|
|
transport_line(Rest, I, J1, Flow, Ls).
|
|
|
|
|
|
make_sink(N, p(N)).
|
|
|
|
network_head([], _) --> [].
|
|
network_head([S|Ss], N) -->
|
|
[arc(s,N,S)],
|
|
{ N1 is N + 1 },
|
|
network_head(Ss, N1).
|
|
|
|
network_tail([], _) --> [].
|
|
network_tail([D|Ds], N) -->
|
|
[arc(p(N),t,D)],
|
|
{ N1 is N + 1 },
|
|
network_tail(Ds, N1).
|
|
|
|
network_connections([], _, _, _) --> [].
|
|
network_connections([A|As], Betas, [Cs|Css], N) -->
|
|
network_connections(Betas, Cs, A, N, 1),
|
|
{ N1 is N + 1 },
|
|
network_connections(As, Betas, Css, N1).
|
|
|
|
network_connections([], _, _, _, _) --> [].
|
|
network_connections([B|Bs], [C|Cs], A, N, PN) -->
|
|
( { C =:= A + B } -> [arc(N,p(PN),inf)]
|
|
; []
|
|
),
|
|
{ PN1 is PN + 1 },
|
|
network_connections(Bs, Cs, A, N, PN1).
|
|
|
|
alpha_beta(Torso, Sources, Sinks, Costs, Alphas, Betas, Flow) :-
|
|
network_connections(Alphas, Betas, Costs, 1, Cons, []),
|
|
append(Torso, Cons, Arcs),
|
|
edmonds_karp(Arcs, MaxFlow),
|
|
mark_hashes(MaxFlow, MArcs, MRevArcs),
|
|
all_markable(MArcs, MRevArcs, Markable),
|
|
mark_unmark(Sources, Markable, MarkSources, UnmarkSources),
|
|
( MarkSources == [] -> Flow = MaxFlow
|
|
; mark_unmark(Sinks, Markable, MarkSinks0, UnmarkSinks0),
|
|
maplist(un_p, MarkSinks0, MarkSinks),
|
|
maplist(un_p, UnmarkSinks0, UnmarkSinks),
|
|
MarkSources = [FirstSource|_],
|
|
UnmarkSinks = [FirstSink|_],
|
|
theta(FirstSource, FirstSink, Costs, Alphas, Betas, TInit),
|
|
theta(MarkSources, UnmarkSinks, Costs, Alphas, Betas, TInit, Theta),
|
|
duals_add(MarkSources, Alphas, Theta, Alphas1),
|
|
duals_add(UnmarkSinks, Betas, Theta, Betas1),
|
|
Theta1 is -Theta,
|
|
duals_add(UnmarkSources, Alphas1, Theta1, Alphas2),
|
|
duals_add(MarkSinks, Betas1, Theta1, Betas2),
|
|
alpha_beta(Torso, Sources, Sinks, Costs, Alphas2, Betas2, Flow)
|
|
).
|
|
|
|
mark_hashes(MaxFlow, Arcs, RevArcs) :-
|
|
assoc_to_list(MaxFlow, FlowList),
|
|
maplist(un_arc, FlowList, FlowList1),
|
|
flatten(FlowList1, FlowList2),
|
|
empty_assoc(E),
|
|
mark_arcs(FlowList2, E, Arcs),
|
|
mark_revarcs(FlowList2, E, RevArcs).
|
|
|
|
un_arc(_-Ls0, Ls) :-
|
|
assoc_to_list(Ls0, Ls1),
|
|
maplist(un_arc_, Ls1, Ls).
|
|
|
|
un_arc_(_-Ls, Ls).
|
|
|
|
mark_arcs([], Arcs, Arcs).
|
|
mark_arcs([arc(From,To,F,C)|Rest], Arcs0, Arcs) :-
|
|
( get_assoc(From, Arcs0, As) -> true
|
|
; As = []
|
|
),
|
|
( C == inf -> As1 = [To|As]
|
|
; F < C -> As1 = [To|As]
|
|
; As1 = As
|
|
),
|
|
put_assoc(From, Arcs0, As1, Arcs1),
|
|
mark_arcs(Rest, Arcs1, Arcs).
|
|
|
|
mark_revarcs([], Arcs, Arcs).
|
|
mark_revarcs([arc(From,To,F,_)|Rest], Arcs0, Arcs) :-
|
|
( get_assoc(To, Arcs0, Fs) -> true
|
|
; Fs = []
|
|
),
|
|
( F > 0 -> Fs1 = [From|Fs]
|
|
; Fs1 = Fs
|
|
),
|
|
put_assoc(To, Arcs0, Fs1, Arcs1),
|
|
mark_revarcs(Rest, Arcs1, Arcs).
|
|
|
|
|
|
un_p(p(N), N).
|
|
|
|
duals_add([], Alphas, _, Alphas).
|
|
duals_add([S|Ss], Alphas0, Theta, Alphas) :-
|
|
add_to_nth(1, S, Alphas0, Theta, Alphas1),
|
|
duals_add(Ss, Alphas1, Theta, Alphas).
|
|
|
|
add_to_nth(N, N, [A0|As], Theta, [A|As]) :- !,
|
|
A is A0 + Theta.
|
|
add_to_nth(N0, N, [A|As0], Theta, [A|As]) :-
|
|
N1 is N0 + 1,
|
|
add_to_nth(N1, N, As0, Theta, As).
|
|
|
|
|
|
theta(Source, Sink, Costs, Alphas, Betas, Theta) :-
|
|
nth1(Source, Costs, Row),
|
|
nth1(Sink, Row, C),
|
|
nth1(Source, Alphas, A),
|
|
nth1(Sink, Betas, B),
|
|
Theta is (C - A - B) rdiv 2.
|
|
|
|
theta([], _, _, _, _, Theta, Theta).
|
|
theta([Source|Sources], Sinks, Costs, Alphas, Betas, Theta0, Theta) :-
|
|
theta_(Sinks, Source, Costs, Alphas, Betas, Theta0, Theta1),
|
|
theta(Sources, Sinks, Costs, Alphas, Betas, Theta1, Theta).
|
|
|
|
theta_([], _, _, _, _, Theta, Theta).
|
|
theta_([Sink|Sinks], Source, Costs, Alphas, Betas, Theta0, Theta) :-
|
|
theta(Source, Sink, Costs, Alphas, Betas, Theta1),
|
|
Theta2 is min(Theta0, Theta1),
|
|
theta_(Sinks, Source, Costs, Alphas, Betas, Theta2, Theta).
|
|
|
|
|
|
mark_unmark(Nodes, Hash, Mark, Unmark) :-
|
|
mark_unmark(Nodes, Hash, Mark, [], Unmark, []).
|
|
|
|
mark_unmark([], _, Mark, Mark, Unmark, Unmark).
|
|
mark_unmark([Node|Nodes], Markable, Mark0, Mark, Unmark0, Unmark) :-
|
|
( memberchk(Node, Markable) ->
|
|
Mark0 = [Node|Mark1],
|
|
Unmark0 = Unmark1
|
|
; Mark0 = Mark1,
|
|
Unmark0 = [Node|Unmark1]
|
|
),
|
|
mark_unmark(Nodes, Markable, Mark1, Mark, Unmark1, Unmark).
|
|
|
|
all_markable(Flow, RevArcs, Markable) :-
|
|
phrase(markable(s, [], _, Flow, RevArcs), Markable).
|
|
|
|
all_markable([], Visited, Visited, _, _) --> [].
|
|
all_markable([To|Tos], Visited0, Visited, Arcs, RevArcs) -->
|
|
( { memberchk(To, Visited0) } -> { Visited0 = Visited1 }
|
|
; markable(To, [To|Visited0], Visited1, Arcs, RevArcs)
|
|
),
|
|
all_markable(Tos, Visited1, Visited, Arcs, RevArcs).
|
|
|
|
markable(Current, Visited0, Visited, Arcs, RevArcs) -->
|
|
{ ( Current = p(_) ->
|
|
( get_assoc(Current, RevArcs, Fs) -> true
|
|
; Fs = []
|
|
)
|
|
; ( get_assoc(Current, Arcs, Fs) -> true
|
|
; Fs = []
|
|
)
|
|
) },
|
|
[Current],
|
|
all_markable(Fs, [Current|Visited0], Visited, Arcs, RevArcs).
|
|
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
solve(File) -- read input from File.
|
|
|
|
Format (NS = number of sources, ND = number of demands):
|
|
|
|
NS
|
|
ND
|
|
S1 S2 S3 ...
|
|
D1 D2 D3 ...
|
|
C11 C12 C13 ...
|
|
C21 C22 C23 ...
|
|
... ... ... ...
|
|
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
input(Ss, Ds, Costs) -->
|
|
integer(NS),
|
|
integer(ND),
|
|
n_integers(NS, Ss),
|
|
n_integers(ND, Ds),
|
|
n_kvectors(NS, ND, Costs).
|
|
|
|
n_kvectors(0, _, []) --> !.
|
|
n_kvectors(N, K, [V|Vs]) -->
|
|
n_integers(K, V),
|
|
{ N1 is N - 1 },
|
|
n_kvectors(N1, K, Vs).
|
|
|
|
n_integers(0, []) --> !.
|
|
n_integers(N, [I|Is]) --> integer(I), { N1 is N - 1 }, n_integers(N1, Is).
|
|
|
|
|
|
number([D|Ds]) --> digit(D), number(Ds).
|
|
number([D]) --> digit(D).
|
|
|
|
digit(D) --> [D], { between(0'0, 0'9, D) }.
|
|
|
|
integer(N) --> number(Ds), !, ws, { name(N, Ds) }.
|
|
|
|
ws --> [W], { W =< 0' }, !, ws. % closing quote for syntax highlighting: '
|
|
ws --> [].
|
|
|
|
solve(File) :-
|
|
time((phrase_from_file(input(Supplies, Demands, Costs), File),
|
|
transportation(Supplies, Demands, Costs, Matrix),
|
|
maplist(print_row, Matrix))),
|
|
halt.
|
|
|
|
print_row(R) :- maplist(print_row_, R), nl.
|
|
|
|
print_row_(N) :- format("~w ", [N]).
|
|
|
|
|
|
% ?- call_residue_vars(transportation([12,7,14], [3,15,9,6], [[20,50,10,60],[70,40,60,30],[40,80,70,40]], Ms), Vs).
|
|
%@ Ms = [[0, 3, 9, 0], [0, 7, 0, 0], [3, 5, 0, 6]],
|
|
%@ Vs = [].
|
|
|
|
|
|
%?- call_residue_vars(simplex:solve('instance_80_80.txt'), Vs).
|
|
|
|
%?- call_residue_vars(simplex:solve('instance_3_4.txt'), Vs).
|
|
|
|
%?- call_residue_vars(simplex:solve('instance_100_100.txt'), Vs).
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% Assignment problem - for now, reduce to transportation problem
|
|
|
|
assignment(Costs, Assignment) :-
|
|
length(Costs, LC),
|
|
length(Supply, LC),
|
|
all_one(Supply),
|
|
transportation(Supply, Supply, Costs, Assignment).
|
|
|