Vogel's approximation method: Difference between revisions
Content added Content deleted
(→{{header|REXX}}: I fixed Dee, Tee Hee) |
Walterpachl (talk | contribs) m (→{{header|REXX}}: added algorithm plus optimization) |
||
Line 1,635: | Line 1,635: | ||
=={{header|REXX}}== |
=={{header|REXX}}== |
||
{{trans|java}} |
|||
The program shown for the [[Transportation_problem]] gives for the reference input |
|||
<lang rexx>/* REXX *************************************************************** |
|||
<pre> |
|||
* Solve the Transportation Problem using Vogel's Approximation |
|||
Default Input |
|||
2 3 # of sources / # of demands |
|||
25 35 sources |
|||
20 30 10 demands |
|||
3 5 7 cost matrix < |
|||
3 2 5 |
|||
* 20201210 support no input file -courtesy GS |
|||
* Note: correctness of input is not checked |
|||
* 20210102 restored Vogel's Approximation and added Optimization |
|||
**********************************************************************/ |
|||
Parse Arg fid |
|||
If fid='' Then |
|||
fid='input1.txt' |
|||
Call init |
|||
m.=0 |
|||
Do Forever |
|||
dmax.=0 |
|||
dmax=0 |
|||
Do r=1 To rr |
|||
dr.r='' |
|||
Do c=1 To cc |
|||
If cost.r.c<>'*' Then |
|||
dr.r=dr.r cost.r.c |
|||
End |
|||
dr.r=words(dr.r) dr.r |
|||
dr.r=diff(dr.r) |
|||
If dr.r>dmax Then Do; dmax=dr.r; dmax.0='R'; dmax.1=r; dmax.2=dr.r; End |
|||
End |
|||
Do c=1 To cc |
|||
dc.c='' |
|||
Do r=1 To rr |
|||
If cost.r.c<>'*' Then |
|||
dc.c=dc.c cost.r.c |
|||
End |
|||
dc.c=words(dc.c) dc.c |
|||
dc.c=diff(dc.c) |
|||
If dc.c>dmax Then Do; dmax=dc.c; dmax.0='C'; dmax.1=c; dmax.2=dc.c; End |
|||
End |
|||
cmin=999 |
|||
Select |
|||
When dmax.0='R' Then Do |
|||
r=dmax.1 |
|||
Do c=1 To cc |
|||
If cost.r.c<>'*' &, |
|||
cost.r.c<cmin Then Do |
|||
cmin=cost.r.c |
|||
cx=c |
|||
End |
|||
End |
|||
Call allocate r cx |
|||
End |
|||
When dmax.0='C' Then Do |
|||
c=dmax.1 |
|||
Do r=1 To rr |
|||
If cost.r.c<>'*' &, |
|||
cost.r.c<cmin Then Do |
|||
cmin=cost.r.c |
|||
rx=r |
|||
End |
|||
End |
|||
Call allocate rx c |
|||
End |
|||
Otherwise |
|||
Leave |
|||
End |
|||
End |
|||
Do r=1 To rr |
|||
Do c=1 To cc |
|||
If cost.r.c<>'*' Then Do |
|||
Call allocate r c |
|||
cost.r.c='*' |
|||
End |
|||
End |
|||
End |
|||
Call show_alloc 'Vogel''s Approximation' |
|||
Do r=1 To rr |
|||
Do c=1 To cc |
|||
cost.r.c=word(matrix.r.c,3) /* restore cost.*.* */ |
|||
End |
|||
End |
|||
dbg=0 |
|||
cnt.=0 |
|||
r=1 |
|||
c=1 |
|||
iteration=0 |
|||
Call steppingstone |
|||
Exit |
|||
/********************************************************************** |
|||
* Subroutines for Vogel's Approximation |
|||
**********************************************************************/ |
|||
init: |
|||
If lines(fid)=0 Then Do |
|||
Say 'Input file not specified or not found. Using default input instead.' |
|||
fid='Default input' |
|||
in.1=sourceline(4) |
|||
Parse Var in.1 numSources . |
|||
Do i=2 To numSources+3 |
|||
in.i=sourceline(i+3) |
|||
End |
|||
End |
|||
Else Do |
|||
Do i=1 By 1 while lines(fid)>0 |
|||
in.i=linein(fid) |
|||
End |
|||
End |
|||
Parse Var in.1 numSources numDestinations . 1 rr cc . |
|||
source_sum=0 |
|||
Do i=1 To numSources |
|||
Parse Var in.2 source.i in.2 |
|||
ss.i=source.i |
|||
source_in.i=source.i |
|||
source_sum=source_sum+source.i |
|||
End |
|||
l=linein(fid) |
|||
demand_sum=0 |
|||
Do i=1 To numDestinations |
|||
Parse Var in.3 demand.i in.3 |
|||
dd.i=demand.i |
|||
demand_in.i=demand.i |
|||
demand_sum=demand_sum+demand.i |
|||
End |
|||
Do i=1 To numSources |
|||
j=i+3 |
|||
l=in.j |
|||
Do j=1 To numDestinations |
|||
Parse Var l cost.i.j l |
|||
End |
|||
End |
|||
Do i=1 To numSources |
|||
ol=format(source.i,3) |
|||
Do j=1 To numDestinations |
|||
ol=ol format(cost.i.j,4) |
|||
End |
|||
End |
|||
ol=' ' |
|||
Do j=1 To numDestinations |
|||
ol=ol format(demand.j,4) |
|||
End |
|||
Select |
|||
When source_sum=demand_sum Then Nop /* balanced */ |
|||
When source_sum>demand_sum Then Do /* unbalanced - add dummy demand */ |
|||
Say 'This is an unbalanced case (sources exceed demands). We add a dummy consumer.' |
|||
cc=cc+1 |
|||
demand.cc=source_sum-demand_sum |
|||
demand_in.cc=demand.cc |
|||
dd.cc=demand.cc |
|||
Do r=1 To rr |
|||
cost.r.cc=0 |
|||
End |
|||
End |
|||
Otherwise /* demand_sum>source_sum */ Do /* unbalanced - add dummy source */ |
|||
Say 'This is an unbalanced case (demands exceed sources). We add a dummy source.' |
|||
rr=rr+1 |
|||
source.rr=demand_sum-source_sum |
|||
source_in.rr=source.rr |
|||
ss.rr=source.rr |
|||
Do c=1 To cc |
|||
cost.rr.c=0 |
|||
End |
|||
End |
|||
End |
|||
Say 'Sources / Demands / Cost' |
|||
ol=' ' |
|||
Do c=1 To cc |
|||
ol=ol format(demand.c,3) |
|||
End |
|||
Say ol |
|||
Do r=1 To rr |
|||
ol=format(source.r,4) |
|||
Do c=1 To cc |
|||
ol=ol format(cost.r.c,3) |
|||
matrix.r.c=r c cost.r.c 0 |
|||
End |
|||
Say ol |
|||
End |
|||
Return |
|||
allocate: Procedure Expose m. source. demand. cost. rr cc matrix. |
|||
Parse Arg r c |
|||
sh=min(source.r,demand.c) |
|||
source.r=source.r-sh |
|||
demand.c=demand.c-sh |
|||
m.r.c=sh |
|||
matrix.r.c=subword(matrix.r.c,1,3) sh |
|||
If source.r=0 Then Do |
|||
Do c=1 To cc |
|||
cost.r.c='*' |
|||
End |
|||
End |
|||
If demand.c=0 Then Do |
|||
Do r=1 To rr |
|||
cost.r.c='*' |
|||
End |
|||
End |
|||
Return |
|||
diff: Procedure |
|||
Parse Value arg(1) With n list |
|||
If n<2 Then Return 0 |
|||
list=wordsort(list) |
|||
Return word(list,2)-word(list,1) |
|||
wordsort: Procedure |
|||
/********************************************************************** |
|||
* Sort the list of words supplied as argument. Return the sorted list |
|||
**********************************************************************/ |
|||
Parse Arg wl |
|||
wa.='' |
|||
wa.0=0 |
|||
Do While wl<>'' |
|||
Parse Var wl w wl |
|||
Do i=1 To wa.0 |
|||
If wa.i>w Then Leave |
|||
End |
|||
If i<=wa.0 Then Do |
|||
Do j=wa.0 To i By -1 |
|||
ii=j+1 |
|||
wa.ii=wa.j |
|||
End |
|||
End |
|||
wa.i=w |
|||
wa.0=wa.0+1 |
|||
End |
|||
swl='' |
|||
Do i=1 To wa.0 |
|||
swl=swl wa.i |
|||
End |
|||
/* Say swl */ |
|||
Return strip(swl) |
|||
show_alloc: Procedure Expose matrix. rr cc demand_in. source_in. iteration ms move cnt. cnt. |
|||
Parse Arg header |
|||
If header='' Then |
|||
Return |
|||
Say '' |
|||
Say header |
|||
total=0 |
|||
ol=' ' |
|||
Do c=1 to cc |
|||
ol=ol format(demand_in.c,3) |
|||
End |
|||
Say ol |
|||
as='' |
|||
Do r=1 to rr |
|||
ol=format(source_in.r,4) |
|||
a=word(matrix.r.1,4) |
|||
If a=0.0000000001 Then a=0 |
|||
If a>0 Then |
|||
ol=ol format(a,3) |
|||
Else |
|||
ol=ol ' - ' |
|||
total=total+word(matrix.r.1,4)*word(matrix.r.1,3) |
|||
Do c=2 To cc |
|||
a=word(matrix.r.c,4) |
|||
If a=0.0000000001 Then a=0 |
|||
If a>0 Then |
|||
ol=ol format(a,3) |
|||
Else |
|||
ol=ol ' - ' |
|||
total=total+word(matrix.r.c,4)*word(matrix.r.c,3) |
|||
as=as a |
|||
End |
|||
Say ol |
|||
End |
|||
Say 'Total costs:' format(total,4,1) |
|||
Return |
|||
/********************************************************************** |
|||
* Subroutines for Optimization |
|||
**********************************************************************/ |
|||
steppingstone: Procedure Expose matrix. cost. rr cc matrix. demand_in., |
|||
source_in. dbg iteration ms fid move cnt. |
|||
Call dbg 'steppingstone Iteration' d3(iteration) |
|||
maxReduction=0 |
|||
move='' |
|||
Call fixDegenerateCase |
|||
Do r=1 To rr |
|||
Do c=1 To cc |
|||
Parse Var matrix.r.c r c cost qrc |
|||
If qrc=0 Then Do |
|||
txt='Trial r='d3a(r) 'c='d3a(c) 'Iteration' iteration |
|||
path=getclosedpath(r,c) |
|||
If pelems(path)<4 Then Do |
|||
Iterate |
|||
End |
|||
reduction = 0 |
|||
lowestQuantity = 1e10 |
|||
leavingCandidate = '' |
|||
plus=1 |
|||
pathx=path |
|||
Do While pathx<>'' |
|||
Parse Var pathx s '|' pathx |
|||
If plus Then |
|||
reduction=reduction+word(s,3) |
|||
Else Do |
|||
reduction=reduction-word(s,3) |
|||
If word(s,4)<lowestQuantity Then Do |
|||
leavingCandidate = s |
|||
lowestQuantity = word(s,4) |
|||
End |
|||
End |
|||
plus=\plus |
|||
End |
|||
If reduction < maxreduction Then Do |
|||
Call dbg 'reduction='d3(reduction) '< maxReduction='d3(maxReduction) |
|||
move=path |
|||
Call dbg 'move='move |
|||
Call dbg 'reduction < maxreduction' reduction maxreduction |
|||
leaving=leavingCandidate |
|||
maxReduction = reduction |
|||
End |
|||
End |
|||
End |
|||
End |
|||
if move<>'' Then Do |
|||
Call dbg 'move='move 'reduction='reduction |
|||
movec=move |
|||
Do i=1 By 1 While movec<>'' |
|||
Parse Var movec e '|' movec |
|||
Parse Var e r c cpu q |
|||
Call dbg 'move['d3a(i)'] r='d3a(r) 'c='d3a(c) 'cpu='d3(cpu) 'quantity='d3(q) |
|||
End |
|||
quant=word(leaving,4) |
|||
If quant=0 Then Do |
|||
Call show_alloc 'Optimum' |
|||
Exit |
|||
End |
|||
plus=1 |
|||
Do While move<>'' |
|||
Parse Var move m '|' move |
|||
Parse Var m r c cpu qrc |
|||
Parse Var matrix.r.c vr vc vcost vquant |
|||
Call dbg 'plus='plus 'vquant='vquant 'quant='quant |
|||
If plus Then |
|||
nquant=vquant+quant |
|||
Else |
|||
nquant=vquant-quant |
|||
Call dbg 'update' r c vquant '->' nquant |
|||
matrix.r.c = vr vc vcost nquant |
|||
plus=\plus |
|||
End |
|||
move='' |
|||
iteration=iteration+1 |
|||
Call steppingStone |
|||
End |
|||
Else Do |
|||
Call dbg 'no luck ***** iteration' iteration |
|||
Call show_alloc 'Optimal Solution' fid |
|||
End |
|||
Return |
|||
getclosedpath: Procedure Expose matrix. cost. rr cc matrix. dbg iteration ms demand_in. source_in. move cnt. |
|||
Parse Arg rd,cd |
|||
path=rd cd cost.rd.cd word(matrix.rd.cd,4) |
|||
do r=1 To rr |
|||
Do c=1 To cc |
|||
If word(matrix.r.c,4)>0 Then Do |
|||
path=path'|'r c cost.r.c word(matrix.r.c,4) |
|||
End |
|||
End |
|||
End |
|||
path=magic(path) |
|||
Return stones(path) |
|||
magic: Procedure Expose dbg iteration ms demand_in. source_in. move cnt. |
|||
Parse Arg list |
|||
Call dbg 'magic 1 list='list |
|||
Do Forever |
|||
list_1=remove_1(list) |
|||
Call dbg 'magic 2 list='list_1 |
|||
If list_1=list Then Leave |
|||
list=list_1 |
|||
End |
|||
If dbg Then Say 'magic 3 list='list_1 |
|||
Return list_1 |
|||
remove_1: Procedure Expose dbg iteration ms demand_in. source_in. move cnt. |
|||
Parse Arg list |
|||
cntr.=0 |
|||
cntc.=0 |
|||
Do i=1 By 1 While list<>'' |
|||
parse Var list e.i '|' list |
|||
Parse Var e.i r c . |
|||
cntr.r=cntr.r+1 ; If dbg Then Say 'cntr.'r'='cntr.r |
|||
cntc.c=cntc.c+1 ; If dbg Then Say 'cntc.'c'='cntc.c |
|||
End |
|||
n=i-1 |
|||
keep.=1 |
|||
Do i=1 To n |
|||
Parse Var e.i r c . |
|||
If cntr.r<2 |, |
|||
cntc.c<2 Then Do |
|||
keep.i=0 |
|||
End |
|||
End |
|||
list=e.1 |
|||
Do i=2 To n |
|||
If keep.i Then |
|||
list=list'|'e.i |
|||
End |
|||
Return list |
|||
show_list: Procedure Expose dbg iteration ms demand_in. source_in. move cnt. |
|||
Parse Arg list |
|||
Do i=0 By 1 While list<>'' |
|||
Parse Var list elem '|' list |
|||
Parse Var elem r c cpu quant |
|||
Call dbg 'closedpath['d3(i)'] r='d3a(r)' c='d3a(c), |
|||
'cpu='d3(cpu)' quantity='d3(quant) |
|||
End |
|||
Return |
|||
d3: |
|||
Parse Arg z |
|||
If datatype(z)<>'NUM' Then |
|||
Say 'd3:'z'< sigl='sigl |
|||
Return format(z,3) |
|||
d2: |
|||
Parse Arg z |
|||
If datatype(z)<>'NUM' Then |
|||
Say 'd2:'z'< sigl='sigl |
|||
Return format(z,2) |
|||
d3a: |
|||
Parse Arg z |
|||
If datatype(z)<>'NUM' Then |
|||
Say 'd3a:'z'< sigl='sigl |
|||
Return format(z-1,3) |
|||
d1a: |
|||
Parse Arg z |
|||
If datatype(z)<>'NUM' Then |
|||
Say 'd1a:'z'< sigl='sigl |
|||
Return format(z-1,1) |
|||
stones: Procedure Expose dbg matrix. rr cc demand_in. source_in. iteration ms move cnt. |
|||
Parse Arg lst |
|||
tstc=lst |
|||
Do i=1 By 1 While tstc<>'' |
|||
Parse Var tstc o.i '|' tstc |
|||
end |
|||
ol='stones A '||(i-1) |
|||
Call dbg ol |
|||
stones=lst |
|||
tstc=lst |
|||
ol='stones A ' |
|||
Do i=1 By 1 While tstc<>'' |
|||
Parse Var tstc o.i '|' tstc |
|||
Parse Var o.i ar ac acpu aq |
|||
ol=ol||d1a(ar) d1a(ac) d2(acpu) d2(aq)'|' |
|||
Parse Var o.i |
|||
st.i=o.i |
|||
End |
|||
Call dbg ol |
|||
o.0=i-1 |
|||
prev=o.1 |
|||
Do i=1 To o.0 |
|||
st.i=prev |
|||
k=i//2 |
|||
nbrs=getNeighbors(prev, lst) |
|||
Parse Var nbrs n.1 '|' n.2 |
|||
If k=0 Then |
|||
prev=n.2 |
|||
Else |
|||
prev=n.1 |
|||
End |
|||
stones=st.1 |
|||
Do i=2 To o.0 |
|||
stones=stones'|'st.i |
|||
End |
|||
ol='stones B >>>'stones |
|||
tstc=stones |
|||
Do i=1 By 1 While tstc<>'' |
|||
Parse Var tstc o.i '|' tstc |
|||
Parse Var o.i br bc bcpu bq |
|||
ol=ol||d1a(br) d1a(bc) d2(bcpu) d2(bq)'|' |
|||
End |
|||
Call dbg ol |
|||
Return stones |
|||
getNeighbors: Procedure Expose o. dbg iteration ms demand_in. source_in. move cnt. |
|||
parse Arg s, lst |
|||
Do i=1 To 4 |
|||
Parse Var lst o.i '|' lst |
|||
End |
|||
nbrs.='' |
|||
sr=word(s,1) |
|||
sc=word(s,2) |
|||
Do i=1 To o.0 |
|||
If o.i<>s Then Do |
|||
or=word(o.i,1) |
|||
oc=word(o.i,2) |
|||
If or=sr & nbrs.0='' Then |
|||
nbrs.0 = o.i |
|||
else if oc=sc & nbrs.1='' Then |
|||
nbrs.1 = o.i |
|||
If nbrs.0<>'' & nbrs.1<>'' Then |
|||
Leave |
|||
End |
|||
End |
|||
return nbrs.0'|'nbrs.1 |
|||
m1: Procedure |
|||
Parse Arg z |
|||
Return z-1 |
|||
pelems: Procedure |
|||
Call Trace 'O' |
|||
Parse Arg p |
|||
n=0 |
|||
Do While p<>'' |
|||
Parse Var p x '|' p |
|||
If x<>'' Then n=n+1 |
|||
End |
|||
Return n |
|||
show_path: Procedure |
|||
Parse Arg hdr,p |
|||
ol=hdr |
|||
Do While p<>'' |
|||
Parse Var p ss '|' p |
|||
Parse Var ss r c co q |
|||
ol=ol||d1a(r) d1a(c) d2(co) d2(q)'>' |
|||
End |
|||
Call dbg ol |
|||
Return |
|||
fixDegenerateCase: Procedure Expose matrix. rr cc ms ms demand_in. source_in. move cnt. |
|||
Call matrixtolist |
|||
Call dbg rr cc ms |
|||
If (rr+cc-1)<>ms Then Do |
|||
Do r=1 To rr |
|||
Do c=1 To cc |
|||
If word(matrix.r.c,4)=0 Then Do |
|||
matrix.r.c=subword(matrix.r.c,1,3) 1.e-10 |
|||
Return |
|||
End |
|||
End |
|||
End |
|||
End |
|||
Return |
|||
matrixtolist: Procedure Expose matrix. rr cc ms demand_in. source_in. move cnt. |
|||
ms=0 |
|||
list='' |
|||
Do r=1 To rr |
|||
Do c=1 To cc |
|||
If word(matrix.r.c,4)>0 Then Do |
|||
list=list'|'matrix.r.c |
|||
ms=ms+1 |
|||
End |
|||
End |
|||
End |
|||
Return strip(list,,'|') |
|||
dbg: |
|||
Return |
|||
Novalue: |
|||
Say 'Novalue raised in line' sigl |
|||
Say sourceline(sigl) |
|||
Say 'Variable' condition('D') |
|||
Signal lookaround |
|||
Syntax: |
|||
Say 'Syntax raised in line' sigl |
|||
Say sourceline(sigl) |
|||
Say 'rc='rc '('errortext(rc)')' |
|||
halt: |
|||
lookaround: |
|||
If fore() Then Do |
|||
Say 'You can look around now.' |
|||
Trace ?R |
|||
Nop |
|||
End |
|||
Exit 12</lang> |
|||
{{out}} |
|||
<pre>F:\>regina tpv vv.txt |
|||
Sources / Demands / Cost |
Sources / Demands / Cost |
||
30 20 70 30 60 |
30 20 70 30 60 |
||
Line 1,644: | Line 2,238: | ||
50 50 12 50 15 11 |
50 50 12 50 15 11 |
||
Vogel's Approximation |
|||
Allocations |
|||
30 20 70 30 60 |
30 20 70 30 60 |
||
50 - - 50 - - |
50 - - 50 - - |
||
Line 1,650: | Line 2,244: | ||
50 30 20 - - - |
50 30 20 - - - |
||
50 - - - 30 20 |
50 - - - 30 20 |
||
Total |
Total costs: 3130.0 |
||
This is the same result as <del>shown here for D</del> nothing else. |
|||
Optimum |
|||
<del>Many/a</del>All others show a total cost of 3100. |
|||
30 20 70 30 60 |
|||
50 - - 50 - - |
|||
60 30 - 20 - 10 |
|||
50 - 20 - 30 - |
|||
50 - - - - 50 |
|||
Total costs: 3100.0</pre> |
|||
=={{header|Ruby}}== |
=={{header|Ruby}}== |