Rosetta Code

Transportation problem: Difference between revisions

Page Discussion

Transportation problem (view source)

Revision as of 13:37, 26 December 2020

5,655 bytes added ,  3 years ago
m
→‎{{header|REXX}}: replaced Vogel's approximation with NWC + Optimization translated from Java
m (→‎{{header|REXX}}: slight improvement for default case in sourcelines)
m (→‎{{header|REXX}}: replaced Vogel's approximation with NWC + Optimization translated from Java)
Line 3,910:
 
=={{header|REXX}}==
{{trans|Java}}
<lang rexx>/* REXX ***************************************************************
* Solve the Transportation Problem using Vogel'sthe ApproximationNorthwest Corner Method
Default Input
2 3 # of sources / # of demands
Line 3,919 ⟶ 3,920:
3 2 5
* 20201210 support no input file -courtesy GS
* Note: correctnesscorrectnes of input is not checked
rexx compaxx tpj.xxx tpx.xxx d.d - anno veryq 5
* 20201226 add optimization
**********************************************************************/
Parse Arg fid
Line 3,925 ⟶ 3,928:
fid='input1.txt'
Call init
dbg=0
r=1
c=1
mmatrix.=0
iteration=0
Do Forever
dmax.ms=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
Ifmatrix.r.c=r c cost.r.c<>'*' Then Do0
Call allocate r c
cost.r.c='*'
End
End
End
r=1
c=1
Do While r<=rr & c<=cc
q=min(source.r,demand.c)
matrix.r.c=r c cost.r.c q
source.r=source.r-q
demand.c=demand.c-q
If source.r=0 Then r=r+1
If demand.c=0 Then c=c+1
End
Call show_alloc 'after NWC application'
iteration=0
Call steppingstone
Exit
 
steppingstone: Procedure Expose matrix. cost. rr cc matrix. demand_in.,
cost=0
source_in. dbg iteration ms fid
Call dbg 'steppingstone Iteration' d3(iteration)
maxReduction=0
move=''
 
Call fixDegenerateCase
 
Say ''
Say 'Allocations'
ol=' '
Do c=1 To cc
ol=ol format(dd.c,3)
End
Say ol
Do r=1 To rr
ol=format(ss.r,4)
Do c=1 To cc
IfParse mVar matrix.r.c>0 Thenr c cost Doqrc
If olqrc=ol0 Then format(m.r.c,3)Do
costCall dbg 'Trial r=cost+m.'d3a(r.) 'c*costx.r.='d3a(c)
path=getclosedpath(r,c)
 
Call show_path "A",path
 
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
--Say 'move='move
leaving=leavingCandidate
maxReduction = reduction
End
End
End
End
if move <> '' Then Do
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)
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
olnquant=ol ' vquant- 'quant
matrix.r.c = vr vc vcost nquant
plus=\plus
End
Call show_alloc
Say ol
move=''
iteration=iteration+1
Call steppingStone
End
Else Do
Say 'Total cost' cost
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
Exit
Parse Arg rd,cd
 
path=rd cd cost.rd.cd word(matrix.rd.cd,4)
allocate: Procedure Expose m. source. demand. cost. rr cc
do r=1 To rr
Parse Arg r c
sh=min(source.r,demand.c)
source.r=source.r-sh
demand.c=demand.c-sh
m.r.c=sh
If source.r=0 Then Do
Do c=1 To cc
costIf 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)
If demand.c=0 Then Do
Return stones(path)
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)
 
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 .
Line 4,057 ⟶ 4,064:
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
Line 4,077 ⟶ 4,087:
ol=ol format(cost.i.j,4)
End
End
ol=' '
Do j=1 To numDestinations
ol=ol format(demand.j,4)
End
 
Line 4,082 ⟶ 4,096:
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
Line 4,090 ⟶ 4,106:
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
Line 4,098 ⟶ 4,116:
End
End
Do r=1 To rr
Do c=1 To cc
costx.r.c=cost.r.c
End
End
 
Say 'Sources / Demands / Cost'
ol=' '
Line 4,110 ⟶ 4,122:
End
Say ol
 
Do r=1 To rr
ol=format(source.r,4)
Line 4,118 ⟶ 4,131:
End
Return
 
wordsort: Procedure
magic: Procedure Expose dbg iteration ms
/**********************************************************************
Parse Arg list
* Sort the list of words supplied as argument. Return the sorted list
Call dbg 'magic 1 list='list
**********************************************************************/
Do Forever
Parse Arg wl
list_1=remove_1(list)
wa.=''
Call dbg 'magic 2 list='list_1
wa.0=0
If list_1=list Then Leave
Do While wl<>''
list=list_1
Parse Var wl w wl
End
Do i=1 To wa.0
If dbg Then Say 'magic 3 list='list_1
If wa.i>w Then Leave
Return list_1
End
 
If i<=wa.0 Then Do
remove_1: Procedure Expose dbg iteration ms
Do j=wa.0 To i By -1
Parse Arg list
ii=j+1
If dbg Then Do
wa.ii=wa.j
Say 'remove_1 list>'list
End
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
Call dbg 'remove' e.i 'weil cntr.r='cntr.r 'und cntc.c='cntc.c
keep.i=0
End
End
list=e.1
Do i=2 To n
If keep.i Then
list=list'|'e.i
End
Call dbg 'remove_1 list<'list
Return list
 
show_list: Procedure Expose dbg iteration ms
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 iteration ms
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 '
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)'|'
Parse Var o.i
End
Call dbg ol
Return stones
 
getNeighbors: Procedure Expose o. dbg iteration ms
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
 
show_alloc: Procedure Expose matrix. rr cc demand_in. source_in. iteration ms
Parse Arg header
If header='' Then
Return
Say ''
Say header
Call dbg 'Allocations' arg(1) 'Iteration' (iteration-1)
total=0
ol=' '
Do c=1 to cc
ol=ol format(demand_in.c,3)
End
Do r=1 to rr
ol=format(source_in.r,4)
a=word(matrix.r.1,4)
If a>0 Then
ol=format(a,4)
Else
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 Then
ol=ol format(a,4)
Else
ol=ol ' - '
total=total+word(matrix.r.c,4)*word(matrix.r.c,3)
End
Say ol
End
Say 'Total costs:' format(total,4,1)
Return
 
m1: Procedure
Parse Arg z
Return z-1
 
pelems: Procedure
Parse Arg p
Do i=1 By 1 While p<>''
Parse Var p x '|' p
End
Return i
 
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
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
wa.i=w
wa.0=wa.0+1
End
swl=''End
Return
Do i=1 To wa.0
 
swl=swl wa.i
matrixtolist: Procedure Expose matrix. rr cc ms
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
/* Say swl */
Return strip(swllist,,'|')</lang>
 
dbg:
/* Say arg(1) */
Return</lang>
{{out}}
<pre>SourcesF:\>rexx /tpx2 Demands / Costinput1.txt
Sources / Demands / Cost
20 30 10
25 3 5 7
35 3 2 5
 
after NWC application
Allocations
20 20 5 30 10-
25- 20 - 25 510
Total costs: 185.0
35 - 30 5
 
Total cost 180
Optimal Solution input1.txt
20 - 5
- 30 5
Total costs: 180.0
 
F:\>rexx tpx2 input2.txt
This is an unbalanced case (sources exceed demands). We add a dummy consumer.
Sources / Demands / Cost
20 30 10 25
12 3 5 7 0
40 2 4 6 0
33 9 1 8 0
 
after NWC application
12 - - -
8 30 2 -
- - 8 25
Total costs: 248.0
 
Optimal Solution input2.txt
- - - 12
20 - 10 10
- 30 - 3
Total costs: 130.0
 
F:\>rexx tpx2 input3.txt
This is an unbalanced case (demands exceed sources). We add a dummy source.
Sources / Demands / Cost
10 15 12 15
14 10 30 25 15
10 20 15 20 10
15 10 30 20 20
12 30 40 35 45
1 0 0 0 0
 
after NWC application
10 4 - -
- 10 - -
- 1 12 2
- - - 12
- - - 1
Total costs: 1220.0
 
Optimal Solution input3.txt
Compared to Java's optimal solutions, the results are quite good
- - - Java this pgm NWC w/o Optimization14
input1.txt - 180.0 180 9 - 185 1
input2.txt 10 130.0 - 136 5 248 -
input3.txt 1000.0- 1005 5 1220</pre> 7 -
- 1 - -
Total costs: 1000.0</pre>
 
=={{header|SAS}}==
Walterpachl
2,295

edits

Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/232246"