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

//	Part 2 - Heuristics

//	E. McCreight
//	last edited June 15, 1977  11:58 AM  by emm

external
	[ 
	MoveBlock
	Zero
	CallSwat
	bestTotalNetLength
	heuristicWork

	GetOrderedRandomSet
	ArcLength

	forceFirstNodeToEnd
	n
	Perm

	HeuristicNet
	]


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 = vec 200
	MakeMinSpanTree(BUSpanDest)

	let Root = ReRoot(BUSpanDest)

	let TDSpanSons = vec 200
	let TDSpanBros = vec 200
	ReRepresent(BUSpanDest, TDSpanSons, TDSpanBros)

	TreeWalk(Root, TDSpanSons, TDSpanBros, Perm)

	CycleToRemoveLongest(Perm)
	]


and MakeMinSpanTree(BUSpanDest) be

	[ let InCluster = vec 200
	let NearestEltInCluster = vec 200
	let DistToCluster = vec 200

	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
				]
			]
		]
	]



and ReRoot(BUDest) = valof

	[ let Root = 1	// re-root the spanning tree at a unary node
	unless forceFirstNodeToEnd do
		[ let Into = vec 200
		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 = vec 200
	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
		]

	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 = vec 200
	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
		]
	]


and CycleToRemoveLongest(Perm) be

	[ let NewPerm = vec 200
	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
			]
	]


and HeuristicImprove() be

	[ let OrigFirstNode = Perm!1

	let aL = vec 200
	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")
	]



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 = vec 200
	let tempLens = vec 200

	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)
	resultis true
	]


(635)\f1 96f0 23f1 50f0 20f1 4595f0 18f1 3045f0 18f1 34f0 18f1