Arrays in VBScript sehr schnell sortieren - Mischsort von 1985

Option Explicit 

' Mischsort-Algorithmus 

' ===================== 

' 

' Original: Zeitschrift "64er" Ausgabe 9/1985, Seite 126/127 

' Originalautor: Horst Armin Kosog 

' 

' C64-Originalprogramm (optisch aufgebessert): 

'1000 DIM A$(6):A=6 

'1010 A$(1)="TEST" 

'1020 A$(2)="TEST2" 

'1030 A$(3)="NOCHEINS" 

'1040 A$(4)="EINELEMENT" 

'1050 A$(5)="NOCHEINELEMENT" 

'1060 A$(6)="LETZTES ELEMENT" 

'10050 ZF=INT(A/2+.5) 

'10052 DIM TV$(ZF) 

'10059 REM 

'10060 FOR X=2 TO A STEP 2 

'10070    IF A$(X-1)>A$(X) THEN TV$(0)=A$(X-1):A$(X-1)=A$(X):A$(X)=TV$(0) 

'10080 NEXT X 

'10082 IF A<3 THEN 50000 

'10090 LF=1 

'10092 FOR MZ=1 TO INT(LOG(A-1)/LOG(2)) 

'10100    ZF=INT(ZF/2+.5) 

'10101    LF=2*LF 

'10110    FOR FZ=1 TO ZF 

'10112       A1=1+2*LF*(FZ-1) 

'10114       A2=A1+LF 

'10116       E1=A2-1 

'10118       E2=E1+LF 

'10120       IF E2<=A THEN ET=LF:GOTO 10150 

'10130       IF A<A2 THEN 10230 

'10140       E2=A 

'10142       ET=A+1-A2 

'10150       FOR X=1 TO ET:TV$(X)=A$(X+E1):NEXT 

'10160       FOR X=E2 TO A1 STEP -1 

'10170          IF A$(E1)<TV$(ET) THEN 10200 

'10180          A$(X)=A$(E1) 

'10182          E1=E1-1 

'10184          IF E1>=A1 THEN 10220 

'10190          FOR Y=X-1 TO A1 STEP -1 

'10192             A$(Y)=TV$(ET) 

'10194             ET=ET-1 

'10196          NEXT Y 

'10198          GOTO 10210 

'10200          A$(X)=TV$(ET) 

'10202          ET=ET-1 

'10204          IF ET>=1 THEN 10220 

'10210          X=A1 

'10220       NEXT X 

'10230    NEXT FZ 

'10240 NEXT MZ 

'50000 FOR I=1 TO 6:PRINT A$(I):NEXT I 

' 

' 

' ------------------------------------ 

' VBS-Variante 

' ------------------------------------ 

' Autor: Christian Coppes 

' Version: 1.0 

' Letzte Änderung: 29.11.2007 

' 

' Die Sortierroutine sortiert extrem schnell auch große Stringmengen. 

' Kleiner Wermutstropfen: Das Stringarray muß mit Index 1 beginnen. 

Const Anz=10 

Dim I,strSort(), strAnzeige, strElement 

ReDim strSort(Anz) 

strSort(1)="Test" 

strSort(2)="Test2" 

strSort(3)="Nocheins" 

strSort(4)="EinElement" 

strSort(5)="Noch ein Element" 

strSort(6)="Letztes Element" 

strSort(7)="Doch nicht1" 

strSort(8)="2Doch nicht" 

strSort(9)="3Nicht doch" 

strSort(10)="Mal sehen, was geht" 

'strSort(1)="6" 

'strSort(2)="4" 

'strSort(3)="1" 

'strSort(4)="3" 

'strSort(5)="9" 

'strSort(6)="5" 

'strSort(7)="8" 

'strSort(8)="7" 

'strSort(9)="0" 

'strSort(10)="2" 

For I = 1 To Anz 

	strAnzeige=strAnzeige+strSort(I)+vbCr 

Next 

MsgBox strAnzeige 

Mischsort strSort 

strAnzeige="" 

For I = 1 To Anz 

	strAnzeige=strAnzeige+strSort(I)+vbCr 

Next 

MsgBox strAnzeige 

WScript.Quit 

Function Mischsort(strArr) 

	Dim A,intTeilfeldAnzahl,X, intLaufendeFeldlaenge, intMischzaehler, intTeilfeldZaehler 

	Dim A1, A2, E1, E2, ET, Y 

	Dim ZF, LF, MZ, FZ, NextX 

	Dim strTempArr() 

	A=UBound(strArr) 

	ZF=Int(A/2+0.5) 

	ReDim strTempArr(ZF) 

	For X=2 To A Step 2 

		If strArr(X-1)>strArr(X) Then 

			strTempArr(0)=strArr(X-1) 

			strArr(X-1)=strArr(X) 

			strArr(X)=strTempArr(0) 

		End If 

	Next 'X 

	If A<3 Then WScript.Quit 

	LF=1 

	For MZ=1 To Int(Log(A-1)/Log(2)) 

		ZF=Int(ZF/2+0.5) 

		LF=2*LF 

		For FZ=1 To ZF 

			A1=1+2*LF*(FZ-1) 

			A2=A1+LF 

			E1=A2-1 

			E2=E1+LF 

			If E2<=A Then 

				ET=LF 

			Else 

				If Not(A<A2) Then 

					E2=A 

					ET=A+1-A2 

				End If 

			End If 

			If (E2<=A) Or (Not(A<A2)) Then 

				For X=1 To ET 

					strTempArr(X)=strArr(X+E1) 

				Next 

				For X=E2 To A1 Step -1 

					NextX=0 

					If strArr(E1)<strTempArr(ET) Then 

						NextX=1 ' Flag setzen, um "GOTO 10220" zu emulieren 

						strArr(X)=strTempArr(ET) 

						ET=ET-1 

						If Not(ET>=1) Then 

							X=A1 

						End If 

					End If 

					If NextX=0 Then 

						strArr(X)=strArr(E1) 

						E1=E1-1 

						If Not(E1>=A1) Then 

							For Y=X-1 To A1 Step -1 

								strArr(Y)=strTempArr(ET) 

								ET=ET-1 

							Next 'Y 

							X=A1 

						End If 

					End If 

				Next 'X 

			End If '(E2<=A) Or (Not(A<A2)) 

		Next 'FZ 

	Next 'MZ 

End Function