//routeSpanTree.bcpl

// Cheap wire router that sets up a pretty good (at worst 2x optimum)
// permutation for the heuristic router.

//last edited by McCreight, July 2, 1981 3:37 PM

get "route.defs"

let GenerateGoodPerm() be

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

let Root = ReRoot(BUSpanDest)

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

ReRepresent(BUSpanDest, TDSpanSons, TDSpanBros)

Free(swapZone, BUSpanDest)

TreeWalk(Root, TDSpanSons, TDSpanBros, Perm)

Free(swapZone, TDSpanSons)
Free(swapZone, TDSpanBros)

CycleToRemoveLongest(Perm)
]


and MakeMinSpanTree(BUSpanDest) be

[ let InCluster = Allocate(swapZone, n+2)
let NearestEltInCluster = Allocate(swapZone, n+2)
let DistToCluster = Allocate(swapZone, 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(swapZone, InCluster)
Free(swapZone, NearestEltInCluster)
Free(swapZone, DistToCluster)
]



and ReRoot(BUDest) = valof

[ let Root = 1// re-root the spanning tree at a unary node
let Into = Allocate(swapZone, 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(swapZone, 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(swapZone, 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(swapZone, BroStack)
]

and CycleToRemoveLongest(Perm) be

[ let NewPerm = Allocate(swapZone, 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(swapZone, NewPerm)
]