PutWord und PutLong haben bereits einen zusätzlichen Parameter, der hier den Wert automatisch dreht.
Da muss also nichts gedreht werden.
Mein Wunsch nach den Quadints beinhaltet auch da den Schalter.
Das muss also nicht beachtet werden.
PutWord und PutLong haben bereits einen zusätzlichen Parameter, der hier den Wert automatisch dreht.
Da muss also nichts gedreht werden.
Mein Wunsch nach den Quadints beinhaltet auch da den Schalter.
Das muss also nicht beachtet werden.
Abt. RotateLeft, RotateRight
=====================
Shiftbefehle existieren in XProfan, Rotate-Befehle nicht. Das ändern wir jetzt, zumindest was Rotation ohne Einbeziehung eines zusätzlichen Carry-bits betrifft: Die Rotationsweite ist von 1 bis 31 einstellbar (sinnvoll jeweils nur bis max. 15, darüber hinaus sollte man einfach die Rotationsrichtung ändern). Auch die Bitbreite der Rotation ist zwischen 32 bit bis 2 bit herunter einstellbar. Könnte ganz nützlich werden, bei SHA-256 z.B.
Gruss
cls:font 2
var x&=%00100111
var n&= 1 '[1..31]
var w&=32 '[2..32]
var nu$="00"
proc RotL :parameters x&,n&,w&
return (x&<<n&) | (x&>>(w&-n&))
endproc
proc RotR :parameters x&,n&,w&
return (x&>>n&) | (x&<<(w&-n&))
endproc
nu$=mkstr$("0",w&)
while 1
locate 2,2
print right$(nu$+bin$(x&),w&)
sound 300,30
waitinput 1000
x&=RotL(x&,n&,w&)
wend
Alles anzeigen
Abt. RotateWide über 2 x 32 bit
=======================
XProfan-11 kennt noch keine QuadInt, aber manchmal kann man sich mit 2 einfachen Int behelfen.
Gruss
cls:font 2
declare x&,y&,a&,b&,c&,d&,w&,n&,nu$
w&=32 '2..32
nu$=mkstr$("0",w&)
n&=1
x&=%10101001100011100001111
repeat
locate 2,2
print translate$(right$(nu$+bin$(y&),w&)+":"+right$(nu$+bin$(x&),w&),"0","°")
waitinput 400
ROTLw
until 0
Proc ROTRw
a&=x&>>n&
b&=x&<<(w&-n&)
c&=y&>>n&
d&=y&<<(w&-n&)
x& = a& | d&
y& = b& | c&
endproc
Proc ROTLw
a&=x&<<n&
b&=x&>>(w&-n&)
c&=y&<<n&
d&=y&>>(w&-n&)
x& = a& | d&
y& = b& | c&
endproc
Alles anzeigen
P.S.: Das geht sicher eleganter und schneller, aber als Demo reicht es
Abt. Langsam wird es lächerlich
=======================
Nochmal im Kreis rotieren lassen, diesmal über 3 DWords. Braucht garantiert keiner...
Window 0,0-%maxx,100
font 2
declare x&,y&,z&,a&,b&,c&,d&,e&,f&,w&,n&,nu$
w&=32 '2..32
nu$=mkstr$("0",w&)
n&=1
x&=%10101001100011100001111
repeat
locate 2,2
print translate$(\
right$(nu$+bin$(z&),w&)+"."+\
right$(nu$+bin$(y&),w&)+"."+\
right$(nu$+bin$(x&),w&)\
,"0","°")
waitinput 20
ROTLw
until 0
Proc ROTRw
a&=x&>>n&
b&=x&<<(w&-n&)
c&=y&>>n&
d&=y&<<(w&-n&)
e&=z&>>n&
f&=z&<<(w&-n&)
x& = a& | d&
y& = c& | f&
z& = e& | b&
endproc
Proc ROTLw
a&=x&<<n&
b&=x&>>(w&-n&)
c&=y&<<n&
d&=y&>>(w&-n&)
e&=z&<<n&
f&=z&>>(w&-n&)
x& = a& | f&
y& = c& | b&
z& = e& | d&
endproc
Alles anzeigen
Abt. O.K.: Absolut lächerlich - Rot4Wide
==============================
Ich versuche, langsam an ein Schema für x DoubleWords zu kommen. Macht Spaß ... Das hier simuliert wenigstens zwei Quadwords. SHA-512 bräuchte dann so etwas ...
Window 0,0-%maxx,100
font 2
declare x&,y&,z&,u&, a&,b&,c&,d&,e&,f&,g&,h&, w&,n&,nu$
w&=32 '2..32
nu$=mkstr$("0",w&)
n&=1
x&=%10101001100011100001111
repeat
locate 2,2
print translate$(\
right$(nu$+bin$(u&),w&)+"."+\
right$(nu$+bin$(z&),w&)+"."+\
right$(nu$+bin$(y&),w&)+"."+\
right$(nu$+bin$(x&),w&)\
,"0","°")
waitinput 20
ROTLw
until 0
Proc ROTRw
a&=x&>>n&
b&=x&<<(w&-n&)
c&=y&>>n&
d&=y&<<(w&-n&)
e&=z&>>n&
f&=z&<<(w&-n&)
g&=u&>>n&
h&=u&<<(W&-n&)
x& = a& | d&
y& = c& | f&
z& = e& | h&
u& = g& | b&
endproc
Proc ROTLw
a&=x&<<n&
b&=x&>>(w&-n&)
c&=y&<<n&
d&=y&>>(w&-n&)
e&=z&<<n&
f&=z&>>(w&-n&)
g&=u&<<n&
h&=u&>>(W&-n&)
x& = a& | h&
y& = c& | b&
z& = e& | d&
u& = g& | f&
endproc
Alles anzeigen
Abt. Auch schon egal: Rot5Wide
========================
Rotation links/rechts über 5 DWords; langsam wird das Schema klar. Hat Ähnlichkeit mit Eisenbahn spielen
Sorry, penlich ... Vielleicht eines Tags als Fixtabulator-Leiste nützlich?
Window 0,0-%maxx,100:font 2
declare x&,y&,z&,u&,v&, a&,b&,c&,d&,e&,f&,g&,h&,i&,j&, w&,n&,nu$
w&=32 '1..32 Genutzte Breite der DWords
n&=1 'Rotationsweite
x&=%10101001100011100001111 'x,y,z,u,v: Binäres Muster
v&=%1
nu$=mkstr$("0",w&)
Repeat :locate 2,1:print translate$(\
right$(nu$+bin$(v&),w&)+"."+right$(nu$+bin$(u&),w&)+"."+\
right$(nu$+bin$(z&),w&)+"."+right$(nu$+bin$(y&),w&)+"."+\
right$(nu$+bin$(x&),w&)\
,"0","°"):waitinput 22
if 1 : ROTLw :else :ROTRw :endif
until 0
Proc ROTRw
a&=x&>>n&:b&=x&<<(w&-n&)
c&=y&>>n&:d&=y&<<(w&-n&):x&=a& | d&
e&=z&>>n&:f&=z&<<(w&-n&):y&=c& | f&
g&=u&>>n&:h&=u&<<(w&-n&):z&=e& | h&
i&=v&>>n&:j&=v&<<(w&-n&):u&=g& | j&
v&=i& | b&
endproc
Proc ROTLw
i&=v&<<n&:j&=v&>>(w&-n&)
g&=u&<<n&:h&=u&>>(W&-n&):v&=i& | h&
e&=z&<<n&:f&=z&>>(w&-n&):u&=g& | f&
c&=y&<<n&:d&=y&>>(w&-n&):z&=e& | d&
a&=x&<<n&:b&=x&>>(w&-n&):y&=c& | b&
x&=a& | j&
endproc
Alles anzeigen
Abt. Das selbe, aber eleganter
-----------------------------
WindowTitle "WideBitROTATE-Schema"
Window 0,0-%maxx,100:font 0
declare x&,y&,z&,u&,v&, w&,n&,nu$,toLeft&
w&=32 '1..32 Genutzte Breite der DWords
n&=1 'Rotationsweite (max. 31)
toLeft&=0
x&=%10101001100011100001111 'x,y,z,u,v: Binäres Muster
v&=%1
nu$=mkstr$("0",w&)
Repeat :locate 2,1:print translate$(\
right$(nu$+bin$(v&),w&)+right$(nu$+bin$(u&),w&)+\
right$(nu$+bin$(z&),w&)+right$(nu$+bin$(y&),w&)+\
right$(nu$+bin$(x&),w&)\
,"0","°"):waitinput 21
if toLeft& : ROTLw :else :ROTRw :endif
until 0
Proc ROTLw
var q&=w&-n&
var tmp&=v&>>q&
v&=v&<<n& | u&>>q&
u&=u&<<n& | z&>>q&
z&=z&<<n& | y&>>q&
y&=y&<<n& | x&>>q&
x&=x&<<n& | tmp&
endproc
Proc ROTRw
var q&=w&-n&
var tmp&=x&<<q&
x&=x&>>n& | y&<<q&
y&=y&>>n& | z&<<q&
z&=z&>>n& | u&<<q&
u&=u&>>n& | v&<<q&
v&=v&>>n& | tmp&
endproc
Alles anzeigen
Abt. BITROTATOR, flexibel für Arrays von z.B. 10 DWords à jeweils 29 genutze Bit
------------------------------------------------------------------------------
Gruss
WindowTitle "xDWordsArray-BITROTATOR"
WindowStyle 24:Window 0,0-%maxx,80:font 2
Declare w&,n&,nu$,toLeft&
var DWordanz& = 10
declare x&[DWordanz&-1]
w&=29 '1..32 Genutzte Breite der DWords
n&=2 'Rotationsweite (max. 31)
toLeft&=0
x&[0]=%10101001100011100001111 'x&[]: Binäres Muster
x&[sizeof(x&[])-1]=%1
nu$=mkstr$("0",w&)
Repeat
locate 2,1
Whileloop sizeof(x&[])-1,0,-1
print translate$(right$(nu$+bin$( x&[&loop] ),w&),"0","°")+":";
endwhile:waitinput 21
if toLeft& : ROTLw x&[],n&,w&:else :ROTRw x&[],n&,w&:endif
until 0
Proc ROTLw :parameters x&[],n&,w&
var q&=w&-n&:var s&=sizeof(x&[])-1
var tmp&=x&[s&]>>q&:whileloop s&,1,-1
x&[&loop]=x&[&loop]<<n& | x&[&Loop-1]>>q&
endwhile:x&[0]=x&[0]<<n& | tmp&
endproc
Proc ROTRw :parameters x&[],n&,w&
var q&=w&-n&:var s&=sizeof(x&[])-1
var tmp&=x&[0]<<q&:whileloop 0,s&-1
x&[&Loop]=x&[&Loop]>>n& | x&[&Loop+1]<<q&
endwhile:x&[s&]=x&[s&]>>n& | tmp&
endproc
Alles anzeigen
Abt. INTEGERSTRINGS MULTIPLIZIEREN
=============================
Aus der Nostalgielade - und damals schon abgelegt unter "Vintage Computing" - stammt das folgende Machwerk, das wir irgendwann für kryptographische Zwecke und das geplante SHA-256 brauchen werden.
Gruss
WINDOWTITLE "VINTAGE COMPUTING: I N T E G E R "+\
"- S T R I N G S M U L T I P L I C A T I O N"
'(CL) 2018-05 TO XPROFAN-11 BY P.SPECHT, WIEN. KEINE GEWÄHR!
'http://www.rosettacode.org/wiki/long_multiplication#applesoft_basic
WINDOWSTYLE 24:CLS:FONT 2:DECLARE A$,B$,E$
REPEAT
A$="":B$=""
PRINT "\n MULTIPLIKAND A$ = ";:INPUT A$
:IF A$="":CLS:CONTINUE:ENDIF ' "18446744073709551616"
PRINT " MULTIPLIKATOR B$ = ";:INPUT B$:CASE B$="":B$=A$
PRINT " PRODUKT E$ = ";
CLEARCLIP
MULTIPLY_A$XB$
PUTCLIP E$+"\n"
PRINT E$:SOUND 4000,25:PRINT " ==> ZW.-ABLAGE\n"
E$="":WAITINPUT 1000
UNTIL %KEY=27
END
PROC MULTIPLY_A$XB$
DECLARE C&,B&,C$,D$,I&,J&,V& : C$="":D$="0"
WHILELOOP LEN(B$),1,-1:I&=&LOOP
C&=0:B&=VAL(MID$(B$,I&,1))
WHILELOOP LEN(A$),1,-1:J&=&LOOP
V&=B&*VAL(MID$(A$,J&,1))+C&
C&=INT(V&/10):V&=V&-C&*10
C$=STR$(V&)+C$
ENDWHILE
CASE C&:C$=STR$(C&)+C$
ADD_C$_D$
D$=E$:C$="0":J&=LEN(B$)-I&
:WHILE J&:DEC J&:C$=C$+"0":ENDWHILE
ENDWHILE
ENDPROC
PROC ADD_C$_D$
DECLARE E&,V&,D&
E&=LEN(D$):E$="":C&=0
WHILELOOP LEN(C$),1,-1:J&=&LOOP
CASE E&:D&=VAL(MID$(D$,E&,1))
V&=VAL(MID$(C$,J&,1))+D&+C&
C&=(V&>9):V&=V&-10*C&
E$=STR$(V&)+E$
:IF E&:DEC E&:D&=0:ENDIF
ENDWHILE
WHILE E&
V&=VAL(MID$(D$,E&,1))+C&:C&=(V&>9)
V&=V&-10*C&:E$=STR$(V&)+E$:DEC E&
ENDWHILE
ENDPROC
Alles anzeigen
Abt. Kombinationen, aber rekursiv
=========================
Aus N Elementen werden m verschiedene ausgewählt und ohne Beachtung der Reihenfolge (als Menge) angezeigt. Erscheint mir kurz, bündig und elegant, obwohl Rekursion an sich keine Stärke von XProfan ist.
Gruss
Windowtitle "Kombinationen rekursiv":cls
'Q: http://www.rosettacode.org/wiki/Combinations#Pascal
'Von n Elementen jeweils m zusammenstellen:
var n_max& = 10:var m_max& = 9
declare anz&,combination&[m_max&]:generate(1):print "(";Anz&;")":waitinput:end
proc generate :parameters m&:declare n&,i&
if m&>m_max&:whileloop m_max&:Print combination&[&loop],:endwhile:print:inc anz&
else:whileloop n_max&:if (m& = 1) or (&Loop > combination&[m&-1])
combination&[m&]=&Loop:generate(m&+1):endif:endwhile:endif
endproc
Abt. Schon wieder Rätsel - SwR 6: Der AMB-Operator
---------------------------------------------------
Aufgabe: Schreibe ein Programm "AMB-Operator", das aus allen 4 vorgebenen Wortgruppen
1. "the" "that" "a"
2. "frog" "elephant" "thing"
3. "walked" "treaded" "grows"
4. "slowly" "quickly"
jeweils ein Wort so wählt, dass sein Endbuchstabe dem Anfangsbuchstaben des Wortes der nächsten Gruppe entspricht (und halbwegs vernünftige englische Sätze dabei herauskommen).
P.S.: treaded = er schritt, er trottete ...
Meine Lösung anbei... Rekursiv wäre aber elganter. Wer mag?
Windowtitle "AMB Operator":CLS:font 2
declare w1$[3],w2$[3],w3$[3],w4$[2],i&,j&,k&,l&
w1$[1]="the":w1$[2]="that":w1$[3]="a"
w2$[1]="frog":w2$[2]="elephant":w2$[3]="thing"
w3$[1]="walked":w3$[2]="treaded":w3$[3]="grows"
w4$[1]="slowly":w4$[2]="quickly"
Whileloop 3:i&=&Loop
Whileloop 3:j&=&Loop
if right$(w1$[i&],1)=left$(w2$[j&],1)
Whileloop 3:k&=&Loop
if right$(w2$[j&],1)=left$(w3$[k&],1)
Whileloop 2:l&=&Loop
if right$(w3$[k&],1)=left$(w4$[l&],1)
print "\n ",w1$[i&],w2$[j&],w3$[k&],w4$[l&]
endif
Endwhile
endif
Endwhile
endif
Endwhile
Endwhile
print "\n OK":beep:Waitinput
End
Alles anzeigen
Abt. Schon wieder Rätsel - SwR 7
-----------------------------------
Statt der Buchstaben sind Ziffern zu finden, die die genannte Summe MONEY ergeben:
_ SEND
+MORE
-------
MONEY
P.S.: Das _ ist nur zum Einrücken gedacht
Lösung mit Brute force anbei, dauert aber 6 Minuten - pfui, wie unelegant!
Wer hat einen eher kriminologischen Ansatz?
Windowtitle "SwR 7: SEND + MORE = MONEY"
cls:font 2
declare s&,e&,n&,d&,m&,o&,r&,y&
whileloop 1,9:s&=&Loop
:whileloop 0,9:e&=&Loop
case e&=s&:continue
:whileloop 0,9:n&=&Loop:print ".";
case (n&=e&) or (n&=s&):continue
:whileloop 0,9:d&=&Loop
case (d&=n&) or (d&=e&) or (d&=s&):continue
:whileloop 1,9:m&=&Loop
case (m&=d&) or (m&=n&) or (m&=e&) or (m&=s&):continue
:whileloop 0,9:o&=&Loop
case (o&=m&) or (o&=d&) or (o&=n&) or (o&=e&) or (o&=s&):continue
:whileloop 0,9:r&=&Loop
case (r&=o&) or (r&=m&) or (r&=d&) or (r&=n&) or (r&=e&) or (r&=s&):continue
:whileloop 0,9:y&=&Loop
case (y&=r&) or (y&=o&) or (y&=m&) or (y&=d&) or (y&=n&) or (m&=e&) or (m&=s&):continue
'print s&,e&,n&,d&,m&,o&,r&,y&
'if val(str$(s&)+str$(e&)+str$(n&)+str$(d&))\
' +val(str$(m&)+str$(o&)+str$(r&)+str$(e&))\
'=val(str$(m&)+str$(o&)+str$(n&)+str$(e&)+str$(y&))
if (1000*s&+100*e&+10*n&+d& +1000*m&+100*o&+10*r&+e&)=(10000*m&+1000*o&+100*n&+10*e&+y&)
print "\n ",s&,e&,n&,d&
print "+",m&,o&,r&,e&
print "---------------------------"
print m&,o&,n&,e&,y&
sound 4000,40:waitinput 5000
endif
endwhile:endwhile:endwhile:endwhile:endwhile:endwhile:endwhile:endwhile
beep
Print "\n ENDE"
waitinput 'Lösung: 9567+1085=10652
end
Alles anzeigen
Abt. Benchmark "Optimierter LR-Bubblesort" vs QuickSort (2000 Strings)
===============================================
Und dabei hieß es "In einigen Situationen ähnlich schnell"
WindowTitle "Optimierter LinksRechts-Bubblesort versus Quicksort"
Window 0,0-%maxx,%maxy-40
declare tm&,w$,a$[],b$[],l&,r&,i&,j&
var n&=2000
print "\n Setup von",n&," alphanumerischen Zufalls-Strings läuft ..."
print " Beispiele:\n"
Whileloop 0,n&-1:i&=&Loop
w$="":whileloop 1+Rnd(60):w$=w$+chr$(65+rnd(57))
endwhile:a$[i&]=w$
case rnd(333)=0
print tab(10-len(str$(int(i&))));i&,tab(12);a$[i&]
endwhile
b$[]=a$[]
print "\n\n LRBubblesort läuft ..."
tm&=&GetTickCount
l&=0:r&=sizeof(a$[])-1
LRBubblesort a$[],l&,r&
tm&=&GetTickCount-tm&
CLS:print "\n Sortiert in",tm&,"ms":sound 100,100
waitinput 5000
Whileloop 0,r&:i&=&Loop
print tab(10-len(str$(int(i&))));i&,tab(12);a$[i&]
if i&:if a$[i&]<a$[i&-1]:print "ALARM: ERROR!!!!!!!!!!!!!":sound 2000,200:waitinput:end:endif:endif
if %csrlin>48:waitinput 1700:cls:print:endif
endwhile
beep
waitinput
CLS
print "\n\n QuicksortUp läuft ..."
tm&=&GetTickCount
l&=0:r&=sizeof(a$[])-1
QuickSortUpDwn10c(b$[],1)
tm&=&GetTickCount-tm&
CLS:print "\n Sortiert in",tm&,"ms":sound 100,100
waitinput 5000
Whileloop 0,r&:i&=&Loop
print tab(10-len(str$(int(i&))));i&,tab(12);b$[i&]
if i&:if b$[i&]<b$[i&-1]:print "ALARM: ERROR!!!!!!!!!!!!!":sound 2000,200:waitinput:end:endif:endif
if %csrlin>48:waitinput 1700:cls:print:endif
endwhile
beep
waitinput
end
proc LRBubblesort :parameters a$[],l&,r&:declare x$,f$:var m&=r&:var i&=l&
:while i&<m&:x$=a$[i&]:f$=a$[m&]:if x$>f$:a$[m&]=x$:a$[i&]=f$:endif:inc i&:dec m&:endwhile
:while l&<r&:x$=a$[l&]:m&=l&-1:i&=l&+1
:while i&<=r&:f$=a$[i&]:if x$<=f$:x$=f$:else :a$[i&]=x$:m&=i&-1:a$[m&]=f$:endif:inc i&:endwhile
dec r&:if r&>m&:if l&<m&:r&=m&:else :r&=l&:endif:endif
x$=a$[r&]:m&=r&+1:i&=r&-1
:while i&>=l&:f$=a$[i&]:if x$>=f$:x$=f$:else :a$[i&]=x$:m&=i&+1:a$[m&]=f$:endif:dec i&:endwhile
inc l&:if l&<m&:if r&>m&:l&=m&:else :l&=r&::endif:endif
endwhile
endproc
proc QuickSortUpDwn10c :parameters a$[],desc&:declare n&,p&,l&,r&,s&,sl&[],sr&[],w$
' desc&=0 or 1: Sort Ascending a 0-based Array; desc& = -1: Sort descending a 0-based Array;
' desc&= 2 : Sort Ascending with Indexbase =1; desc& = -2: Sort descending 1-based.
declare x$,i&,j&:n&=sizeof(a$[]):s&=1:sl&[1]=(abs(desc&)=2):sr&[1]=n&-(abs(desc&)<>2)
:while s&>0:l&=sl&[s&]:r&=sr&[s&]:s&=s&-1:while l&<r&:i&=l&:j&=r&:p&=(l&+r&)\2
if a$[l&]>a$[p&]:w$=a$[l&]:a$[l&]=a$[p&]:a$[p&]=w$:endif
if a$[l&]>a$[r&]:w$=a$[l&]:a$[l&]=a$[r&]:a$[r&]=w$:endif
if a$[p&]>a$[r&]:w$=a$[p&]:a$[p&]=a$[r&]:a$[r&]=w$: endif :x$=a$[p&]
:while i&<=j&:if desc&<0:while a$[i&]>x$:inc i&:endwhile :while x$>a$[j&]:dec j&
endwhile :else :while a$[i&]<x$:inc i&:endwhile :while x$<a$[j&]:dec j&:endwhile
endif :if i&<=j&:w$=a$[i&]:a$[i&]=a$[j&]:a$[j&]=w$:i&=i&+1:j&=j&-1:endif:endwhile
if (j&-l&)<(r&-i&):if i&<r&:s&=s&+1:sl&[s&]=i&:sr&[s&]=r&:endif :r&=j&:else
if l&<j&:s&=s&+1:sl&[s&]=l&:sr&[s&]=j&:endif :l&=i&:endif :endwhile :endwhile
endproc
Alles anzeigen
Abt. Auch nicht schneller ...
===================
Immer wieder gab und gibt es Versuche, einen Sortieralgorithmus schneller als Quicksort zu finden. Bucketsort und seine Verwandten kamen diesem Ziel deshalb nahe, weil spezielle Datenkonfigurationen vom Programm erkannt werden und dann - je grob vorsortierter Werteklasse (= "Bucket", Behälter) - der dafür jeweils geeignetste Algorithmus eingesetzt wird. Leider sorgt der Verwaltungs-Overhead dann oft wieder für Ernüchterung, m.E. auch bei einem Verwandten dieser Algorithmenklasse, dem urheberrechtlich geschützten ´FlashSort´, der Permutationen nutzt und hier als reine Demo für private Zwecke dargestellt wird.
Gruss
WindowTitle "Studie: FlashSort Algorithm (c) by Karl-Dietrich Neubert"
' FlashSort is Copyright © 1998-2002 by Karl-Dietrich Neubert.
' - - - http://www.neubert.net/FSOIntro.html
' Ähnelt stark dem Bucket-Sort, arbeitet aber local ´in-situ´.
' Kommt an Quicksort in speziellen Fällen heran.
' Demo-Translation from Pascal to XProfan-11.2a by p.specht/vienna
' Achtung: Rechte Dritter!!!- Nur für Demonstrationszwecke - Ohne jede Gewähr!
' Verwendeter Arraytyp: arr&[1..1000] starting with 1
' Erfunden, um die n*log(n)-Vermutung von D. Knuth zu widerlegen
CLS:Randomize:font 2
declare a&[10000+1],l&[1000+1]
declare num&,nmin&,nmax&,cnum&,i&,hold&
declare c1&,c2&,tm&,auto&
'Main program "FlashSort"
readin
print "\n Starting Sort ..."
tm&=&GetTickCount
buckets
perm
insert
tm&=&GetTickCount-tm&
beep:print "\n Sorted in",tm&,"ms"
waitinput 20000
WriteOutAndCheck
waitinput
end
Proc readin
declare i&,w$
auto&=0
print "\n This is the integer version of FlashSort(c) "
print " In this XProfan program, for specific testing "
print " you may input directly the values to be sorted."
print "\n Number of values to be sorted [0=auto]:",:input num&
if num&=0
auto&=2000
num&=auto&
endif
case auto&:print " Reading in",auto&,"randomized integers ..."
if auto&
a&[]=rnd(2147483647)
else
whileloop num&
print " a[";&loop;"]=";:input w$:a&[&loop]=val(w$)
endwhile
endif
print "\n How many buckets do you want [0=auto]? ";:input cnum&
case cnum&=0:cnum&=num&\10+num& mod 2
endproc
proc buckets
declare i&,k&
nmin&=1:nmax&=1
whileloop num&:i&=&loop
case a&[i&] < a&[nmin&]:nmin&=i&
case a&[i&] > a&[nmax&]:nmax&=i&
endwhile 'Größtes und Kleinstes a[] gefunden
case NMIN&=A&[NMAX&]:RETURN
c1&=(cnum&-1)\(a&[nmax&]-a&[nmin&])'Bucketsize: Buckets-1 durch Range
c2&= c1& * a&[nmin&] 'obere bucketgrenze
l&[]=0 'Leiste = 0
whileloop num&:i&=&loop
k&=1+(c1&*a&[i&]-c2&) 'bucketindex
l&[k&]=l&[k&]+1 'Füllstand
endwhile
whileloop 2,cnum&:k&=&Loop
l&[k&]=l&[k&]+l&[k&-1]
endwhile
hold&=a&[nmax&]
a&[nmax&]=a&[1]
a&[1]=hold&
endproc
Proc perm
declare nmove&,i&,j&,k&,flash&
nmove&=0
j&=1
k&=cnum&
while nmove&<(num&-1)
while j&>l&[k&]
j&=j&+1
k&=1+(c1&*a&[j&]-c2&)
endwhile
flash&=a&[j&]
while j&<> ( l&[k&] + 1 )
k&= 1 + ( c1&*flash&- c2& )
hold&=a&[l&[k&]]
a&[l&[k&]]=flash&
l&[k&]=l&[k&]-1
flash&=hold&
nmove&=nmove&+1
endwhile
endwhile
endproc
Proc insert
declare i&,j&
whileloop num&-2,1,-1:i&=&loop
if a&[i&+1]<a&[i&]
hold&=a&[i&]
j&=i&
while a&[j&+1]<hold&
a&[j&]=a&[j&+1]
j&=j&+1
endwhile
a&[j&]=hold&
endif
endwhile
endproc
Proc writeoutandcheck
declare i&
whileloop num&:i&=&loop
print i&,a&[i&]
if i&>1:if a&[i&]<a&[i&-1]:print "*** ALARM: SORT ERROR! ***"
Sound 2000,200:waitinput':END
Endif:Endif
endwhile
endproc
Alles anzeigen
Abt. CMD-SORT
==========
In Zusammenhang mit schnellen Sortieralgorithmen bietet das ehemalige DOS-Programm SORT, das auch im Windows-CMD-Fenster noch existiert, große Vorteile. Es nutzt z.B. den verfügbaren Hauptspeicher voll aus und legt bei übergroßen Dateien automatische Zwischendateien auf Platte an. Sortieren kann es alphanumerisch auf- oder absteigend, wobei man angeben kann, ab welchem Zeichen im Datensatz der Sortierschlüssel gelesen werden soll. Da es bei gleichen Werten die Reihenfolge nicht verändert, können so erst Unter-Sortierungen und anschließend die Sortierung nach dem Hauptkriterium erfolgen - schnell und praktisch!
Gruss
P.S.: Im Spoiler ein Auszug aus der zugehörigen Hilfe.
SORT [/+n][/R][/M Kilobytes][/L Gebietsschema][/REC Datensatzbytes][[Laufwerk1:][Pfad1]Datei1] [/T [Laufwerk2:][Pfad2]] [/O [Laufwerk3:][Pfad3]Datei3]
/+n
Gibt an, mit welchem Zeichen der Vergleich begonnen werden soll. /+3 bedeutet, dass der
Vergleich mit dem dritten Zeichen jeder Zeile beginnen soll. Zeilen mit weniger als n Zeichen
kommen im Vergleich vor allen anderen Zeilen. Standardmäßig beginnt der Vergleich mit dem
ersten Zeichen jeder Zeile. Diese Option erlaubt es, zuerst Untersortierungen, danach Sort-
Läufe nach dem Hauptschlüssel durchzuführen, da der SORT-Befehl ein stabiler Algorithmus ist,
d.h. die Sub-Ordnung gleicher Elemente wird bewahrt.
/L[OCALE] Gebietsschema
überschreibt das Standardgebietsschema des Systems mit dem angegebenen Gebietsschema.
Das ´C´-Gebietsschema richtet sich nach der schnellsten Zuordnungssequenz und ist gegenwärtig
die einzige Alternative. Die Sortierung berücksichtigt immer Groß- und Kleinschreibung.
/M[EMORY] Kilobytes
gibt die Größe des für Sort zu verwendenden Hauptspeicher in Kilobytes an. Die verwendete
Speichergröße ist immer mindestens 160 Kilobyte groß. Wird die Speichergröße angegeben, wird
genau dieser Wert für Sort verwendet, auch wenn mehr Hauptspeicher verfügbar wäre.
Die beste Leistung wird gewöhnlich erzielt, wenn keine Speichergröße angegeben wird. Standardmäßig wird Sort in einem Durchgang (ohne temporäre Datei) ausgeführt. Wenn die standardmäßige maximale Speichergröße nicht ausreicht, wird Sort in zwei Durchgängen (mit vorsortierten Daten in einer temporären Datei) durchgeführt, so dass die verwendete Speichergröße für den Sortier- und den Zusammenführungsvorgang gleich groß sind. Die standardmäßige maximale Speichergröße ist 90% des verfügbaren Hauptspeichers, wenn sowohl zur Ein- als auch zur Ausgabe Dateien verwendet werden, ansonsten 45% desselben.
/REC[ORD_MAXIMUM] Zeichen
Gibt die maximale Anzahl an Zeichen pro Datensatz an (Standard: 4096, maximal 65535).
/R[EVERSE]
Dreht die Sortierreihenfolge um, d.h. sortiert von Z bis A, dann von 9 bis 0.
[Laufwerk1:][Pfad1]Datei1
Gibt die zu sortierende Datei an. Wird diese nicht angegeben, wird der Standardeingang zum
Sortieren verwendet. Die Angabe der Datei ist schneller als die Umleitung des Standardeingangs
auf diese Datei.
/T[EMPORARY] [Laufwerk2:][Pfad2]
Gibt den Pfad an, unter dem ggf. die temporäre Datei angelegt werden soll. Standardmäßig wird
das Temporärverzeichnis des Systems verwendet (Vermutlich schnellster Speicher).
/O[UTPUT] [Laufwerk3:][Pfad3]Datei3
Gibt die Datei an, in der die sortierten Daten gespeichert werden sollen. Wird diese nicht
angegeben, wird der Standardausgang verwendet. Die Angabe der Datei ist schneller als die
Umleitung des Standardausgangs auf diese Datei.
Ergänzung zu #114: Benchmark: FlashSort, Kombination FlashSort und Quicksort (statt wie im Original Insertsort) und reinem Quicksort über 2000 Integerzahlen: 21 Sek | 652 ms | 451 ms.
Ergebnis: Quicksort bleibt bei halbwegs glatt verteilten Daten absoluter Sieger... In der Disziplin "Verkehrt herum sortierte Daten richtig sortieren" ist der Unterschied noch deutlicher: 42 sek zu 651 ms zu 273 ms (!!!)
Abt. Benchmark "Optimierter LR-Bubblesort" vs QuickSort (2000 Strings)
===============================================
Und dabei hieß es "In einigen Situationen ähnlich schnell"Code Alles anzeigenWindowTitle "Optimierter LinksRechts-Bubblesort versus Quicksort" Window 0,0-%maxx,%maxy-40 declare tm&,w$,a$[],b$[],l&,r&,i&,j& var n&=2000 print "\n Setup von",n&," alphanumerischen Zufalls-Strings läuft ..." print " Beispiele:\n" Whileloop 0,n&-1:i&=&Loop w$="":whileloop 1+Rnd(60):w$=w$+chr$(65+rnd(57)) endwhile:a$[i&]=w$ case rnd(333)=0 print tab(10-len(str$(int(i&))));i&,tab(12);a$[i&] endwhile b$[]=a$[] print "\n\n LRBubblesort läuft ..." tm&=&GetTickCount l&=0:r&=sizeof(a$[])-1 LRBubblesort a$[],l&,r& tm&=&GetTickCount-tm& CLS:print "\n Sortiert in",tm&,"ms":sound 100,100 waitinput 5000 Whileloop 0,r&:i&=&Loop print tab(10-len(str$(int(i&))));i&,tab(12);a$[i&] if i&:if a$[i&]<a$[i&-1]:print "ALARM: ERROR!!!!!!!!!!!!!":sound 2000,200:waitinput:end:endif:endif if %csrlin>48:waitinput 1700:cls:print:endif endwhile beep waitinput CLS print "\n\n QuicksortUp läuft ..." tm&=&GetTickCount l&=0:r&=sizeof(a$[])-1 QuickSortUpDwn10c(b$[],1) tm&=&GetTickCount-tm& CLS:print "\n Sortiert in",tm&,"ms":sound 100,100 waitinput 5000 Whileloop 0,r&:i&=&Loop print tab(10-len(str$(int(i&))));i&,tab(12);b$[i&] if i&:if b$[i&]<b$[i&-1]:print "ALARM: ERROR!!!!!!!!!!!!!":sound 2000,200:waitinput:end:endif:endif if %csrlin>48:waitinput 1700:cls:print:endif endwhile beep waitinput end proc LRBubblesort :parameters a$[],l&,r&:declare x$,f$:var m&=r&:var i&=l& :while i&<m&:x$=a$[i&]:f$=a$[m&]:if x$>f$:a$[m&]=x$:a$[i&]=f$:endif:inc i&:dec m&:endwhile :while l&<r&:x$=a$[l&]:m&=l&-1:i&=l&+1 :while i&<=r&:f$=a$[i&]:if x$<=f$:x$=f$:else :a$[i&]=x$:m&=i&-1:a$[m&]=f$:endif:inc i&:endwhile dec r&:if r&>m&:if l&<m&:r&=m&:else :r&=l&:endif:endif x$=a$[r&]:m&=r&+1:i&=r&-1 :while i&>=l&:f$=a$[i&]:if x$>=f$:x$=f$:else :a$[i&]=x$:m&=i&+1:a$[m&]=f$:endif:dec i&:endwhile inc l&:if l&<m&:if r&>m&:l&=m&:else :l&=r&::endif:endif endwhile endproc proc QuickSortUpDwn10c :parameters a$[],desc&:declare n&,p&,l&,r&,s&,sl&[],sr&[],w$ ' desc&=0 or 1: Sort Ascending a 0-based Array; desc& = -1: Sort descending a 0-based Array; ' desc&= 2 : Sort Ascending with Indexbase =1; desc& = -2: Sort descending 1-based. declare x$,i&,j&:n&=sizeof(a$[]):s&=1:sl&[1]=(abs(desc&)=2):sr&[1]=n&-(abs(desc&)<>2) :while s&>0:l&=sl&[s&]:r&=sr&[s&]:s&=s&-1:while l&<r&:i&=l&:j&=r&:p&=(l&+r&)\2 if a$[l&]>a$[p&]:w$=a$[l&]:a$[l&]=a$[p&]:a$[p&]=w$:endif if a$[l&]>a$[r&]:w$=a$[l&]:a$[l&]=a$[r&]:a$[r&]=w$:endif if a$[p&]>a$[r&]:w$=a$[p&]:a$[p&]=a$[r&]:a$[r&]=w$: endif :x$=a$[p&] :while i&<=j&:if desc&<0:while a$[i&]>x$:inc i&:endwhile :while x$>a$[j&]:dec j& endwhile :else :while a$[i&]<x$:inc i&:endwhile :while x$<a$[j&]:dec j&:endwhile endif :if i&<=j&:w$=a$[i&]:a$[i&]=a$[j&]:a$[j&]=w$:i&=i&+1:j&=j&-1:endif:endwhile if (j&-l&)<(r&-i&):if i&<r&:s&=s&+1:sl&[s&]=i&:sr&[s&]=r&:endif :r&=j&:else if l&<j&:s&=s&+1:sl&[s&]=l&:sr&[s&]=j&:endif :l&=i&:endif :endwhile :endwhile endproc
Das Quicksort würde ich glatt so (natürlich angepasst an ListViews) in die ListView.inc übernehmen wollen. Ist das ok? Natürlich Hinweis auf dich.
@Jac de Lad: Gerne! QuickSort ist auch nicht von mir, sondern von US-Universitätslehrern und durch Doktoranden der Informatik oft verbessert - daher öffentliches Gut, frei zur allgemeinen Verwendung. 10000 Strings in reinem XProfan-Compilat binnen 3 Sekunden sortiert, das sollte ausreichend schnell sein. Ich selbst hab´nur mal einen QuickIndexSort (QuickDex) auf der Basis gebastelt, den kannst Du auch gerne benutzen.
Gruss
P.S.: Wenn Du den Variablentyp anpassen willst, mußt Du nur die Variablen A[], w und x ändern.
Für ein ListView, würde ich eher zu einem stabilen Sortieralgorhymus gereifen. Quicksort ist instabil.
Stabilität (Sortierverfahren)
binnen 3 Sekunden sortiert
Naja, das mag ja für XProfan schnell sein oder waren es doch nur ms?
Naja, Phyton z.B. wäre noch langsamer, ist aber die Sprache der Wahl für Künstliche Intelligenz. Soll heißen: Auf Geschwindigkeit kommt´s nicht immer an, sie muss nur "ausreichend" sein. Im übrigen: Xprofan X4 hat schlimmstenfalls noch den Inline-Assembler in petto.
Sie haben noch kein Benutzerkonto auf unserer Seite? Registrieren Sie sich kostenlos und nehmen Sie an unserer Community teil!