Code: Select all
'#cmdline "-exx"
#define intrange(f,l) Int(Rnd*(((l)+1)-(f))+(f))
Dim As String vn(0 To ...) ={"Lockwood Village","Little Hinton","New Malia","Rose Hills","Katoka Village","Lemzilville","Elderville","Brushwind Village","Old Town Sycamore","Azalea Village","Kraniya Town","Tancarville","Taffir Town","Old Evergreen","Zyron Village","The Valley","Apolline Village","Yellow Garden Village","Gentle Mornings","Stoneykirk Village","Old Town Kiko","Taziz Town","Great Oaks Village","Old Lucia","Tryxon Village","Kharthas Village","Lady Krea Village","Wahftar Town","Frandlyn Village","Grytt Village","Quinn Village","Old Pyro","Old Town Desberg","Bird Valley","Plum Paradise","Blurg Village","New Chestnut","Saeville","Great Xendos","Tryx Town","Hirtas Villas","New Grasslands","Diamond Village","Marys Town","Auburn Village","Port Gendar","Peach Pink Village","Waehr Village","Old Town Joviz","Gale Town"}
Type pt
As Integer x,y
As String cap
End Type
Redim Shared As pt c()
Function ShortSpline(p() As pt,t As Single) As pt
#macro set(n)
0.5 *( (2 * P(2).n) +_
(-1*P(1).n + P(3).n) * t +_
(2*P(1).n - 5*P(2).n + 4*P(3).n - P(4).n) * t*t +_
(-1*P(1).n + 3*P(2).n- 3*P(3).n + P(4).n) * t*t*t)
#endmacro
Dim As pt G
G.x=set(x):G.y=set(y)':G.z=set(z)
Return g
End Function
Sub GetSpline(v() As pt,outarray() As pt,arraysize As Integer=9000)
Dim As pt p(1 To 4)
Redim outarray(0)
Dim As Single stepsize=(Ubound(v)-1)/(arraysize)
If stepsize>1 Then stepsize=1
For n As Integer=Lbound(v)+1 To Ubound(v)-2
p(1)=v(n-1):p(2)=v(n):p(3)=v(n+1):p(4)=v(n+2)
For t As Single=0 To 1 Step stepsize
Redim Preserve outarray(1 To Ubound(outarray)+1)
outarray(Ubound(outarray))=ShortSpline(p(),t)
Next t
Next n
End Sub
Sub DrawCurve(a() As pt,ydisp As Integer=0,col As Ulong)
Pset(a(Lbound(a)).x,a(Lbound(a)).y+ydisp),col
For z As Integer=Lbound(a)+1 To Ubound(a)
Line-(a(z).x,a(z).y+ydisp),col
Next z
End Sub
Function shortline(fp As pt,p As pt,length As Single) As pt
Dim As Single diffx=p.x-fp.x,diffy=p.y-fp.y
Dim As pt t
t.x=fp.x+length*diffx
t.y=fp.y+length*diffy
Return t
End Function
Function closestdistance Overload(clr() As pt,v As Long) As Long
#define dist(p1,p2) Sqr((p1.x-p2.x)*(p1.x-p2.x) + (p1.y-p2.y)*(p1.y-p2.y))
Dim As Double dt=1e20
For n As Long=Lbound(clr) To Ubound(clr)
If v=n Then Continue For
Var distance=dist(clr(n),clr(v))
If dt> distance Then dt = distance 'catch the distance
Next n
Return dt
End Function
Sub shuffle(a() As String)
#define range(f,l) Int(Rnd*((l+1)-(f))+(f))
For n As Long = Lbound(a) To Ubound(a)-2
Swap a(n), a(range((n+1),Ubound(a)))
Next n
End Sub
Function distance(points() As pt) As Integer
#define length(a,b) ((a.x-b.x)*(a.x-b.x)+(a.y-b.y)*(a.y-b.y))
Dim As Single total,L
For n As Integer=Lbound(points) To Ubound(points)-1
L= length(points(n),points(n+1))
total+=Sqr(L)
Next n
Return total
End Function
Sub show(c() As pt,flag As Integer)
For n As Integer=Lbound(c)+1 To Ubound(c)-1
Var L=Len(c(n).cap)
Draw String(c(n).x-8*L/2,c(n).y+7),c(n).cap,6
Circle(c(n).x,c(n).y),5
Next n
If flag Then
For n As Integer=Lbound(c)+1 To Ubound(c)-1
If n=Lbound(c)+1 Then Circle(c(n).x,c(n).y),5,4,,,,f :Draw String(10,25)," start at village "+c(n).cap
If n=Ubound(c)-1 Then Circle(c(n).x,c(n).y),5,2,,,,f:Draw String(10,35),"finish at village "+c(n).cap
Draw String(c(n).x,c(n).y-14),Str(n)
Next n
Draw String(10,45),"number of visits "+Str(Ubound(c)-1)
End If
End Sub
Sub circulate(p() As pt)
#macro Circlesort()
' bubblesort
For p1 As Long = Lbound(p)+1 To Ubound(p)-1-1
For p2 As Long = p1 + 1 To Ubound(p)-1
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 setup(points() As pt,vn() As String)
Var u=Ubound(points),L=Lbound(points)
For n As Integer=Lbound(points) To Ubound(points)
Do
points(n).x=IntRange(20,1000)
points(n).y=IntRange(50,710)
Loop Until closestdistance(points(),n)>80
Next n
Dim As pt temp(Lbound(points) To Ubound(points))
For n As Long=Lbound(points) To Ubound(points)
temp(n)=points(n)
Next
Redim points(0 To Ubound(points)+1)
For n As Long=Lbound(points) To Ubound(points)
If n>0 And n<Ubound(points) Then points(n)=temp(n)
Next
Var k=shortline(points(2),points(1),1.1)
points(0)=k
k=shortline(points(u-1),points(u),1.1)
points(u+1)=k
For n As Long=Lbound(points) To Ubound(points)
points(n).cap=Ucase(vn(n))
Next
End Sub
Screen 20
Width 1024\8,768\8
Randomize(Timer)
Redim As pt result()
Do
Var num=intrange(6,30)
Redim result(1 To num)
setup(result(),vn()) 'set some random screen points
show(result(),0)
circulate(result())
GetSpline(result(),c())
Print "Press a key (or <esc> to end)"
Sleep
Cls
If Inkey=Chr(27) Then Exit Do
show(result(),1)
Draw String(10,15), "crow fly distance = "& distance(result())
DrawCurve(c(),,2)
Sleep
shuffle(vn())
If Inkey=Chr(27) Then Exit Do
Cls
Loop
