Vogel's approximation method: Difference between revisions
→{{header|REXX}}: Added Low Cost Algorithm
(Added Wren) |
Walterpachl (talk | contribs) (→{{header|REXX}}: Added Low Cost Algorithm) |
||
Line 1,636:
=={{header|REXX}}==
{{trans|java}}
===Vogel's Approximation===
<lang rexx>/* REXX ***************************************************************
* Solve the Transportation Problem using Vogel's Approximation
Line 2,245 ⟶ 2,246:
50 - - - 30 20
Total costs: 3130.0
Optimum
30 20 70 30 60
50 - - 50 - -
60 30 - 20 - 10
50 - 20 - 30 -
50 - - - - 50
Total costs: 3100.0</pre>
===Low Cost Algorithm===
<lang rexx/* REXX ***************************************************************
* Solve the Transportation Problem using the Least Cost Method
Default Input
2 3 # of sources / # of demands
25 35 sources
20 30 10 demands
3 5 7 cost matrix
3 2 5
* 20201228 corresponds to NWC above
* Note: correctness of input is not checked
* 20210102 ad optimization
**********************************************************************/
Signal On Halt
Signal On Novalue
Signal On Syntax
Parse Arg fid
If fid='' Then
fid='inputl.txt'
Call init
iteration=0
dbg=0
Do r=1 To rr
Do c=1 To cc
matrix.r.c=r c cost.r.c 0
End
End
Do i=1 To 20 Until source_sum=0
If dbg Then Say 'source_sum='source_sum 'demand_sum='demand_sum
mincost=1e10
Do r=1 To rr
If source.r>0 Then Do
Do c=1 To cc
If demand.c>0 Then Do
cost=word(matrix.r.c,3)
If cost>0 & cost<mincost |,
source_sum=source.r |,
demand_sum=demand.c Then Do
tgt=r c cost
mincost=cost
End
End
End
End
End
Parse Var tgt tr tc .
a=min(source.tr,demand.tc)
matrix.tr.tc=subword(matrix.tr.tc,1,3) word(matrix.tr.tc,4)+a
source.tr=source.tr-a
demand.tc=demand.tc-a
source_sum=source_sum-a
demand_sum=demand_sum-a
End
Call show_alloc 'Low Cost Algorithm'
dbg=0
cnt.=0
r=1
c=1
iteration=0
Call steppingstone
Exit
/**********************************************************************
* Subroutines for Low Cost Algorithm
**********************************************************************/
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_sum=source_sum+source.i
source_in.i=source.i
End
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
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
ss.rr=source.rr
source_in.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)
End
Say ol
End
Return
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 Iterate
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
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:\>rexx tpl vv.txt
Sources / Demands / Cost
30 20 70 30 60
50 16 16 13 22 17
60 14 14 13 19 15
50 19 19 20 23 50
50 50 12 50 15 11
Low Cost Algorithm
30 20 70 30 60
50 - - 50 - -
60 30 10 20 - -
50 - 10 - 30 10
50 - - - - 50
Total costs: 3400.0
Optimum
| |||