PureBasic Forums - English

Posted: **Mon Apr 06, 2009 6:33 pm**

Works also with PB 5.20

A permutation, also called an "arrangement number" or "order," is a rearrangement of the elements of an ordered list.

Generating all permutations of a list is not a simple task. I cannot remember whether I didn't manage to write a general algorithm for it at all, or wether it was way to slow. Anyhow, I decided to look with what someone with "a little more"

knowledge than me had come up, and implemented it in PureBasic. Enjoy!

Code: Select all

EnableExplicit


Procedure Visit (Array a(1))
   ; This is just a sample Procedure.
   Protected i, text$

   text$ = ""
   For i = 1 To ArraySize(a())
      text$ + Str(a(i)) + " "
   Next
   Debug text$
EndProcedure


Procedure Algorithm_L (Array a(1))
   ; after Donald E. Knuth:
   ; The Art Of Computer Programming, Vol. 4, Fascicle 2 (2005)
   ; Algorithm 7.2.1.2 L (pp. 39 f.)
   ; Lexicographic permutations;
   ; also works when equal elements are present, meaning a() is a multiset.
   ; Implemented in PureBasic 4.30 by Little John
   Protected h, i, k, n

   n = ArraySize(a())

   Repeat
      ;-- Step 1: Visit
      Visit(a())
   
      ;-- Step 2: Find h
      h = n - 1
      While a(h) >= a(h+1)
         h - 1
      Wend
      If h = 0
         ProcedureReturn
      EndIf
   
      ;-- Step 3: Increase a(h)
      k = n
      While a(h) >= a(k)
         k - 1
      Wend
      Swap a(h), a(k)
   
      ;-- Step 4: Reverse a(h+1..n)
      i = h + 1
      k = n
      While i < k
         Swap a(i), a(k)
         i + 1
         k - 1
      Wend
   ForEver
EndProcedure


;-- Demo
Define i, n

n = 6             ; Caution, choosing a big n will take long time!

Dim a(n)
For i = 1 To n
   a(i) = i
Next

Algorithm_L(a())

Posted: **Thu Apr 09, 2009 1:04 am**

I like this algorithm, I think it's fast and efficient and a good solution. However, there are 3 problems with it:

1) The array must be in sort-ascending order for it to work
2) Duplicates in the array will cause it to fail
3) It uses stringhandling at the iteration level

I wanted to use this for generating anagrams, but with these limitations it's not usable in its current state. So I removed the string logic and made a modification which will solve the other two problems:

1. Create a translation table from the alphabet: A,B,C,D, etc.
2. Encode the input string with corresponding values from the table
3. Generate the permutations using the encoded characters
4. As each permutation is created, decode it back to its original characters

So:

Code: Select all

Input string: e a s t e r
becomes:      A B C D E F   which is acceptable To the routine because:
                            
                            a) All characters are unique
                            b) The input array to the routine is in sort-ascending order

Here is the code for the modified routine. It returns a pointer to a structured memory block containing everything you need to use the permutations:

Code: Select all


Structure PERMUTATIONS
  n.l      ; number of permutations generated
  length.l ; length of each item with terminating 0
  *bytes   ; pointer to data block containing items
EndStructure

Global Dim Table(26)
Global Dim WordIn(26)


Procedure Translate(char, n)

  For i=1 To n
    If table(i)=char
      ProcedureReturn WordIn(i)
    EndIf
  Next
  
EndProcedure

Procedure Visit (Array a(1), *pdata.BYTE) 

   Protected i,n
   Static *datapointer.BYTE, iterations=0
   
   n=ArraySize(a()) 
   *datapointer = *pdata + iterations * (n+1)

   For i = 1 To n
      *datapointer\b = translate(a(i),n) : *datapointer+1
   Next 
   *datapointer\b = 0 
   iterations+1
EndProcedure 


Procedure Algorithm_L (Array a(1), *pdata.BYTE) 
   ; after Donald E. Knuth: 
   ; The Art Of Computer Programming, Vol. 4, Fascicle 2 (2005) 
   ; Algorithm 7.2.1.2 L (pp. 39 f.) 
   ; Lexicographic permutations; 
   ; also works when equal elements are present, meaning a() is a multiset. 
   ; Implemented in PureBasic 4.30 by Little John 
   Protected h, i, k, n 

   n = ArraySize(a()) 

   Repeat 
      ;-- Step 1: Visit 
      Visit(a(), *pdata) 
    
      ;-- Step 2: Find h 
      h = n - 1 
      While a(h) >= a(h+1) 
         h - 1 
      Wend 
      If h = 0 
         ProcedureReturn 
      EndIf 
    
      ;-- Step 3: Increase a(h) 
      k = n 
      While a(h) >= a(k) 
         k - 1 
      Wend 
      Swap a(h), a(k) 
    
      ;-- Step 4: Reverse a(h+1..n) 
      i = h + 1 
      k = n 
      While i < k 
         Swap a(i), a(k) 
         i + 1 
         k - 1 
      Wend 
   ForEver 
EndProcedure 

Procedure.q Factorial(n)
  Protected f.q = n
  For i=n To 2 Step -1
    f * (i-1)
  Next
  ProcedureReturn f
EndProcedure


ProcedureDLL CreatePermutations(str$)
  
  Protected n = Len(str$)
  Protected fn = Factorial(n)
  
  For i=1 To n
    wordin(i)=Asc(Mid(str$,i,1))
  Next
  
  For i=1 To 26
    Table(i)=i+64
  Next
  
  Dim a(n)
  For i=1 To n
    a(i)=table(i)
  Next
  
  *pdata.BYTE = AllocateMemory(fn*n+fn)
  Algorithm_L(a(), *pdata)
  
  *p.PERMUTATIONS=AllocateMemory(SizeOf(PERMUTATIONS))
  
  With *p
    \n = fn
    \length = n+1 ; 1 for the zero terminating each string
    \bytes = *pdata
  EndWith
  
  ProcedureReturn *p
  
EndProcedure


; Test code

*p.PERMUTATIONS = CreatePermutations("easter") 

NewList *items()
*pointer = *p\bytes
For i=1 To *p\n
  AddElement(*items())
  *items()=*pointer
  *pointer+*p\length
Next

cc=0    
ForEach *items()
  Debug PeekS(*items())
  cc+1
Next
Debug Str(cc)+ " unique permutations"

The translation table slows it down marginally but it's still very quick and it produces a result that is usable for practical applications.

Posted: **Thu Apr 09, 2009 10:00 am**

the french spaggetti code :
this code generate all permutations of an word

Code: Select all


; Code Dobro
; PureBasic 4.00
Resultat = OpenConsole()

Print("Entrez un mot et appuyez sur 'Return': ")
m$=Input()
n= Len(m$)
Dim mo$(n)
Dim p(n)
mo$(n)=m$
z=n
rt:
p(z)=1
dt:
mo$(z-1)=Right(mo$(z),z-1)
z=z-1
If z>1
    Goto rt
EndIf
m$=""
For w=1 To n
    m$=Left(mo$(w),1)+m$
Next w

Print(m$+" ")

gt:
mo$(z+1)=mo$(z)+Left(mo$(z+1),1)
z=z+1
p(z)=p(z)+1
If p(z)<=z
    Goto dt
EndIf
If z<n
    Goto gt
EndIf


Print("FINI !!!!")

k$=Input()

Resultat = CloseConsole()

Posted: **Thu Apr 09, 2009 11:11 am**

BenchMark (for a word with 7 letters) (ISO TONTON):
(mean of cpu clock cycles elapsed during the specified operation)

1st) NetMaestro - near 4,5 megacycles
2nd) Dobro - near 19 megacycles
3rd) Little John - near 19,3 megacycles

Posted: **Sun Apr 12, 2009 12:26 am**

Recursive approach based on Exeter algorithm, outputs strings but that could be changed input a set and choose a range.

CreatePermutations(address of set, range, size of type, print out list)

Code: Select all



;idle permutation based on University of Exeter algorithm, should handle any default type, though only retuns strings at the moment
;CreatePermutations(*set,range,size of type, print out list)
;eg
;set.s = "easter"
;CreatePermutations(@set,6,#TCHAR,#True)  
;Or 
;CreatePermutationsRange(5,8,#TFLOAT,#True,0.50) 

Global ct.i 

Global NewList lout.s()

Enumeration
  #TBYTE
  #TCHAR
  #TWORD
  #TLONG
  #TFLOAT
  #TDOUBLE
  #TQUAD
EndEnumeration   

Procedure Permute(*V,start,n,sizeofV)
 If start = n-1
  If *v
   sout.s
   For i = 0 To n -1
     Select sizeofV 
       Case #TBYTE 
          tv = PeekB(*V+i)
          sout + Str(tv) + " "   
       Case #TCHAR
          tw.c = PeekC(*V+(i* SizeOf(Character)))
          sout + Chr(tw)  
       Case #TWORD
          tww.w = PeekW(*V+(i*SizeOf(WORD))) 
          sout + Str(tww) + " " 
       Case #TLONG 
          ti.i = PeekI(*V+(i*SizeOf(LONG)))
          sout + Str(ti) + " " 
       Case #TFLOAT 
          tf.f = PeekF(*V+(i*SizeOf(Float)))
          sout + StrF(tf,7) + " " 
       Case #TDOUBLE
          td.d = PeekD(*V+(i*SizeOf(DOUBLE)))
          sout + StrD(td,15) + " "  
       Case #TQUAD
          tq.q = PeekQ(*V+(i*SizeOf(QUAD)))
          sout + Str(tq) + " " 
       EndSelect  
   Next
     AddElement(lout())
     lout()= sout
     ct+1
   EndIf
 Else 
    For i = start To n -1
      Select sizeofV 
        Case #TBYTE 
          tmpb.b = PeekB(*V+i)
          PokeB(*v+i,PeekB(*v+start));
          PokeB(*v+start,tmpb)
          permute(*v, start+1, n,sizeofV);
          PokeB(*v+start,PeekB(*v+i));
          PokeB(*v+i,tmpb);
       Case #TCHAR 
          sz = SizeOf(Character)
          tmpc.c = PeekC(*V+(i*sz))
          PokeC(*v+(i*sz),PeekC(*v+(start*sz)));
          PokeC(*v+(start*sz),tmpc)
          permute(*v,start+1,n,sizeofV);
          PokeC(*v+(start*sz),PeekC(*v+(i*sz)))
          PokeC(*v+(i*sz),tmpc);
       Case #TWORD 
          sz = SizeOf(WORD)
          tmpw.w = PeekW(*V+(i*sz))
          PokeW(*v+(i*sz),PeekW(*v+(start*sz)));
          PokeW(*v+(start*sz),tmpw)
          permute(*v,start+1,n,sizeofV);
          PokeW(*v+(start*sz),PeekW(*v+(i*sz)))
          PokeW(*v+(i*sz),tmpw);
       Case #TLONG 
          sz = SizeOf(LONG)
          tmpl.i = PeekI(*V+(i*sz))
          PokeI(*v+(i*sz),PeekI(*v+(start*sz)));
          PokeI(*v+(start*sz),tmpl)
          permute(*v, start+1, n,sizeofV);
          PokeI(*v+(start*sz),PeekI(*v+(i*sz)))
          PokeI(*v+(i*sz),tmpl);
       Case #TFLOAT
          sz =SizeOf(FLOAT)
          tmpf.f = PeekF(*V+(i*sz))
          PokeF(*v+(i*sz),PeekF(*v+(start*sz)));
          PokeF(*v+(start*sz),tmpf)
          permute(*v, start+1, n,sizeofV);
          PokeF(*v+(start*sz),PeekF(*v+(i*sz)))
          PokeF(*v+(i*sz),tmpf);
       Case #TDOUBLE 
          sz = SizeOf(DOUBLE)
          tmpd.d = PeekD(*V+(i*sz))
          PokeD(*v+(i*sz),PeekD(*v+(start*sz)));
          PokeD(*v+(start*sz),tmpd)
          permute(*v, start+1, n,sizeofV);
          PokeD(*v+(start*sz),PeekD(*v+(i*sz)))
          PokeD(*v+(i*sz),tmpd);
       Case #TQUAD 
          sz = SizeOf(QUAD)
          tmpq.q = PeekQ(*V+(i*sz))
          PokeQ(*v+(i*sz),PeekQ(*v+(start*sz)));
          PokeQ(*v+(start*sz),tmpq)
          permute(*v, start+1, n,sizeofV);
          PokeQ(*v+(start*sz),PeekQ(*v+(i*sz)))
          PokeQ(*v+(i*sz),tmpq);
      
      EndSelect  
    Next
  EndIf 
EndProcedure 

Procedure CreatePermutations(*set,range,sizet,print)
  ct = 0
  permute(*set,0,range,sizet)
  If print 
   ForEach lout()
     PrintN(lout())
   Next 
  EndIf    
  ClearList(lout())
EndProcedure 

Procedure CreatePermutationsRange(Rstart.q,REnd.q,type,print,steps.f=1.0)

len= (Rend-Rstart)+1
Select type 
  Case #TBYTE
    *tset = AllocateMemory(Rend-Rstart)
    For a = 0 To len-1 
      PokeB(*tset+a,a+rstart)
    Next
 Case #TWORD
    *tset = AllocateMemory((Rend-Rstart)*SizeOf(WORD))
    sz = SizeOf(word)
    For a = 0 To len -1
      PokeW(*tset+(a*sz),a+rstart)
    Next
 Case #TLONG
    *tset = AllocateMemory((Rend-Rstart)*SizeOf(LONG))
    sz = SizeOf(long)
    For a = 0 To len-1 
      PokeI(*tset+(a*sz),a+rstart)
    Next      
 Case #TFLOAT 
    ctf.f = Rstart 
    sz = SizeOf(float)
    len = (len * (1/steps)) -1
    *tset = AllocateMemory(len*sz)
    For a = 0 To len - 1
      PokeF(*tset+(a*sz),ctf)
      ctf+steps
    Next
 Case #TDOUBLE
     ctd.d = Rstart 
     sz = SizeOf(Double)
     len = (len * (1/steps)) -1
     *tset = AllocateMemory(len*sz)
     For a = 0 To len - 1
       PokeD(*tset+(a*sz),ctd)
       ctd+steps
     Next
 Case  #TQUAD
    *tset = AllocateMemory((Rend-Rstart)*SizeOf(quad))
    sz = SizeOf(Quad)
    For a = 0 To len-1 
      PokeQ(*tset+(a*sz),a+rstart)
    Next   
 EndSelect

 CreatePermutations(*tset,len,type,print)
 FreeMemory(*tset)
 
EndProcedure 


;#########################test code below################################# 

OpenConsole()

;timing run 

na = 100

set.s = "easter"
st = GetTickCount_()
For a = 0 To na
  CreatePermutations(@Set,6,#TCHAR,#False)
Next 
et.s = StrF(((GetTickCount_() - st)/na),3) + " milliseconds "  

PrintN(Str(ct) +  " Permutations Avgerage Time " + et + " =========================")
PrintN("Hit Enter to continue") 
Input()

;########### 
 
CreatePermutationsRange(5,7,#TFLOAT,#True,0.50) 
PrintN(Str(ct) +  " permutations of float range 5 to 7  =======================================")
PrintN("Hit Enter to continue")
Input()  

CreatePermutations(@set,6,#TCHAR,#True) 

PrintN(Str(ct) +  " Chr Permutations =======================================")
PrintN("Hit Enter to continue")
Input() 
 
;array of vals 
Dim bSet.b(5) 
bSet(0) = 1
bSet(1) = 2
bSet(2) = 3
bSet(3) = 4
bSet(4) = 5
 
CreatePermutations(@bSet(0),5,#TBYTE,#True)
 
PrintN(Str(ct) +  " Byte Permutations =======================================")
PrintN("Hit Enter to continue")
Input() 
 
 
;array of vals 
Dim wSet.w(5) 
wSet(0) = 1111
wSet(1) = 2222
wSet(2) = 3333
wSet(3) = 4444
wSet(4) = 5555
 
CreatePermutations(@wSet(0),5,#TWORD,#True)
 
PrintN(Str(ct) +  " Word Permutations =======================================")
PrintN("Hit Enter to continue")
Input()
Dim iSet.i(6) 
iSet(0) = 6666
iSet(1) = 7777
iSet(2) = 8888
iSet(3) = 9999
iSet(4) = 1000
iSet(5) = 2000

CreatePermutations(@iSet(0),5,#TLONG,#True)
PrintN(Str(ct) +  " Long Permutations =======================================")
PrintN("Hit Enter to continue")
Input()

Dim fSet.f(6)
fset(0) = 1.1234
fset(1) = 2.1234
fset(2) = 3.1234
fset(3) = 4.1234
fset(4) = 5.1234
fset(5) = 6.1234

CreatePermutations(@fSet(0),5,#TFLOAT,#True)
PrintN(Str(ct) +  " Float Permutations =======================================")
PrintN("Hit Enter to continue")
Input()

Dim dSet.d(6)
dset(0) = 1.1234
dset(1) = 2.1234
dset(2) = 3.1234
dset(3) = 4.1234
dset(4) = 5.1234
dset(5) = 6.1234

CreatePermutations(@dSet(0),5,#TDOUBLE,#True)
PrintN(Str(ct) +  " Double Permutations =======================================")
PrintN("Hit Enter to continue")
Input()

Dim qSet.q(6)
qset(0) = 112341111
qset(1) = 212341111
qset(2) = 312311214
qset(3) = 412311212
qset(4) = 512341212
qset(5) = 612312214

CreatePermutations(@qSet(0),5,#TQUAD,#True)
PrintN(Str(ct) +  " Quad Permutations =======================================")
PrintN("Hit Enter to continue")



Input()

CloseConsole()

Posted: **Sat Apr 18, 2009 1:54 am**

95% faster then NetMaestros' example for calculation and storing permutaions into MemBlock.

Code: Select all

;Permutations by Booger
;Converted from Trs-80 Model 1 (Z-80) Assembly
;April 2009
;Unknown Algorithm Perhaps trotter

OpenConsole()
string.s = "12345678901";************************************

length = Len(string.s)
PrintN("String is " + string.s)
PrintN("  Length is " + Str(length) )
PrintN("Calculating Permutation Count...")
Permutations = length;set factoring start
For i = length To 2 Step -1
  Permutations*(i-1);factor string.s length
Next
PermutationCount = Permutations
PrintN("Permutations=" + Str(Permutations))
PrintN("")
PrintN("This is going to use " + StrF(((Permutations*4) + Permutations*(length + 1))/1024.0/1024.0) + " Mb of memory if you store the Permutations.")
PrintN("If windows denies the memory, I will crash!")
Print("Do you want to allocate storage(You may want to make file after I am done)? ") : Result.s = Input()
timer = ElapsedMilliseconds()
If LCase(Left(Result, 1)) = "y"
  *store = #True
  Dim *StringPointer(Permutations)
  *buffer = AllocateMemory(Permutations*(length + 1))
  For z = 0 To permutations-1
    *StringPointer(z) = z*(Length + 1)
  Next
Else
  *store = #False
EndIf
PrintN("Calculating Permutations...")
Gosub Permutate
PrintN("")
PrintN("I have returned!")
PrintN("Permutations found=" + Str(*count))
PrintN("Count2=" + Str(*count2))
PrintN("time taken was " + StrF((ElapsedMilliseconds()-timer)/1000) + " Seconds")
If LCase(Left(Result, 1)) = "y"
  PrintN("")
  PrintN("The Results are stored in memory.")
  PrintN("")
  Print("Do you want to write these to a file? ") : Result.s = Input()
  If LCase(Left(Result, 1)) = "y"
    Print("Please input filename for your text file:") : Result.s = Input()
    If CreateFile(0, Result + ".txt")
      For z = 1 To *count
        WriteStringN(0, Str(z) + "=" + PeekS(*Buffer + *StringPointer(z)))
      Next
      CloseFile(0)
    Else
      MessageRequester("Information", "Can't create the file!")
    EndIf
  EndIf
EndIf
FreeMemory(*buffer)
PrintN("")
PrintN("Done...Press Enter to end Program.")
Input()
End

Permutate:  ;********(*Number=length,string)

*Number = length

Dim *String(*Number)
Dim *Linkers(*Number)
Dim *StringReference(*Number + 1)

For z = 1 To *number ;Step 4
  *StringReference(z) = Asc(Mid(string, z, 1))
Next

For j = 1 To *Number
  *String(j) = j
Next

*kill = 1
While Not *kill = 0
  *count + 1
  
  *Kill = 0
  *Digits = 0
  If *store 
    *z = 0
    *Temp = *buffer + *StringPointer(*count)
    While *z<*number
      PokeB(*temp + *z, *StringReference(*String(*z + 1)))
      *z + 1
    Wend
  EndIf
  While *Digits<*Number
    *Digits + 1
    *Push = *String(*Digits)
    If *Linkers(*Digits) = 0
      If *Digits>1
        If *String(*Digits-1)<*Push
          If *Push>*Kill
            *Kill = *Push
            *Connectors = *Digits
          EndIf
        EndIf
      EndIf
    ElseIf *Digits<*Number
      If *String(*Digits + 1)<*Push
        If *Push>*Kill
          *Kill = *Push
          *Connectors = *Digits
        EndIf
      EndIf
    EndIf
    If *Kill = *Number
      Break ; done here, update links
    EndIf
  Wend
  *PosLinker = *Linkers(*Connectors)
  If *PosLinker
    *String(*Connectors) = *String(*Connectors + 1)
    *Linkers(*Connectors) = *Linkers(*Connectors + 1)
    *String(*Connectors + 1) = *Kill
    *Linkers(*Connectors + 1) = 1
  Else
    *String(*Connectors) = *String(*Connectors-1)
    *Linkers(*Connectors) = *Linkers(*Connectors-1)
    *String(*Connectors-1) = *Kill
    *Linkers(*Connectors-1) = 0
  EndIf
  For *Digits = 1 To *Number
    If *String(*Digits)>*Kill
      *Linkers(*Digits) = 1-*Linkers(*Digits)
    EndIf
  Next
Wend

Return

Posted: **Wed Aug 26, 2009 2:08 pm**

Could anyone do the math on this for me please? All arrangements of the alphabet - A to Z - no repetition of characters. I didn't think it would that much, but another permutations program I'm running is currently at 130gb. It's the lack of repetition that makes me think it should be less. Wishful thinking?

Posted: **Wed Aug 26, 2009 2:41 pm**

safra wrote:Could anyone do the math on this for me please? All arrangements of the alphabet - A to Z - no repetition of characters. I didn't think it would that much, but another permutations program I'm running is currently at 130gb. It's the lack of repetition that makes me think it should be less. Wishful thinking?

There are a lot of permutations.
You have in the first step 26 possibilities, in the next one 25 for each possiblity in the previous step.

So you get 1*2*3*....*25*26 = 26! = ca 4*10^26 possiblities. And that is definitly a LOT.

To store all of them you need for each one 26 bytes in memory.
That should make: 26! * 26 / 1024^4 = 3,6*10^14 TerraByte

Posted: **Sat Aug 29, 2009 7:47 am**

Dang! Thank you, it is a hell of a lot

PureBasic Forums - English

Generate all permutations

Generate all permutations