Hab hier was auf meiner Platte gefunden was ich schon ganz vergessen hatte.

Einen (klarerweise fehlgeschlagenen) Versuch, das Problem des Handlungsreisenden (travelling salesman problem) zu lösen.

Das Demoprogramm testet den Algo mit 6 Stationen und hält immer bei einem Fehler an. Bei durchschnittlich 2,5-3% der Fälle liegt er falsch, mit einem Unterschied von 1-2%, seltener bis zu 5%.

Binary: http://share.cherrytree.at/showfile-...sreisender.exe

FB Source:

Code: 
#Define C_MIN Asc("A")
#Define C_MAX Asc("F")

Type PointXY
	x As Integer
	y As Integer
	Declare Constructor (x_ As Integer, y_ As Integer)
	Declare Constructor ()
End Type

Constructor PointXY(x_ As Integer, y_ As Integer)
	x = x_
	y = y_
End Constructor

Constructor PointXY()
	
End Constructor

Dim Shared cost(C_MIN To C_MAX, C_MIN To C_MAX) As Integer
Dim Shared city(C_MIN To C_MAX) As PointXY

Randomize(Timer())

ScreenRes 800, 600, 32

Type Route
	way As String
	price As Integer
	Declare Constructor (w As String, p As Integer)
	Declare Sub Insert(c As Integer)
End Type

Constructor Route(w As String, p As Integer)
	way = w
	price = p
End Constructor

Sub Route.Insert(c As Integer)
	Var best = Route(way, &h7FFFFFFF)
	For i As Integer = 1 To Len(way) - 1
		Var w = Left(way, i) & Chr(c) & Right(way, Len(way) - i)
		Var p = price - cost(way[i - 1], way[i]) + cost(way[i - 1], c) + cost(c, way[i])
		If p < best.price Then best = Route(w, p)
	Next
	This = best
End Sub

Function Calc(s As String) As Integer
	Dim p As Integer = 0
	For i As Integer = 0 To Len(s) - 2
		p += cost(s[i], s[i + 1])
	Next
	Return p
End Function

Sub Rec(s As String = "", best As Route Ptr)
	If Len(s) = C_MAX - C_MIN + 1 Then
		Var s2 = s & Left(s, 1)
		Var p = Calc(s2)
		If p < best->price Then *best = Route(s2, p)
		Exit Sub
	EndIf
	
	Var l = Len(s)
	For i As Integer = C_MIN To C_MAX
		If l = 0 Then Print Chr(i);
		If InStr(s, Chr(i)) = 0 Then Rec(s & Chr(i), best)
	Next
End Sub

Sub DrawRoute(w As String)
	Circle (city(w[0]).x, city(w[0]).y), 5
	For i As Integer = 0 To Len(w) - 2
		Line (city(w[i]).x, city(w[i]).y)-(city(w[i + 1]).x, city(w[i + 1]).y)
	Next
End Sub

Dim done As Integer = 0
Dim wrong As Integer = 0
Do
	done += 1
	
	ScreenLock()
	Cls()
	For i As Integer = C_MIN To C_MAX
		city(i) = PointXY(CInt(Rnd * 800), 200 + CInt(Rnd * 400))
		Circle (city(i).x, city(i).y), 3, RGB(255, 0, 0), , , , F
		Draw String (city(i).x, city(i).y - 12), Chr(i), RGB(255, 255, 255)
	Next
	
	For x As Integer = C_MIN To C_MAX
		For y As Integer = C_MIN To C_MAX
			Line (city(x).x, city(x).y)-(city(y).x, city(y).y), RGB(96, 96, 96)
			cost(x, y) = Sqr((city(y).x - city(x).x) ^ 2 + (city(y).y - city(x).y) ^ 2) * 100
			If x <> y Then Draw String ((city(y).x + city(x).x) / 2 + 4, (city(y).y + city(x).y) / 2 - 4), "" & cost(x, y), RGB(160, 160, 160)
		Next
	Next
	
	Var t = Timer()
	
	Color RGB(255, 255, 0)
	
	Print "USING CHERRY'S ALGORITHM"
	Var best = Route("", &h7FFFFFFF)
	For f As Integer = C_MIN To C_MAX
		Print Chr(f);
		Var r = Route(Chr(f, f), cost(f, f))
		For i As Integer = C_MIN To C_MAX
			If f <> i Then r.Insert(i)
		Next
		If r.price < best.price Then best = r
	Next
	
	Print
	Print "--------------------"
	Print Timer() - t & " sec."
	Print best.way
	Print best.price
	Var oldbest = best.price
	DrawRoute(best.way)
	
	Color RGB(255, 255, 255)
	
	Print "--------------------"
	
	t = Timer()
	
	Color RGB(0, 255, 0)
	
	Print "USING NAIVE ALGORITHM (Try all possible ways, find shortest)"
	best = Route("", &h7FFFFFFF)
	Rec(, @best)
	
	Print
	Print "--------------------"
	Print Timer() - t & " sec."
	Print best.way
	Print best.price
	DrawRoute(best.way)
	
	
	Color RGB(255, 255, 255)
	Print "--------------------"
	Print "" & done & " tries"
	Print "--------------------"
	
	If best.price <> oldbest Then
		wrong += 1
		Color RGB(255, 0, 0)
		Print "FAILED!"
		Print "Diff: " & oldbest - best.price & " (";
		Print Using "##.##"; ((oldbest - best.price) / best.price) * 100;
		Print "%)"
		Print "--------------------"
		Print "" & wrong & " tries wrong (";
		Print Using "##.##"; (wrong / done) * 100;
		Print "%)"
		Print "(Press any key to continue)"
		ScreenUnLock()
		Sleep()
	Else
		ScreenUnLock()
	EndIf
Loop Until InKey() = !"\&hFFk"
mfG Cherry