The Travelling Salesman Problem

[UEZ]

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]

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

Both the circle and nearest town algorithms get pretty good results.

[dodicat]

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

[dodicat]

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

[BasicCoder2]

@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))))
    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
 

[dodicat]

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