XProfan

WindowTitle "Lexikographisch aufsteigende Permutationen eingegebener Wortstrings"
Font 2:randomize:cls rnd(8^8)
print " Trenner = Leerzeichen oder |, Durch negative Zahlen"
print " (zB. -9) werden Indexfolgen 0|1|2|3|4|5|6|7|8 permutiert."
print
' Interpreter: 9 Elemente 362880 mal permutiert in 148.81 Sek (ohne Ausgeben)
' XPIA:                       - '' -            in  28.55 Sek
' ProfComp                                      in  27.33 Sek
' $MAKE CLE
 {$cleq}
Declare t$,z&,tt$[],n&,tm&,ts$
var ausgeben%=0
Restart:
print " Zu permutieren (Leer oder | als Trenner):\n\n ";
input t$
t$=trim$(t$)
t$=translate$(t$,"  "," ")
case instr("|",t$):q$="|"
t$=translate$(t$," ","|")

if val(t$)<0

    setSize tt$[],-1*val(t$)
    tt$[]=str$(&Index)

else

    tt$[]=explode(t$,"|")

Endif

n&=SizeOf(tt$[])

if n&<2

    z&=0
    Goto "Skip"

endif

cls rnd(8^8)
print " Permutation läuft..."
tm&=&gettickcount
z&=PERM()' PERM ruft DOSOMETHINGWITHRESULTS auf!
' und verwendet dann NEXTPERM
tm&=&gettickcount-tm&
cls
print
ts$=" In "+str$(tm&)+" ms"
Skip:
ts$=ts$+" "+str$(z&)+" Permutationen erzeugt."
ClearClip
PutClip ts$
Print ts$
Print " Benchwerte in Zwischenablage verfügbar."
beep
WaitInput
CLS rnd(8^8)
Goto "Restart"
End

Proc DOSOMETHINGWITHRESULTS

    ' Hier: Ausgeben
    casenot ausgeben%:return
    case %csrlin>21: locate 1,1

    WhileLoop n&

        print tt$[&Loop-1];
        case &Loop=n&:continue
        print q$;

    EndWhile

    print

EndProc

PROC PERM

    Declare k&,j&,u&,v&,e%,z&,q$
    e%=1
    z&=0
    q$="|"

    While e%

        inc z&
        DOSOMETHINGWITHRESULTS
        NEXTPERM

    EndWhile

    return z&

ENDPROC

proc NEXTPERM

    'erzeugt die jeweils nächste lexikalische Permutation
    k&=n&-2

    While tt$[k&]>=tt$[k&+1]

        Dec k&
        case k&<0:break

    EndWhile

    if k&<0

        e%=0

    else

        j&=n&-1

        While tt$[j&]<=tt$[k&]

            dec j&

        EndWhile

        t$=tt$[k&]
        tt$[k&]=tt$[j&]
        tt$[j&]=t$
        u&=k&+1
        v&=n&-1

        While u&<v&

            t$=tt$[u&]
            tt$[u&]=tt$[v&]
            tt$[v&]=t$
            inc u&
            dec v&

        EndWhile

    endif

endProc

proc rofl

    declare a&
    return mao()

endproc

proc mao

    return a&*a&

endproc

proc rofl

    declare a&
    return mao()

    proc mao()

        return a&*a&

    endproc

endproc