Rosetta Code

Transportation problem: Difference between revisions

Page Discussion

Transportation problem (view source)

Revision as of 14:12, 3 January 2021

1,719 bytes removed ,  3 years ago
→‎{{header|REXX}}: cleanup & remove debug code
m (→‎{{header|REXX}}: remove one debug line)
(→‎{{header|REXX}}: cleanup & remove debug code)
Line 3,922:
* Note: correctnes of input is not checked
* 20201226 add optimization
* 20210103 remove debug code
**********************************************************************/
Signal On Halt
Signal On Novalue
Signal On Syntax
 
Parse Arg fid
If fid='' Then
fid='input1.txt'
Call init
dbg=0
r=1
c=1
matrix.=0
iteration=0
ms=0
Do r=1 To rr
Line 3,949 ⟶ 3,950:
End
Call show_alloc 'after NWC application'
iteration=0
Call steppingstone
Exit
 
/**********************************************************************
steppingstone: Procedure Expose matrix. cost. rr cc matrix. demand_in.,
* Subroutines for NWC Algorithm
source_in. dbg iteration ms fid
**********************************************************************/
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
Call dbg 'Trial r='d3a(r) 'c='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
nquant=vquant-quant
matrix.r.c = vr vc vcost nquant
plus=\plus
End
Call show_alloc
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
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)
 
init:
Line 4,131 ⟶ 4,045:
Return
 
magicshow_alloc: Procedure Expose dbgmatrix. iterationrr mscc demand_in. source_in.
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
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
 
/**********************************************************************
* Subroutines for Optimization
**********************************************************************/
 
steppingstone: Procedure Expose matrix. cost. rr cc demand_in.,
source_in. fid
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
path=getclosedpath(r,c)
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
move=path
leaving=leavingCandidate
maxReduction = reduction
End
End
End
End
if move <> '' Then Do
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
If plus Then
nquant=vquant+quant
Else
nquant=vquant-quant
matrix.r.c = vr vc vcost nquant
plus=\plus
End
move=''
Call steppingStone
End
Else Do
Call show_alloc 'Optimal Solution' fid
End
Return
 
getclosedpath: Procedure Expose matrix. cost. rr cc
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
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
Parse Arg list
If dbg Then Do
Say 'remove_1 list>'list
End
cntr.=0
cntc.=0
Line 4,153 ⟶ 4,170:
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
Line 4,162 ⟶ 4,179:
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
Line 4,171 ⟶ 4,187:
list=list'|'e.i
End
Call dbg 'remove_1 list<'list
Return list
 
show_liststones: 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
Line 4,214 ⟶ 4,195:
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
Line 4,243 ⟶ 4,212:
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 ToBy 41 While lst<>''
Parse Var lst o.i '|' lst
End
o.0=i-1
nbrs.=''
sr=word(s,1)
Line 4,276 ⟶ 4,236:
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
Line 4,321 ⟶ 4,244:
Return i
 
show_pathfixDegenerateCase: Procedure Expose matrix. rr cc ms
Call matrixtolist
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
Line 4,360 ⟶ 4,271:
Return strip(list,,'|')
 
Novalue:
dbg:
Say 'Novalue raised in line' sigl
/* Say arg(1) */
Say sourceline(sigl)
Return</lang>
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 tpx2 input1.txt
Walterpachl
2,295

edits

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