Dabei können beliebig viele Elemente permutiert werden, selbst wenn die Anzahl ihrer Permutationen die 2^31-Grenze überschreitet.
[Anm: Permutation = Aneinanderreihung von Elementen der Ausgangsmenge (hier der Zahlen 1..p_numElems), wobei jedes genau einmal und an einer beliebigen Position auftaucht]
Code: Alles auswählen
;/ PermutationCaller(p_numElems.l, *p_callbackProc.l)
;/ >> generates all permutations of numbers 1..p_numElems and calls *p_callbackProc on
;/ >> each permutation to use it for any purpose
;/
;/ p_numElems: the number of elements to permutate (1..)
;/ *p_callbackProc: pointer to function to call each time a new permutation
;/ was generated. This function has to be of the form:
;/ ProcName (*p_array.l, p_numElems.l, p_counter.l)
;/ where [*p_array] will hold a pointer to an array
;/ of [p_numElems] permutated long-values each in
;/ range 1..[p_numElems]
;/ p_counter just counts from 1..
;/ This callbackfunction has to return 0 (or nothing) to let
;/ PermutationCaller() continue,
;/ or may return anything <> 0 to let PermutationCaller()
;/ stop immediately.
;/
;/ by Froggerprogger, 20.11.2004
Procedure.l PermutationCaller(p_numElems.l, *p_callbackProc.l)
Dim Permutation.l (p_numElems - 1) ; holds the actual permutation
Dim TempFreedValues.l (p_numElems - 1) ; entry 0=used, 1=(temporarily) not used value
Protected resume.l : resume = 1
Protected runPos.l : runPos = p_numElems - 2
Protected tempL.l
Protected lastVal.l
Protected counter.l
; nothing to permutate with p_numElems <= 1
If p_numElems <= 1
ProcedureReturn 0
EndIf
; fill in the first permutation
For i=0 To p_numElems - 1
Permutation(i) = i+1
Next
Repeat
counter + 1
; call the custom function
tempL = CallFunctionFast(*p_callbackProc, @Permutation(), p_numElems, counter)
If tempL <> 0
ProcedureReturn tempL
EndIf
; free all entries from runPos to end
descending = 1
lastVal = Permutation(runPos)
TempFreedValues(lastVal - 1) = 1
For i = runPos + 1 To p_numElems - 1
tempL = Permutation(i)
TempFreedValues(tempL - 1) = 1
If descending And tempL > lastVal
descending = 0
ElseIf descending
lastVal = tempL
EndIf
Next
While descending
; if at runPos the local maximum is, then free it and go one more left to increase it
runPos - 1
; quit if this was the most left position
If runPos < 0 : ProcedureReturn counter : EndIf
tempL = Permutation(runPos)
TempFreedValues(tempL-1) = 1
lastVal = Permutation(runPos+1)
If tempL < lastVal
descending = 0
EndIf
Wend
; write nearest greater value to runPos
i = Permutation(runPos)
Repeat
i+1
Until TempFreedValues(i-1) = 1
TempFreedValues(i-1) = 0
Permutation(runPos) = i
; write back the other freed values in descending order
j = runPos + 1
For i=0 To p_numElems - 1
If TempFreedValues(i) = 1
TempFreedValues(i) = 0
Permutation(j) = i+1
j+1
EndIf
Next
runPos = p_numElems - 2
ForEver
EndProcedure
;-
;- 2 Examples
;-
;/ example 1 - simple number permutation
#max1 = 4
Debug "example 1: simple number permutation"
Procedure SimpleDebugArray(*p_array.l, p_numElems.l, p_counter.l)
;( >>sniff<< there are no arrays as parameters in PB)
Protected res.s
res = ""
For i=0 To p_numElems-1
res + Str(PeekL(*p_array + 4*i)) + " | "
Next
Debug res
ProcedureReturn 0
EndProcedure
Debug Str(PermutationCaller(#max1, @SimpleDebugArray())) + " permutations"
Debug "" : Debug ""
;/ example 2 - using permutationcaller for another purepose (strings' combination here)
#max2 = 5
Dim MyStringArray.s(#max2 - 1)
Debug "example 2: using permutationcaller() for strings' combination"
Procedure DebugStrings(*p_array.l, p_numElems.l, p_counter.l)
;( >>sniff<< there are no arrays as parameters in PB)
Protected res.s
res = ""
For i=0 To p_numElems-1
res + MyStringArray(PeekL(*p_array + 4*i)-1) + " "
Next
Debug res
ProcedureReturn 0
EndProcedure
; fill some strings into an array
For i=0 To #max2-1
MyStringArray(i) = Chr(65 + i) + Str(i) + Chr(97 + i)
Next
Debug Str(PermutationCaller(#max2, @DebugStrings())) + " permutations"