_TITLE "Traveling Salesperson Find Shortest Round Trip 2" 'B+ 2019-04-01 '2019-03-31 #2 add thic line sub and ftri for that to show best path found so far
'2019-04-01 starting with Traveling Salesperson, make the Points array 0 based and add ID to PointType.
'fix code to handle the base 0 change
'add lexicographic order code to replace shuffle, start array Order to hold the current Order being tested.
' OK Traveling Salesman Find Shortest Rount Trip is set to run through all Permutations of Points
' to find the shortest path amoung them. (There will be nPoints * 2 minimun shortest paths
' because roundtrips are closed loops, one could start at any city and go clockwise or CCW to visit every
' city.
' Traveling Salesperson Find Shortest Round Trip 2, save time as soon as the distance exceeds smallD move on.
' Not going to work...
' 2019-04-02 Overhaul this to test a new approach to the finding the shortest trip.
' make a list of points
' make an array called connected and add the first 3 points of list to it, already shortest path
' start loop from 4 th point to nPoints
' get next point on list and compare distances from new point to all pairs of connected points
' insert (connect) the new point between the pair of conncted points
' loop to next get point until all points on list exhausted.
' Save old permutations check to verify we are building smallest trips
'2019-04-02 OK works but results are disappointing, need to see what is going on when adding points to build
'2019-04-02 OK build up the route from a points list by checking new point between every other point for
' shortest trip, I have not seen many crossed or intersecting lines, but running throuh all permutations
' there is often a better route, 50/50?
'2019-04-03 added Optimizer sub that takes the Connected() and runs through all the points again between
'all the other points looking for a smaller path, sometimes it finds, one 1/10?
'BTW after half permutations run, I end checking because you wont get any better path after that.
CONST nPoints
= 10 '3 trivial they all are shortest! more than 10 is agonizingly long to run all permutations
''start of building a shortest Trip by adding one point at a time to already connected shortest path ----------------------------
DIM SHARED LexiDone
, smallD
'signal from Lexi that it has run all perms restart:
makePointsList 'ID's will match up with Order() later
FOR i
= 0 TO 2 'add first three points on list to connected since any 3 points are already shortest trip Connected(i) = PointsList(i)
showArr Connected(), 0
PRINT "Here is our starting Triangle." 'FOR i = 0 TO 2
' PRINT Connected(i).ID, Connected(i).x, Connected(i).y
'NEXT
'end
'start adding one point at a time to connected, hoping this method preserves shortest trip
FOR ListPointer
= 3 TO nPoints
- 1 'in pairs of connected points find the smallest distand to the two points
smallestDD = 10 ^ 6 'invalid
'PRINT: PRINT "Here is Connected Array before new Point insertion:"
'FOR i = LBOUND(connected) TO UBOUND(Connected)
' PRINT Connected(i).ID, Connected(i).x, Connected(i).y
'NEXT
'INPUT "OK press enter... :", wate$
Connected(ubc + 1) = PointsList(ListPointer)
insertPointer = ubc + 1
d = dTrip!(Connected())
IF d
< smallestDD
THEN smallestDD
= d: savePointer
= insertPointer
'PRINT: PRINT "InsetPointer at"; insertPointer; "distance here ="; d; "savePointer is"; savePointer
'FOR i = LBOUND(connected) TO UBOUND(connected)
' PRINT Connected(i).ID, Connected(i).x, Connected(i).y
'NEXT
'INPUT "OK press enter... :", wate$
'setup next
SWAP Connected
(insertPointer
), Connected
(insertPointer
- 1) FOR insertPointer
= lbc
TO ubc
SWAP Connected
(insertPointer
), Connected
(insertPointer
+ 1)
''ok the new point should be all the way around to the end again
'PRINT: PRINT "OK restored Connected at end insertion of new, save Pointer="; savePointer
'FOR i = LBOUND(connected) TO UBOUND(connected)
' PRINT Connected(i).ID, Connected(i).x, Connected(i).y
'NEXT
'INPUT "OK press enter... :", wate$
connectedPointer = ubc + 1
WHILE connectedPointer
<> savePointer
SWAP Connected
(connectedPointer
), Connected
(connectedPointer
- 1) connectedPointer = connectedPointer - 1
'check insertion and that should finish the loop
'PRINT: PRINT "Check insertion:"
'FOR i = LBOUND(connected) TO UBOUND(Connected)
' PRINT Connected(i).ID, Connected(i).x, Connected(i).y
'NEXT
'INPUT "OK press enter... :", wate$
showArr Connected(), 0
showArr Connected(), 0
PRINT " Here is the map built up from list of points, hopefully close to shortest path..." INPUT "OK press enter to try Optimizer...", wate$
Optimize Connected()
PRINT "Here is that map run through the new Optimizer routine, did it help?" showArr Connected(), 0
INPUT "OK press enter to run through all Permutations...", wate$
'-------------------------------------------------------------------------------------- end of new building shortest Path code
'this is all for checking what we've built, code already works if I don't screw it up
'OK load this into Points and check if shortest path
Points(i) = PointsList(i)
copyPoints
'load Order
Order(i) = i
' initialize checking
nTests&& = factorial&&(nPoints)
copyPoints
smallD = dTrip!(Points()) ' get the distance of the points at the present load with the built path
changedShortestPath = 0
LexiDone = 0
count = 0
'checking loop to confirm that the Connected() order is best
'CLS
'showArr Points(), 0
'showArr CopyPts(), xmax / 2
'_PRINTSTRING (xmax / 2 + 125, 0), "Shortest Trip found systematically so far."
d = dTrip!(Points())
showArr Points(), 0
showArr CopyPts(), xmax / 2
_PRINTSTRING (xmax
/ 2 + 125, 0), "Shortest Trip found systematically so far." copyPoints
smallD = d
changedShortestPath = changedShortestPath + 1
count = count + 1
showArr Points(), 0
showArr CopyPts(), xmax / 2
_PRINTSTRING (xmax
/ 2 + 125, 0), "Shortest Trip found systematically so far." _PRINTSTRING (0, 0), "Round trip distance:" + STR$(d
) + " for" + STR$(count
) + " test of" + STR$(nTests&&
) + " total tests to be made."
'_DISPLAY
'_DELAY .01
'Here we update the Lexicographical Order in Order array
updateOrder ' and then will swap the order of points for next test.
IF count
> .5 * nTests&&
THEN LexiDone
= 1
'display final results
showArr Connected(), xmax / 2
_PRINTSTRING (xmax
/ 2 + 200, 5), "Here is original path built:" PRINT "From"; count;
"random routes, this was the shortest:" reloadPoints
showArr Points(), 0
PRINT "with distance of"; smallD
PRINT "Changed shortest path:"; changedShortestPath;
"times since the build of the first set of Points." PRINT "press any to Restart... "
'this sub runs through all the points and inserts each between all the other points looking for best distance
'but since we are far from ALL permutations this is not perfect system
' the builder code does a pretty good job connecting points for small path and this Optimizer does NOT change
'routes often.
SUB Optimize
(a
() AS pointType
) curD = dTrip!(a())
restart:
flag = 0
d = dTrip!(a())
curD = d
flag = 1
f&& = 1
f&& = f&& * i
factorial&& = f&&
SUB updateOrder
'from Lexicographical Order change P() to Order() 'step 1 Find largest index x st P(x) < P(x +1)
bigX = -1 'invalid index at end says we are done
IF Order
(x
) < Order
(x
+ 1) THEN bigX
= x
'step 2 Find largest y st P(x) < P(y)
bigY = -1
IF Order
(bigX
) < Order
(y
) THEN bigY
= y
'step 3 swap P(bigI) , P(bigJ)
SWAP Order
(bigX
), Order
(bigY
)
'QB64 has no slice! or any of that JS stuff, have to do this by hand
'step 4 Reverse P(x+1 ... n) = n - (x+1) -1 elements ??? let the computer count it out!
count = 0
count = count + 1
count = 0
temp(count) = Order(r)
count = count + 1
count = 0
Order(r) = temp(count)
count = count + 1
'OK now rearrange points to Order()
FOR i
= 0 TO nPoints
- 2 'only have to go to secound to last targetID = Order(i)
IF Points
(i
).ID
<> targetID
THEN 'find where it is and swap FOR j
= i
+ 1 TO nPoints
- 1 IF Points
(j
).ID
= targetID
THEN SWAP Points
(i
), Points
(j
)
PointsList(i).ID = i
PointsList
(i
).x
= RND * (xmax
- 20) * .5 + 5 PointsList
(i
).y
= RND * (ymax
- 40) + 40
CopyPts(i).x = Points(i).x
CopyPts(i).y = Points(i).y
Points(i).x = CopyPts(i).x
Points(i).y = CopyPts(i).y
d
= d
+ SQR((a
(i
).x
- a
(lba
).x
) ^ 2 + (a
(i
).y
- a
(lba
).y
) ^ 2) d
= d
+ SQR((a
(i
).x
- a
(i
+ 1).x
) ^ 2 + (a
(i
).y
- a
(i
+ 1).y
) ^ 2) dTrip! = d
SUB showArr
(a
() AS pointType
, xOffset
) 'does route and Points of given arr LINE (a
(i
).x
+ xOffset
, a
(i
).y
)-(a
(lba
).x
+ xOffset
, a
(lba
).y
) LINE (a
(i
).x
+ xOffset
, a
(i
).y
)-(a
(i
+ 1).x
+ xOffset
, a
(i
+ 1).y
) CIRCLE (a
(i
).x
+ xOffset
, a
(i
).y
), 2 d = dTrip!(a())
