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.caseih wrote: ↑Mar 09, 2024 1:58Yes that's the first I've heard of it being applied to a person's daily life who wasn't a salesman. haha.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.
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.
The Travelling Salesman Problem
Re: The Travelling Salesman Problem
-
- Posts: 3917
- Joined: Jan 01, 2009 7:03
- Location: Australia
Re: The Travelling Salesman Problem
@dodicat
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.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.
-
- 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.
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.
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))))
Return total
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
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.
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))))
Return total
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
-
- 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.
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))))
Return total
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
Re: The Travelling Salesman Problem
That's really neat basiccoder2.
I get quite a few correct.
I get quite a few correct.