//R o u t i n g A l g o r i t h m s

//Part 2 - Heuristics

//E. McCreight
//last edited April 25, 1978 9:24 PM by emm

external
[
MoveBlock
Zero
CallSwat
bestTotalNetLength
heuristicWork

GetOrderedRandomSet
ArcLength

forceFirstNodeToEnd
n
Perm

HeuristicNet

Allocate
Free
SilZone
]


static
[
arcLens
totalCircuitLength
longestArcLen
longestArc
heuristicImprovements
improvementBreak = -1
heuristicWork = 20
]


//2. A heuristic algorithm which does not guarantee an
//optimum but is much more economical than the
//combinatorial one for large nets.

let HeuristicNet() be

[ GenerateGoodPerm()
HeuristicImprove()
]


and GenerateGoodPerm() be

[ let BUSpanDest = Allocate(SilZone, n+2)
MakeMinSpanTree(BUSpanDest)

let Root = ReRoot(BUSpanDest)

let TDSpanSons = Allocate(SilZone, n+2)
let TDSpanBros = Allocate(SilZone, n+2)

ReRepresent(BUSpanDest, TDSpanSons, TDSpanBros)

Free(SilZone, BUSpanDest)

TreeWalk(Root, TDSpanSons, TDSpanBros, Perm)

Free(SilZone, TDSpanSons)
Free(SilZone, TDSpanBros)

CycleToRemoveLongest(Perm)
]


and MakeMinSpanTree(BUSpanDest) be

[ let InCluster = Allocate(SilZone, n+2)
let NearestEltInCluster = Allocate(SilZone, n+2)
let DistToCluster = Allocate(SilZone, n+2)

let NearestOutsideElt = 0
let ShortestDistToCluster = nil

for i=1 to n do
[ InCluster!i = (i eq 1)
if InCluster!i then
[ BUSpanDest!i = 0
loop
]

NearestEltInCluster!i = 1
DistToCluster!i = ArcLength(1, i)
if (NearestOutsideElt eq 0) %
(DistToCluster!i ls ShortestDistToCluster)
then
[ NearestOutsideElt = i
ShortestDistToCluster = DistToCluster!i
]
]


while NearestOutsideElt ne 0 do

[ BUSpanDest!NearestOutsideElt = NearestEltInCluster!NearestOutsideElt
InCluster!NearestOutsideElt = true

let NewClusterElt = NearestOutsideElt
NearestOutsideElt = 0

for i=1 to n do
[ if InCluster!i then loop
let DistToNewClusterElt = ArcLength(i, NewClusterElt)
if DistToNewClusterElt ls DistToCluster!i then
[ DistToCluster!i = DistToNewClusterElt
NearestEltInCluster!i = NewClusterElt
]

if (NearestOutsideElt eq 0) %
(DistToCluster!i ls ShortestDistToCluster)
then
[ NearestOutsideElt = i
ShortestDistToCluster = DistToCluster!i
]
]
]
Free(SilZone, InCluster)
Free(SilZone, NearestEltInCluster)
Free(SilZone, DistToCluster)
]



and ReRoot(BUDest) = valof

[ let Root = 1// re-root the spanning tree at a unary node
let Into = Allocate(SilZone, n+2)
unless forceFirstNodeToEnd do
[ Zero(Into+1, n)
for i=1 to n do
Into!(BUDest!i)=Into!(BUDest!i)+1
for i=1 to n do
if Into!i eq 0 then
[ Root = i
break
]
]

let Father = Into
let CurNode = Root
let CurAlt = 0
while BUDest!CurNode ne 0 do
[ Father!CurAlt = CurNode
CurAlt = CurAlt+1
CurNode = BUDest!CurNode
]

while CurAlt gr 0 do
[ CurAlt = CurAlt-1
BUDest!CurNode = Father!CurAlt
CurNode = Father!CurAlt
]

Free(SilZone, Father)

BUDest!Root = 0
resultis Root
]


and ReRepresent(BUDest, TDSons, TDBros) be

[ Zero(TDSons+1, n)
Zero(TDBros+1, n)

for i=1 to n do
[ let Father = BUDest!i
if Father eq 0 then loop// this is the root

TDBros!i = TDSons!Father
TDSons!Father = i
]
]


and TreeWalk(Root, TDSons, TDBros, Perm) be

[ let BroStack = Allocate(SilZone, n+2)
let Depth = 0
let NodesInPerm = 0

while Depth ge 0 do
[ NodesInPerm = NodesInPerm+1
Perm!NodesInPerm = Root

let Son = TDSons!Root
if Son ne 0 then
[ BroStack!Depth = TDBros!Root
if BroStack!Depth ne 0 then Depth = Depth+1
Root = Son
loop
]

Root = TDBros!Root
if Root ne 0 then loop

Depth = Depth-1
Root = BroStack!Depth
]

Free(SilZone, BroStack)
]


and CycleToRemoveLongest(Perm) be

[ let NewPerm = Allocate(SilZone, n+2)
let LongestArcPos = nil
let LongestArcLen = -1

test forceFirstNodeToEnd

ifnot[ for i=1 to n do
[ let ThisArcLen = ArcLength(Perm!i,
Perm!((i rem n)+1))
if ThisArcLen gr LongestArcLen then
[ LongestArcLen = ThisArcLen
LongestArcPos = i
]
]

MoveBlock(lv (NewPerm!1), lv (Perm!(LongestArcPos+1)),
n-LongestArcPos)
MoveBlock(lv (NewPerm!((n-LongestArcPos)+1)), lv (Perm!1),
LongestArcPos)
MoveBlock(lv (Perm!1), lv (NewPerm!1), n)
]

ifso if ArcLength(Perm!1, Perm!2) gr
ArcLength(Perm!n, Perm!1) then // reverse Perm!2..Perm!n
for i=1 to (n-1)/2 do
[ let T = Perm!(i+1)
Perm!(i+1) = Perm!(n+1-i)
Perm!(n+1-i) = T
]
Free(SilZone, NewPerm)
]


and HeuristicImprove() be

[ let OrigFirstNode = Perm!1

let aL = Allocate(SilZone, n+2)
arcLens = aL

let tempArcLen = nil
totalCircuitLength = 0

let triesSinceImprovement = 0
let criterion = heuristicWork*n
longestArcLen = -1

for i=1 to n do
[ tempArcLen = ArcLength(Perm!i, Perm!((i rem n)+1))
totalCircuitLength = totalCircuitLength+tempArcLen
arcLens!i = tempArcLen
if tempArcLen gr longestArcLen then
[ longestArc = Perm!i
longestArcLen = tempArcLen
]
]

if forceFirstNodeToEnd then
test arcLens!n gr arcLens!1
ifso[ longestArc = Perm!n
longestArcLen = arcLens!n
]
ifnot[ longestArc = Perm!1
longestArcLen = arcLens!1
]

bestTotalNetLength = totalCircuitLength-longestArcLen
heuristicImprovements = 0

while triesSinceImprovement ls criterion do
[ triesSinceImprovement = triesSinceImprovement+1

if forceFirstNodeToEnd & (longestArc ne Perm!1) &
(longestArc ne Perm!n) then
[ CallSwat("Heuristic bug 1")
]

let segmentLasts = vec 4
GetOrderedRandomSet(3, segmentLasts, 1, n)

let segmentFirsts = vec 4
segmentFirsts!1 = (segmentLasts!3 ge n)? 1,
segmentLasts!3+1
for i=2 to 3 do
segmentFirsts!i = (segmentLasts!(i-1))+1

if ThisArrangementBetter(segmentFirsts, segmentLasts,
1, 3, 2) %
ThisArrangementBetter(segmentFirsts, segmentLasts,
1, -3, -2) %
ThisArrangementBetter(segmentFirsts, segmentLasts,
1, -3, 2) %
ThisArrangementBetter(segmentFirsts, segmentLasts,
1, 3, -2)
then
[ heuristicImprovements =
heuristicImprovements+1
if heuristicImprovements eq improvementBreak
then
CallSwat("Improvement break")

triesSinceImprovement = 0
]
]

MoveLongestArcToEnd:

CycleToRemoveLongest(Perm)

if forceFirstNodeToEnd then
for i=1 to n/2 do
[ let T = Perm!(n+1-i)// reverse it to get first
Perm!(n+1-i) = Perm!i// node at end
Perm!i = T
]

if forceFirstNodeToEnd & (Perm!n ne OrigFirstNode) then
CallSwat("Heuristic bug 2")

Free(SilZone, aL)
]



and ThisArrangementBetter(origF, origL, seg1, seg2, seg3) = valof

[ // This whole piece of code will fall apart on
// the floor unless seg1 eq 1. OK?

let seg = (lv seg1)-1
let f = vec 4
let l = vec 4
for i=1 to 3 do
[ f!i = (seg!i ls 0)? origL!(-(seg!i)), origF!(seg!i)
l!i = (seg!i ls 0)? origF!(-(seg!i)), origL!(seg!i)
]

let newArcLens = vec 4

for i=1 to 2 do
newArcLens!i = ArcLength(Perm!(l!i), Perm!(f!(i+1)))
newArcLens!3 = ArcLength(Perm!(l!3), Perm!(f!1))

let tempLongestArc = longestArc
let tempLongestArcLen = longestArcLen

if valof
[ for j=1 to 3 do
if Perm!(origL!j) eq longestArc then
resultis true
resultis false
]
then

[ tempLongestArcLen = 0
for i=1 to n do
if (arcLens!i gr tempLongestArcLen) &
valof
[ for j=1 to 3 do
if origL!j eq i then
resultis false
resultis true
]
then
[ tempLongestArc = Perm!i
tempLongestArcLen = arcLens!i
]
]

for j=1 to 3 do
if newArcLens!j gr tempLongestArcLen then
[ tempLongestArc = -(Perm!(l!j))
tempLongestArcLen = newArcLens!j
]

if forceFirstNodeToEnd then
[ let firstArc = Perm!1
let firstArcLen = arcLens!1
if origL!1 eq 1 then
firstArcLen = newArcLens!1

let lastArc = Perm!n
let lastArcLen = arcLens!n

if origL!3 eq n
then[ lastArc = Perm!(l!3)
lastArcLen = newArcLens!3
]

test firstArcLen ge lastArcLen

ifso[ tempLongestArc = -firstArc
tempLongestArcLen = firstArcLen
]

ifnot[ tempLongestArc = -lastArc
tempLongestArcLen = lastArcLen
]
]

let newNetLen = totalCircuitLength+valof
[ let sum=0
for j=1 to 3 do
sum = sum+newArcLens!j-
arcLens!(origL!j)
resultis sum
]-
tempLongestArcLen

unless newNetLen ls bestTotalNetLength do resultis false

HBetterNet:
bestTotalNetLength = newNetLen

totalCircuitLength = newNetLen+tempLongestArcLen

let tempVec = Allocate(SilZone, n+2)
let tempLens = Allocate(SilZone, n+2)

let nextWord = 1
for j=2 to 3 do
[ test seg!j ge 0
ifso[ MoveBlock(tempVec+nextWord,
lv (Perm!(f!j)),
(l!j-f!j+1))
MoveBlock(tempLens+nextWord,
lv (arcLens!(f!j)),
(l!j-f!j+1))
nextWord = nextWord+(l!j-f!j+1)
]

ifnot[ let cur = f!j
while cur ge l!j do
[ tempVec!nextWord = Perm!cur
tempLens!nextWord = arcLens!(cur-1)
if cur gr l!j &
tempLongestArc eq
Perm!(cur-1)
then
tempLongestArc = Perm!cur
cur = cur-1
nextWord = nextWord+1
]
]
tempLens!(nextWord-1) = newArcLens!j
]

arcLens!(origL!1) = newArcLens!1

longestArc = (tempLongestArc ge 0)? tempLongestArc,
-tempLongestArc
longestArcLen = tempLongestArcLen

MoveBlock(lv (Perm!(origF!2)), lv (tempVec!1), nextWord-1)
MoveBlock(lv (arcLens!(origF!2)), lv (tempLens!1),
nextWord-1)
Free(SilZone, tempVec)
Free(SilZone, tempLens)
resultis true
]