RosettaCodeData/Task/Permutations-Derangements/PureBasic/permutations-derangements-1.purebasic

Procedure.q Subfactoral(n)
If n=0:ProcedureReturn 1:EndIf
If n=1:ProcedureReturn 0:EndIf
ProcedureReturn (Subfactoral(n-1)+Subfactoral(n-2))*(n-1)
EndProcedure

factFile.s="factorials.txt"
tempFile.s="temp.txt"
drngFile.s="derangements.txt"
DeleteFile(factFile.s)
DeleteFile(tempFile.s)
DeleteFile(drngFile.s)

n=4

; create our storage file
f.s=factFile.s
If CreateFile(0,f.s)
WriteStringN(0,"1.2")
WriteStringN(0,"2.1")
CloseFile(0)
Else
Debug "not createfile :"+f.s
EndIf

showfactorial=#False

If showfactorial
; cw("nfactorial n ="+str(n))
Debug "nfactorial n ="+Str(n)
EndIf

; build up the factorial combinations
For l=1 To n-2
Gosub nfactorial
Next

; extract the derangements
; cw("derangements["+str(perm(n))+"] for n="+str(n))
Debug "derangements["+Str(Subfactoral(n))+"] for n="+Str(n)
Gosub derangements
; cw("")
Debug ""

; show the first 20 derangements
For i=0 To 20
Debug "derangements["+Str(Subfactoral(i))+"] for n="+Str(i)
Next

End

derangements:
x=0
If ReadFile(0,factFile.s) And CreateFile(1,drngFile.s)
Repeat
r.s = ReadString(0)
cs=CountString(r.s,".")
If cs
hit=0
t.s=""
; scan for numbers at their index
For i=1 To cs+1
s.s=StringField(r.s,i,".")
t.s+s.s+"."
If Val(s.s)=i:hit+1:EndIf
Next
t.s=RTrim(t.s,".")
; show only those which are valid
If Not hit
x+1
; cw(t.s+" "+str(x))
Debug t.s+" "+Str(x)
WriteStringN(1,t.s+" "+Str(x))
EndIf
EndIf
Until Eof(0)
CloseFile(0)
CloseFile(1)
Else
Debug "not readfile :"+factFile.s
Debug "not createfile :"+drngFile.s
EndIf
; cw("")
Debug ""
Return

nfactorial:
x=0
If ReadFile(0,factFile.s) And CreateFile(1,tempFile.s)
Repeat
r.s = ReadString(0)
cs=CountString(r.s,".")
If cs
For j=1 To cs+2
t.s=""
For i=1 To cs+1
s.s=StringField(r.s,i,".")
If i=j
t.s+"."+Str(cs+2)+"."+s.s
Else
t.s+"."+s.s
EndIf
Next
If j=cs+2:t.s+"."+Str(cs+2):EndIf
t.s=Trim(t.s,".")
x+1
If cs+2=n And showfactorial
; cw(t.s+" "+str(x))
Debug t.s+" "+Str(x)
EndIf
WriteStringN(1,t.s)
Next
EndIf
Until Eof(0)
CloseFile(0)
CloseFile(1)
Else
Debug "not readfile :"+factFile.s
Debug "not createfile :"+tempFile.s
EndIf
CopyFile(tempFile.s,factFile.s)
DeleteFile(tempFile.s)
Return