diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
Files
fa0ef4e0c854f5b9df15ad7b36e234b2c943ba0c
yap-6.3/library/clp/simplex.pl

1373 lines
46 KiB
Perl
Raw Normal View History

upgrade to more recent clp.
2010-02-28 12:18:26 +00:00
/* $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
]).
small fixes
2014-08-04 09:47:03 -05:00
:- use_module(library(lists)).
upgrade to more recent clp.
2010-02-28 12:18:26 +00:00
:- use_module(library(clpr)).
:- use_module(library(assoc)).
:- use_module(library(pio)).
needs maplist library.
2014-08-20 07:55:44 -05:00
:- use_module(library(maplist)).
upgrade to more recent clp.
2010-02-28 12:18:26 +00:00
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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).
Reference in New Issue Copy Permalink