95 lines
2.0 KiB
Plaintext
95 lines
2.0 KiB
Plaintext
' version 08-04-2017
|
|
' compile with: fbc -s console
|
|
|
|
Sub Subfactorial(a() As ULongInt)
|
|
|
|
Dim As ULong i
|
|
Dim As ULongInt num
|
|
|
|
For i = 0 To UBound(a)
|
|
num = num * i
|
|
If (i And 1) = 1 Then
|
|
num -= 1
|
|
Else
|
|
num += 1
|
|
End If
|
|
a(i) = num
|
|
Next
|
|
|
|
End Sub
|
|
|
|
' Heap's algorithm non-recursive
|
|
Function perms_derange(n As ULong, flag As Long = 0) As ULongInt
|
|
' fast upto n < 12
|
|
If n = 0 Then Return 1
|
|
|
|
Dim As ULong i, j, c1, count
|
|
Dim As ULong a(0 To n -1), c(0 To n -1)
|
|
|
|
For j = 0 To n -1
|
|
a(j) = j
|
|
Next
|
|
|
|
While i < n
|
|
If c(i) < i Then
|
|
If (i And 1) = 0 Then
|
|
Swap a(0), a(i)
|
|
Else
|
|
Swap a(c(i)), a(i)
|
|
End If
|
|
For j = 0 To n -1
|
|
If a(j) = j Then j = 99
|
|
Next
|
|
If j < 99 Then
|
|
count += 1
|
|
If flag = 0 Then
|
|
c1 += 1
|
|
For j = 0 To n -1
|
|
Print a(j);
|
|
Next
|
|
If c1 > 12 Then
|
|
Print : c1 = 0
|
|
Else
|
|
Print " ";
|
|
End If
|
|
End If
|
|
End If
|
|
c(i) += 1
|
|
i = 0
|
|
Else
|
|
c(i) = 0
|
|
i += 1
|
|
End If
|
|
Wend
|
|
If flag = 0 AndAlso c1 <> 0 Then Print
|
|
Return count
|
|
|
|
End Function
|
|
|
|
' ------=< MAIN >=------
|
|
|
|
Dim As ULong i, n = 4
|
|
Dim As ULongInt subfac(20)
|
|
|
|
Subfactorial(subfac())
|
|
|
|
Print "permutations derangements for n = "; n
|
|
i = perms_derange(n)
|
|
Print "count returned = "; i; " , !"; n; " calculated = "; subfac(n)
|
|
|
|
Print
|
|
Print "count counted subfactorial"
|
|
Print "---------------------------"
|
|
For i = 0 To 9
|
|
Print Using " ###: ######## ########"; i; perms_derange(i, 1); subfac(i)
|
|
Next
|
|
For i = 10 To 20
|
|
Print Using " ###: ###################"; i; subfac(i)
|
|
Next
|
|
|
|
' empty keyboard buffer
|
|
While InKey <> "" : Wend
|
|
Print : Print "hit any key to end program"
|
|
Sleep
|
|
End
|