Raetsel um/mit Buchstabensalat

[Pelagio]

Hallöchen ,
ich hatte etwas Zeit und da kam mir die Idee einmal wieder etwas zu programmieren.
Über ein Rätsel kam mir daher die Idee einmal zu sehen ob ich es schaffe aus einer Buchstabenfolge ein Wort auszulesen. Nach langer Zeit habe ich es auch geschafft, nicht schön aber es klappt. Das Problem liegt nur in der Zeit bei längeren Wörtern. Wörter bis 7 Buchstaben (5040 Buchstabenvariationen) ist die Zeit noch Akzeptabel aber dann..... Überirdisch. Ich gehe davon aus das es einen besseren, sauberen Source gibt.

Code: Alles auswählen

Global.s gLettern = UCase("aeeilrttz") ;Zeitalter

Procedure.i Fakultaet(vZahl.i)
	Protected pResult.i = vZahl

	For n=(vZahl-1) To 1 Step -1
		pResult * n 
	Next n
	ProcedureReturn pResult 
EndProcedure

Procedure.s Variationen(vLettern.s)
	Protected.b pOK 
	Protected.i n, pSize, pLen = Len(vLettern), pMax = Fakultaet(pLen)
	Protected.s pWord, NewList pLettern(), NewList pWords()

	AddElement(pWords()): pWords() = vLettern
	For n=1 To pLen
		AddElement(pLettern()): pLettern() = Mid(vLettern, n, 1)
	Next n
	Repeat
		pOK = #True
		RandomizeList(pLettern())
		ForEach pLettern(): pWord + pLettern(): Next
		ForEach pWords()
			If (pWords()=pWord): pOK = #Null: Break: EndIf
		Next 
		If pOK
			AddElement(pWords()): pWords() = pWord
			pSize = ListSize(pWords())
		EndIf
		pWord = #Null$
	Until (pSize=>pMax)
;------------------------------------------------
ForEach pWords(): Debug pwords(): Next
Debug ListSize(pWords())
;----------------------------------------------------
EndProcedure

gLettern = "HVRECSUE" ;Versuch
Variationen(gLettern)

End

[STARGÅTE]

Hm, ich glaube das größte Problem ist nicht die Menge an Varianten sondern wie du sie ermittelst. Das ganze zufällig zu machen ist sehr sehr ineffizient, weil du ja gegen Ende meist nur noch Wörter triffst die es schon gibt.

Für sowas gibt es den sogenannten Heap-Algorithmus.
Dieser zeichnet sich durch besonders wenig Vertauschungen aus.

Hier mal eine alter Code von mir:

Code: Alles auswählen

Procedure Permutate(Array Element.s(1), First.i=#False)
	Static Dim Index.i(0)
	Static I.i
	Protected N.i = ArraySize(Element())
	If First
		Dim Index.i(N)
		I = 0
	EndIf
	While I <= N
		If  Index(I) < I
			If I&1 = 0
				If Element(0) <> Element(I)
					Swap Element(0), Element(I)
				Else
					Index(I) + 1
					I = 0
					Continue
				EndIf
			Else
				If Element(Index(I)) <> Element(I)
					Swap Element(Index(I)), Element(I)
				Else
					Index(I) + 1
					I = 0
					Continue
				EndIf
			EndIf
			Index(I) + 1
			I = 0
			ProcedureReturn #True
		Else
			Index(I) = 0
			I + 1
		EndIf
	Wend
	ProcedureReturn #False
EndProcedure

Procedure.s Show(Array Element.s(1))
	Protected I.i, N.i = ArraySize(Element())
	Protected String.s
	For I = 0 To N
		String + Element(I)
	Next
	ProcedureReturn String.s
EndProcedure

Dim Element.s(3)

Define I.i
Element(0) = "A"
Element(1) = "B"
Element(2) = "C"
Element(3) = "D"

Debug Show(Element())
If Permutate(Element(), #True)
	Repeat
		Debug Show(Element())
	Until Permutate(Element()) = #False
EndIf

Wird Permutate() das erste mal aufgerufen, setzt man den Parameter First aus #True, dadurch wird das Zustandsarray zurückgesetzt sodass später aufgerufene Permutate() dann #False zurückgeben, wenn alle Permutationen gefunden wurden.

[Kiffi]

Hier mein Vorschlag mit Hilfe der SQLite-Funktionen:

Code: Alles auswählen

EnableExplicit

DisableDebugger

UseSQLiteDatabase()

Define T1, T2
Define Tables.s, Columns.s, Values.s
Define Counter, Counter2

T1 = ElapsedMilliseconds()

OpenDatabase(0, ":memory:", "", "", #PB_Database_SQLite)

Define Wort.s = "aeeilrttz" ; Zeitalter

For Counter = 0 To Len(Wort) - 1
  
  DatabaseUpdate(0, "CREATE TABLE T" + Counter + "( col )")
  
  For Counter2 = Counter To Len(Wort) - 1
    DatabaseUpdate(0, "INSERT INTO T" + Counter + " ( col ) VALUES ('" + Mid(Wort, Counter2 + 1, 1) + "')")
  Next
  
  Tables  + "T" + Counter
  Columns + "T" + Counter + ".col"
  
  If Counter < Len(Wort) - 1
    Tables  + " Join "
    Columns + " || "
  EndIf
  
Next

NewList Variationen.s()

If DatabaseQuery(0, "SELECT " + Columns + " FROM " + Tables)
  
  While NextDatabaseRow(0)
    AddElement(Variationen()) : Variationen() = GetDatabaseString(0, 0)
  Wend
  
  FinishDatabaseQuery(0)
  
Else
  
  Debug DatabaseError()
  
EndIf

CloseDatabase(0)

T2 = ElapsedMilliseconds()

MessageRequester( "", Str(ListSize(Variationen())) + " Variationen in " + Str(T2-T1) + " msecs")

; ForEach Variationen()
;   Debug Variationen()
; Next

Dürfte auch ausreichend schnell sein. Bei mir werden aus 'Zeitalter' 362880 Variationen in 181 msecs generiert.

[Pelagio]

Danke für Eure schnellen Vorschläge,
von STARGÅTE der Vorschlag muss ich erst noch, wenn wieder Zeit ist, genau Analysieren,
scheint doch etwas schwieriger zu sein bei Der Eingabemöglichkeit von unterschiedlichen Wortlängen.
Kiffi, bei Dir habe ich das Problem das ich zwar schnell viele Variationen ermittle aber leider Variationen die ich nicht wollte und die, die ich bräuchte ist nicht dabei. Ich habe einmal mit einem etwas kleineren Wort ("ETST" = TEST) probiert und dies Ergebnis, ohne TEST, bekommen:

ETST,ETTT,ESST,ESTT,ETST,ETTT,TTST,TTTT,TSST,TSTT,TTST,TTTT,STST,STTT,SSST,SSTT,STST,STTT,TTST,TTTT,TSST,TSTT,TTST,TTTT

Das was ich wollte sehe ca. so aus:

ETST,ESTT,ETTS,STET,STTE,SETT,TTES,TETS,TSET,TEST,TSTE,TETS

Ich wünsche noch eine Gute Nacht