## The Travelling Salesman Problem

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
UEZ
Posts: 996
Joined: May 05, 2017 19:59
Location: Germany

### Re: The Travelling Salesman Problem

caseih wrote: Mar 09, 2024 1:58
UEZ wrote: Mar 08, 2024 20:52 The first time I heard about the traveling salesman problem was in computer science class at university in the early 90s. The problem is NP-complete, as far as I can remember, and not solvable in polynomial time.

It is good to hear that the solution to the problem has actually found practical application.
Yes that's the first I've heard of it being applied to a person's daily life who wasn't a salesman. haha.

This problem actually does have a lot of practical application. There's a reason it has the name it has! Companies with salespeople on the road really do need to have workable solutions to this thorny problem. Another practical application would be in generating CNC paths. Fortunately there are several heuristics that provide acceptable solutions to this problem in acceptable time, with different tradeoffs (often using a lot of memory). I think the main heuristic we used in uni was branch and bound. But it's been a long time. I learned enough to identify probable NP-complete problems, so I can avoid trying to solve them.
An example could be the parcel deliverers who have to deliver x parcels to the addresses and have to calculate the optimal route based on the parcels.
BasicCoder2
Posts: 3917
Joined: Jan 01, 2009 7:03
Location: Australia

### Re: The Travelling Salesman Problem

@dodicat
Many years ago (1984), my late wife and myself and our small dog took a long Summer break in our towing caravan.
We ended up near London, and parked up in a site by the edge of Epping forest.
My wife got a temporary job, at her trade as bookkeeper, in Woodford Green, I took a job as a milkman at Hobb's Cross dairies near Theydon Bois.
It can be bitter sweet to remember back over our life. I am sorry for your loss. Your story reminds me of even further back in time when as a child we had our milk and bread delivered each morning to the family citrus orchard.
BasicCoder2
Posts: 3917
Joined: Jan 01, 2009 7:03
Location: Australia

### Re: The Travelling Salesman Problem

Both the circle and nearest town algorithms get pretty good results.
Last edited by BasicCoder2 on Mar 11, 2024 22:44, edited 1 time in total.
dodicat
Posts: 7993
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: The Travelling Salesman Problem

I have compared my circulate method to the permutations method ( the actual shortest).
Only up to 4 to 10 points, beyond that the permutations method is slow.

Code: Select all

``````
#cmdline "-gen gcc -O 2"
Screen 20
Type pt
As single x,y
End Type

Dim Shared As Single d
#define intrange(f,l) Int(Rnd*(((l)+1)-(f))+(f))

Function length(a As pt,b As pt) As Single
Return Sqr((a.x-b.x)*(a.x-b.x)+(a.y-b.y)*(a.y-b.y))
End Function

Sub circulate(p() As pt)
#macro Circlesort()
'  bubblesort
For p1 As Long  = Lbound(p) To Ubound(p)-1
For p2 As Long  = p1 + 1 To Ubound(p)
If Atan2(p(p1).y-c.y,p(p1).x-c.x)< Atan2(p(p2).y-c.y,p(p2).x-c.x) Then
Swap p(p1),p(p2)
End If
Next p2
Next p1
#endmacro
Dim As pt C '--centroid of points
Dim As Long counter
For n As Long=Lbound(p) To Ubound(p)
counter+=1
c.x+=p(n).x
c.y+=p(n).y
Next n
c.x=c.x/counter
c.y=c.y/counter
CircleSort()
End Sub

Sub Permutate(s As String,perm() As String,OptionalStop As String="")
Dim As Integer p,i,j,result
Dim As String s2=s
Redim perm(0)
Dim As Double factorial
Dim temp As Double=1
If Len(s2) >1 Then
For n As Integer =1 To Len(s2)
temp =temp * n
Next
factorial =temp
Else
factorial =1
End If
Redim perm(1 To factorial)
For p1 As Integer =0 To Len(s2)-2
For p2 As Integer =p1 + 1 To Len(s2)-1
If s2[p1]>s2[p2] Then Swap s2[p1],s2[p2]
Next p2
Next p1
Do
p=p+1
perm(p)=s2
If s2=OptionalStop Then Exit  Do
Do
For i=Len(s2)-2 To 0 Step -1
If s2[i] <s2[i+1] Then Exit For
Next
If i <0 Then Result=0:Exit Do
j =Len(s2)-1
While s2[j] <= s2[i]: j -=1 : Wend
Swap s2[i], s2[j]
i +=1
j =Len(s2)-1
While i <j
Swap s2[i], s2[j]
i +=1
j -=1
Wend
result=-1:Exit Do
Loop
Loop Until result=0
Redim Preserve perm(1 To p)
End Sub

Function distances(points() As pt,s As String,o() As pt) As Single
Dim As Single total
For n As Long =Lbound(points) To Ubound(points)-1
total+=(length(points(s[n-1]),points(s[n])))
Next n
total+=(length(points(s[Len(s)-1]),points(s[0])))
If d>total Then
d=total
For n As Integer=Lbound(points) To Ubound(points)
o(n)=points(s[n-1])
Next n
End If
Return d
End Function

Function distanceround(points() As pt) As Single
Dim As Single total
For n As Long=Lbound(points) To Ubound(points)-1
total+=length(points(n),points(n+1))
Next n
total+=(length(points(Ubound(points)),points(Lbound(points))))
End Function

Sub show(p() As pt,flag As Long=0,offset As pt=Type(0,0))
For n As Long=Lbound(p) To Ubound(p)
Circle(p(n).x+offset.x,p(n).y+offset.y),5,,,,,f
Next n
If flag Then
Draw String(p(Lbound(p)).x+offset.x,p(Lbound(p)).y+offset.y+10),Str(1)
Circle(p(Lbound(p)).x+offset.x,p(Lbound(p)).y+offset.y),5,,,,,f
For n As Long=Lbound(p)+1 To Ubound(p)
Line - (p(n).x+offset.x,p(n).y+offset.y)
Draw String(p(n).x+offset.x,p(n).y+offset.y+10),Str(n)
Circle(p(n).x+offset.x,p(n).y+offset.y),5,,,,,f
Next
Line(p(Ubound(p)).x+offset.x,p(Ubound(p)).y+offset.y)-(p(Lbound(p)).x+offset.x,p(Lbound(p)).y+offset.y )
End If
End Sub

Function getstring(pts() As pt) As String
Dim As String s
For n As Long=Lbound(pts) To Ubound(pts)
s+=Chr(n)
Next
Return s
End Function

Function main() As Long
Windowtitle "SPACE TO REFRESH, ESCAPE TO END"
Do
d=1000000
Line(512,0)-(512,768)
Redim As pt pts(1 To intrange(4,10)),copy(1 To Ubound(pts)),o(1 To Ubound(pts))

For n As Long=1 To Ubound(pts)
pts(n).x=intrange(50,(512-50))
pts(n).y=intrange(50,(768-50))
copy(n)=pts(n)
Next
Var t=Timer
show(pts())
circulate(pts())
show(pts(),1)
Print "Distance round ";distanceround(pts())
Print "Circulate (doughnut) method"
Print "time taken ";Timer-t

Dim As String s=getstring(copy())
t=Timer
show(copy(),,Type(512,0))
'Print s
Redim As String p()
permutate(s,p())

For n As Long=Lbound(p) To Ubound(p)
distances(copy(),p(n),o())
Next

show(o(),1,Type(512,0))
Locate 1,66
Print "Distance round ";distanceround(o())
Locate 2,66
Print "Permutations  method"
Locate 3,66
Print "time taken ";Timer-t
Sleep
Cls
Loop Until Inkey=Chr(27)
Return 0
End Function
Randomize
End main

``````
dodicat
Posts: 7993
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: The Travelling Salesman Problem

I notice that using the nearest neighbour method, it depends where the starting point is.
So I have cycled the original array all the way round to get the optimal distance from the optimal starting point.
Tested 32/64 bits and with -exx error check.

Code: Select all

``````
#cmdline "-gen gcc -O 2"
Screen 20
Type pt
As Single x,y
End Type

Dim Shared As Single d
#define intrange(f,l) Int(Rnd*(((l)+1)-(f))+(f))

Function length(a As pt,b As pt) As Single
Return Sqr((a.x-b.x)*(a.x-b.x)+(a.y-b.y)*(a.y-b.y))
End Function

Sub circulate(p() As pt)
#macro Circlesort()
'  bubblesort
For p1 As Long  = Lbound(p) To Ubound(p)-1
For p2 As Long  = p1 + 1 To Ubound(p)
If Atan2(p(p1).y-c.y,p(p1).x-c.x)< Atan2(p(p2).y-c.y,p(p2).x-c.x) Then
Swap p(p1),p(p2)
End If
Next p2
Next p1
#endmacro
Dim As pt C '--centroid of points
Dim As Long counter
For n As Long=Lbound(p) To Ubound(p)
counter+=1
c.x+=p(n).x
c.y+=p(n).y
Next n
c.x=c.x/counter
c.y=c.y/counter
CircleSort()
End Sub

Sub Permutate(s As String,perm() As String,OptionalStop As String="")
Dim As Integer p,i,j,result
Dim As String s2=s
Redim perm(0)
Dim As Double factorial
Dim temp As Double=1
If Len(s2) >1 Then
For n As Integer =1 To Len(s2)
temp =temp * n
Next
factorial =temp
Else
factorial =1
End If
Redim perm(1 To factorial)
For p1 As Integer =0 To Len(s2)-2
For p2 As Integer =p1 + 1 To Len(s2)-1
If s2[p1]>s2[p2] Then Swap s2[p1],s2[p2]
Next p2
Next p1
Do
p=p+1
perm(p)=s2
If s2=OptionalStop Then Exit  Do
Do
For i=Len(s2)-2 To 0 Step -1
If s2[i] <s2[i+1] Then Exit For
Next
If i <0 Then Result=0:Exit Do
j =Len(s2)-1
While s2[j] <= s2[i]: j -=1 : Wend
Swap s2[i], s2[j]
i +=1
j =Len(s2)-1
While i <j
Swap s2[i], s2[j]
i +=1
j -=1
Wend
result=-1:Exit Do
Loop
Loop Until result=0
Redim Preserve perm(1 To p)
End Sub

Function closest Overload(clr() As pt,v As pt,k As Long=0) As Long
Dim As Ulong res
#define dist(p1,p2) Sqr((p1.x-p2.x)*(p1.x-p2.x) + (p1.y-p2.y)*(p1.y-p2.y))' + (p1.z-p2.z)*(p1.z-p2.z)
Dim As Double dt=1e20
For n As Long=1 To Ubound(clr)
If (clr(n).x=v.x And clr(n).y=v.y)   Then Continue For
Var distance=dist(clr(n),v)
If dt> distance Then dt = distance:res=n 'catch the smallest
Next n
Return Iif(k,dt,res)
End Function

Sub arrayinsert(a() As pt,index As Long,insert As pt)
If index>=Lbound(a) And index<=Ubound(a)+1 Then
Var index2=index-Lbound(a)
Redim Preserve a(Lbound(a) To  Ubound(a)+1)
For x As Integer= Ubound(a) To Lbound(a)+index2+1 Step -1
Swap a(x),a(x-1)
Next x
a(Lbound(a)+index2)=insert
End If
End Sub

Function arraydelete(a() As pt,index As Long) As pt
Var v=a(index)
If index>=Lbound(a) And index<=Ubound(a) Then
For x As Integer=index To Ubound(a)-1
a(x)=a(x+1)
Next x
if ubound(a)-1>=lbound(a) then
Redim Preserve a(Lbound(a) To Ubound(a)-1)
end if
End If
Return v
End Function

Sub nearest(p() As pt,_out() As pt)
Redim _out(Lbound(p) To Ubound(p))
Dim As Long c=0,x
Dim As pt temp=p(1)
Do
x=closest(p(),temp)
c+=1
If c>Ubound(_out) Then Exit Do
_out(c)=p(x)
temp= arraydelete(p(),x)
Loop
End Sub

Function distances(points() As pt,s As String,o() As pt) As Single
Dim As Single total
For n As Long =Lbound(points) To Ubound(points)-1
total+=(length(points(s[n-1]),points(s[n])))
Next n
total+=(length(points(s[Len(s)-1]),points(s[0])))
If d>total Then
d=total
For n As Integer=Lbound(points) To Ubound(points)
o(n)=points(s[n-1])
Next n
End If
Return d
End Function

Function distanceround(points() As pt) As Single
Dim As Single total
For n As Long=Lbound(points) To Ubound(points)-1
total+=length(points(n),points(n+1))
Next n
total+=(length(points(Ubound(points)),points(Lbound(points))))
End Function

Sub show(p() As pt,flag As Long=0,offset As pt=Type(0,0))
For n As Long=Lbound(p) To Ubound(p)
Circle(p(n).x+offset.x,p(n).y+offset.y),5,,,,,f
Next n
If flag Then
Draw String(p(Lbound(p)).x+offset.x,p(Lbound(p)).y+offset.y+10),Str(1)
Circle(p(Lbound(p)).x+offset.x,p(Lbound(p)).y+offset.y),5,,,,,f
For n As Long=Lbound(p)+1 To Ubound(p)
Line - (p(n).x+offset.x,p(n).y+offset.y)
Draw String(p(n).x+offset.x,p(n).y+offset.y+10),Str(n)
Circle(p(n).x+offset.x,p(n).y+offset.y),5,,,,,f
Next
Line(p(Ubound(p)).x+offset.x,p(Ubound(p)).y+offset.y)-(p(Lbound(p)).x+offset.x,p(Lbound(p)).y+offset.y )
End If
End Sub

Sub cycle(a() As pt)
Var tmp=a(Lbound(a))
arraydelete(a(),Lbound(a))
arrayinsert(a(),Ubound(a),tmp)
End Sub

Sub bestneighbours(pts() As pt,copy() As pt,o() As pt)'3194
Dim As Long d=10000000
Redim As pt z()
Redim o(Lbound(copy) To Ubound(copy))
For n As Long=Lbound(copy) To Ubound(copy)
nearest(pts(),z())
Var dr=distanceround(z())
If d>dr Then
For k As Long=Lbound(copy) To Ubound(copy)
o(k)=z(k)
Next k
d=dr
End If
cycle(copy())
Redim pts(1 To Ubound(copy))
For m As Long=1 To Ubound(z)
pts(m)=copy(m)
Next m
Next n
End Sub

Function getstring(pts() As pt) As String
Dim As String s
For n As Long=Lbound(pts) To Ubound(pts)
s+=Chr(n)
Next
Return s
End Function

Sub setup(points() As pt)
For n As Integer=Lbound(points) To Ubound(points)
Do
points(n).x=IntRange(20,512-20)
points(n).y=IntRange(50,768-50)
Loop Until closest(points(),points(n),1)>50
Next n
End Sub

Function main() As Long
Windowtitle "SPACE TO REFRESH, ESCAPE TO END"
Do
d=1000000
Line(512,0)-(512,768)
Redim As pt pts(1 To intrange(7,10)),copy(1 To Ubound(pts)),o(1 To Ubound(pts)),oo()
setup(pts())
For n As Long=1 To Ubound(pts)
copy(n)=pts(n)
Next
Var t=Timer
show(pts())
circulate(pts())
bestneighbours(pts() ,copy() ,oo())
show(oo(),1)

Print "Distance round ";distanceround(oo())
Print "Nearest neighbour optimized method"
Print "time taken ";Timer-t

Dim As String s=getstring(copy())
t=Timer
show(copy(),,Type(512,0))
Redim As String p()
permutate(s,p())

For n As Long=Lbound(p) To Ubound(p)
distances(copy(),p(n),o())
Next

show(o(),1,Type(512,0))
Locate 1,66
Print "Distance round ";distanceround(o())
Locate 2,66
Print "Permutations  method"
Locate 3,66
Print "time taken ";Timer-t
Sleep
Cls
Loop Until Inkey=Chr(27)
Return 0
End Function
Randomize 2
End main
``````
BasicCoder2
Posts: 3917
Joined: Jan 01, 2009 7:03
Location: Australia

### Re: The Travelling Salesman Problem

@dodicat
I wondered how well you could figure out the shortest path by visual inspection. The human eye is very good at clustering.
So I modified your code as I was too lazy to write my own version hope you don't mind.
I added a function drawLine() so by clicking each point you could join them up with straight red lines.
When you are done click the right mouse button and the program will continue and display the permutation version to compare.
I found I was usually spot on.

Code: Select all

``````#cmdline "-gen gcc -O 2"
Screen 20
Type pt
As Single x,y
End Type

Dim Shared As Single d,dd
#define intrange(f,l) Int(Rnd*(((l)+1)-(f))+(f))

Function length(a As pt,b As pt) As Single
Return Sqr((a.x-b.x)*(a.x-b.x)+(a.y-b.y)*(a.y-b.y))
End Function

Sub circulate(p() As pt)
#macro Circlesort()
'  bubblesort
For p1 As Long  = Lbound(p) To Ubound(p)-1
For p2 As Long  = p1 + 1 To Ubound(p)
If Atan2(p(p1).y-c.y,p(p1).x-c.x)< Atan2(p(p2).y-c.y,p(p2).x-c.x) Then
Swap p(p1),p(p2)
End If
Next p2
Next p1
#endmacro
Dim As pt C '--centroid of points
Dim As Long counter
For n As Long=Lbound(p) To Ubound(p)
counter+=1
c.x+=p(n).x
c.y+=p(n).y
Next n
c.x=c.x/counter
c.y=c.y/counter
CircleSort()
End Sub

Sub Permutate(s As String,perm() As String,OptionalStop As String="")
Dim As Integer p,i,j,result
Dim As String s2=s
Redim perm(0)
Dim As Double factorial
Dim temp As Double=1
If Len(s2) >1 Then
For n As Integer =1 To Len(s2)
temp =temp * n
Next
factorial =temp
Else
factorial =1
End If
Redim perm(1 To factorial)
For p1 As Integer =0 To Len(s2)-2
For p2 As Integer =p1 + 1 To Len(s2)-1
If s2[p1]>s2[p2] Then Swap s2[p1],s2[p2]
Next p2
Next p1
Do
p=p+1
perm(p)=s2
If s2=OptionalStop Then Exit  Do
Do
For i=Len(s2)-2 To 0 Step -1
If s2[i] <s2[i+1] Then Exit For
Next
If i <0 Then Result=0:Exit Do
j =Len(s2)-1
While s2[j] <= s2[i]: j -=1 : Wend
Swap s2[i], s2[j]
i +=1
j =Len(s2)-1
While i <j
Swap s2[i], s2[j]
i +=1
j -=1
Wend
result=-1:Exit Do
Loop
Loop Until result=0
Redim Preserve perm(1 To p)
End Sub

Function closest Overload(clr() As pt,v As pt,k As Long=0) As Long
Dim As Ulong res
#define dist(p1,p2) Sqr((p1.x-p2.x)*(p1.x-p2.x) + (p1.y-p2.y)*(p1.y-p2.y))' + (p1.z-p2.z)*(p1.z-p2.z)
Dim As Double dt=1e20
For n As Long=1 To Ubound(clr)
If (clr(n).x=v.x And clr(n).y=v.y)   Then Continue For
Var distance=dist(clr(n),v)
If dt> distance Then dt = distance:res=n 'catch the smallest
Next n
Return Iif(k,dt,res)
End Function

Sub arrayinsert(a() As pt,index As Long,insert As pt)
If index>=Lbound(a) And index<=Ubound(a)+1 Then
Var index2=index-Lbound(a)
Redim Preserve a(Lbound(a) To  Ubound(a)+1)
For x As Integer= Ubound(a) To Lbound(a)+index2+1 Step -1
Swap a(x),a(x-1)
Next x
a(Lbound(a)+index2)=insert
End If
End Sub

Function arraydelete(a() As pt,index As Long) As pt
Var v=a(index)
If index>=Lbound(a) And index<=Ubound(a) Then
For x As Integer=index To Ubound(a)-1
a(x)=a(x+1)
Next x
if ubound(a)-1>=lbound(a) then
Redim Preserve a(Lbound(a) To Ubound(a)-1)
end if
End If
Return v
End Function

Sub nearest(p() As pt,_out() As pt)
Redim _out(Lbound(p) To Ubound(p))
Dim As Long c=0,x
Dim As pt temp=p(1)
Do
x=closest(p(),temp)
c+=1
If c>Ubound(_out) Then Exit Do
_out(c)=p(x)
temp= arraydelete(p(),x)
Loop
End Sub

Function distances(points() As pt,s As String,o() As pt) As Single
Dim As Single total
For n As Long =Lbound(points) To Ubound(points)-1
total+=(length(points(s[n-1]),points(s[n])))
Next n
total+=(length(points(s[Len(s)-1]),points(s[0])))
If d>total Then
d=total
For n As Integer=Lbound(points) To Ubound(points)
o(n)=points(s[n-1])
Next n
End If
Return d
End Function

Function distanceround(points() As pt) As Single
Dim As Single total
For n As Long=Lbound(points) To Ubound(points)-1
total+=length(points(n),points(n+1))
Next n
total+=(length(points(Ubound(points)),points(Lbound(points))))
End Function

Sub show(p() As pt,flag As Long=0,offset As pt=Type(0,0))
For n As Long=Lbound(p) To Ubound(p)
Circle(p(n).x+offset.x,p(n).y+offset.y),5,,,,,f
Next n
If flag Then
Draw String(p(Lbound(p)).x+offset.x,p(Lbound(p)).y+offset.y+10),Str(1)
Circle(p(Lbound(p)).x+offset.x,p(Lbound(p)).y+offset.y),5,,,,,f
For n As Long=Lbound(p)+1 To Ubound(p)
Line - (p(n).x+offset.x,p(n).y+offset.y)
Draw String(p(n).x+offset.x,p(n).y+offset.y+10),Str(n)
Circle(p(n).x+offset.x,p(n).y+offset.y),5,,,,,f
Next
Line(p(Ubound(p)).x+offset.x,p(Ubound(p)).y+offset.y)-(p(Lbound(p)).x+offset.x,p(Lbound(p)).y+offset.y )
End If
End Sub

Sub cycle(a() As pt)
Var tmp=a(Lbound(a))
arraydelete(a(),Lbound(a))
arrayinsert(a(),Ubound(a),tmp)
End Sub

Sub bestneighbours(pts() As pt,copy() As pt,o() As pt)'3194
Dim As Long d=10000000
Redim As pt z()
Redim o(Lbound(copy) To Ubound(copy))
For n As Long=Lbound(copy) To Ubound(copy)
nearest(pts(),z())
Var dr=distanceround(z())
If d>dr Then
For k As Long=Lbound(copy) To Ubound(copy)
o(k)=z(k)
Next k
d=dr
End If
cycle(copy())
Redim pts(1 To Ubound(copy))
For m As Long=1 To Ubound(z)
pts(m)=copy(m)
Next m
Next n
End Sub

Function getstring(pts() As pt) As String
Dim As String s
For n As Long=Lbound(pts) To Ubound(pts)
s+=Chr(n)
Next
Return s
End Function

Sub setup(points() As pt)
For n As Integer=Lbound(points) To Ubound(points)
Do
points(n).x=IntRange(20,512-20)
points(n).y=IntRange(50,512-20)
Loop Until closest(points(),points(n),1)>50
Next n
End Sub

sub drawLine()
dim as integer mx,my,mb,ox,oy,x1,y1,x2,y2
locate 1,1
print "CLICK EACH POINT IN TURN UNTIL ALL POINTS JOINED"
print "CLICK RIGHT MOUSE BUTTON WHEN DONE"
'wait for first mouse click
getmouse mx,my,,mb
while mb <> 1
getmouse mx,my,,mb
sleep 2
wend
circle (x1,y1),5,6,,,,f

x1 = mx
y1 = my
ox = x1
oy = y1

'get other points until right button click
while mb<>2

getmouse mx,my,,mb

if mb = 1 then
x2 = mx
y2 = my
line (x1,y1)-(x2,y2),12
dd = dd + Sqr((x1-x2)^2 +(y1-y2)^2)
circle (x1,y1),5,14,,,,f
x1 = x2
y1 = y2
end if

sleep 2
wend

end sub

Function main() As Long
Windowtitle "SPACE TO REFRESH, ESCAPE TO END"
Do
d=1000000
Line(512,0)-(512,768)
Redim As pt pts(1 To intrange(7,10)),copy(1 To Ubound(pts)),o(1 To Ubound(pts)),oo()
setup(pts())
For n As Long=1 To Ubound(pts)
copy(n)=pts(n)
Next
Var t=Timer
show(pts())

circulate(pts())
bestneighbours(pts() ,copy() ,oo())

drawLine()

'show(oo(),1)

Print "Distance round ";distanceround(oo())
Print "Nearest neighbour optimized method"
Print "time taken ";Timer-t

Dim As String s=getstring(copy())
t=Timer
'show(copy(),,Type(512,0))
Redim As String p()
permutate(s,p())

For n As Long=Lbound(p) To Ubound(p)
distances(copy(),p(n),o())
Next

show(o(),1,Type(512,0))
Locate 1,66
Print "Distance round ";distanceround(o())
Locate 2,66
Print "Permutations  method"
Locate 3,66
Print "time taken ";Timer-t
Locate 4,66
print "Distance Manual ";dd
dd = 0
Sleep
Cls
Loop Until Inkey=Chr(27)
Return 0
End Function
Randomize 2
End main
``````
dodicat
Posts: 7993
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: The Travelling Salesman Problem

That's really neat basiccoder2.
I get quite a few correct.