Vogel's approximation method: Difference between revisions
m
→{{header|REXX}}: added algorithm plus optimization
(→{{header|REXX}}: I fixed Dee, Tee Hee) |
Walterpachl (talk | contribs) m (→{{header|REXX}}: added algorithm plus optimization) |
||
Line 1,635:
=={{header|REXX}}==
{{trans|java}}
<lang rexx>/* REXX ***************************************************************
* 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
30 20 70 30 60
Line 1,644 ⟶ 2,238:
50 50 12 50 15 11
Vogel's Approximation
30 20 70 30 60
50 - - 50 - -
Line 1,650 ⟶ 2,244:
50 30 20 - - -
50 - - - 30 20
Total
Optimum
30 20 70 30 60
50 - - 50 - -
60 30 - 20 - 10
50 - 20 - 30 -
50 - - - - 50
Total costs: 3100.0</pre>
=={{header|Ruby}}==
| |||