Anonymous user
Best shuffle: Difference between revisions
no edit summary
m (Add reference to Rust rand library) |
No edit summary |
||
Line 3,610:
up pu (0)
a a (1)</pre>
'=={{header|VBA}}==
'<lang vb>
Option Explicit
Sub Main_Best_shuffle()
Dim S() As Long, W, b As Byte, Anagram$, Count&, myB As Boolean, Limit As Byte, i As Integer
W = Array("a", "abracadabra", "seesaw", "elk", "grrrrrr", "up", "qwerty", "tttt")
For b = 0 To UBound(W)
Count = 0
Select Case Len(W(b))
Case 1: Limit = 1
Case Else
i = NbLettersDiff(W(b))
If i >= Len(W(b)) \ 2 Then
Limit = 0
Else
Limit = Len(W(b))
End If
End Select
RePlay:
Do
S() = ShuffleIntegers(Len(W(b)))
myB = GoodShuffle(S, Limit)
Loop While Not myB
Anagram = ShuffleWord(CStr(W(b)), S)
Count = Nb(W(b), Anagram)
If Count > Limit Then GoTo RePlay
Debug.Print W(b) & " ==> " & Anagram & " (Score : " & Count & ")"
Next
End Sub
Function ShuffleIntegers(l As Long) As Long()
Dim i As Integer, ou As Integer, temp() As Long
Dim C As New Collection
ReDim temp(l - 1)
If l = 1 Then
temp(0) = 0
ElseIf l = 2 Then
temp(0) = 1: temp(1) = 0
Else
Randomize
Do
ou = Int(Rnd * l)
On Error Resume Next
C.Add CStr(ou), CStr(ou)
If Err <> 0 Then
On Error GoTo 0
Else
temp(ou) = i
i = i + 1
End If
Loop While C.Count <> l
End If
ShuffleIntegers = temp
End Function
Function GoodShuffle(t() As Long, Lim As Byte) As Boolean
Dim i&, C&
For i = LBound(t) To UBound(t)
If t(i) = i Then C = C + 1
Next i
GoodShuffle = (C <= Lim)
End Function
Function ShuffleWord(W$, S() As Long) As String
Dim i&, temp, strR$
temp = Split(StrConv(W, vbUnicode), Chr(0))
For i = 0 To UBound(S)
strR = strR & temp(S(i))
Next i
ShuffleWord = strR
End Function
Function Nb(W, A) As Integer
Dim i As Integer, l As Integer
For i = 1 To Len(W)
If Mid(W, i, 1) = Mid(A, i, 1) Then l = l + 1
Next i
Nb = l
End Function
Function NbLettersDiff(W) As Integer
Dim i&, C As New Collection
For i = 1 To Len(W)
On Error Resume Next
C.Add Mid(W, i, 1), Mid(W, i, 1)
Next i
NbLettersDiff = C.Count
End Function
'</lang>
{{out}}
<pre>a ==> a (Score : 1)
abracadabra ==> baacdbaraar (Score : 0)
seesaw ==> awsees (Score : 0)
elk ==> kel (Score : 0)
grrrrrr ==> rgrrrrr (Score : 5)
up ==> pu (Score : 0)
qwerty ==> eytwrq (Score : 0)
tttt ==> tttt (Score : 4)</pre>
=={{header|VBScript}}==
| |||