Posted By

Shurik76 on 02/26/09


Tagged


Versions (?)

Who likes this?

1 person have marked this snippet as a favorite

benrudolph


Array Shuffle


 / Published in: ASP
 

URL: http://forums.aspfree.com/asp-development-5/how-to-shuffle-array-items-156436.html

  1. Sub Shuffle (ByRef arrInput)
  2. 'declare local variables:
  3. Dim arrIndices, iSize, x
  4. Dim arrOriginal
  5.  
  6. 'calculate size of given array:
  7. iSize = UBound(arrInput)+1
  8.  
  9. 'build array of random indices:
  10. arrIndices = RandomNoDuplicates(0, iSize-1, iSize)
  11.  
  12. 'copy:
  13. arrOriginal = CopyArray(arrInput)
  14.  
  15. 'shuffle:
  16. For x=0 To UBound(arrIndices)
  17. arrInput(x) = arrOriginal(arrIndices(x))
  18. Next
  19. End Sub
  20.  
  21. Function CopyArray (arr)
  22. Dim result(), x
  23. ReDim result(UBound(arr))
  24. For x=0 To UBound(arr)
  25. If IsObject(arr(x)) Then
  26. Set result(x) = arr(x)
  27. Else
  28. result(x) = arr(x)
  29. End If
  30. Next
  31. CopyArray = result
  32. End Function
  33.  
  34. Function RandomNoDuplicates (iMin, iMax, iElements)
  35. 'this function will return array with "iElements" elements, each of them is random
  36. 'integer in the range "iMin"-"iMax", no duplicates.
  37.  
  38. 'make sure we won't have infinite loop:
  39. If (iMax-iMin+1)>iElements Then
  40. Exit Function
  41. End If
  42.  
  43. 'declare local variables:
  44. Dim RndArr(), x, curRand
  45. Dim iCount, arrValues()
  46.  
  47. 'build array of values:
  48. Redim arrValues(iMax-iMin)
  49. For x=iMin To iMax
  50. arrValues(x-iMin) = x
  51. Next
  52.  
  53. 'initialize array to return:
  54. Redim RndArr(iElements-1)
  55.  
  56. 'reset:
  57. For x=0 To UBound(RndArr)
  58. RndArr(x) = iMin-1
  59. Next
  60.  
  61. 'initialize random numbers generator engine:
  62. Randomize
  63. iCount=0
  64.  
  65. 'loop until the array is full:
  66. Do Until iCount>=iElements
  67. 'create new random number:
  68. curRand = arrValues(CLng((Rnd*(iElements-1))+1)-1)
  69.  
  70. 'check if already has duplicate, put it in array if not
  71. If Not(InArray(RndArr, curRand)) Then
  72. RndArr(iCount)=curRand
  73. iCount=iCount+1
  74. End If
  75.  
  76. 'maybe user gave up by now...
  77. If Not(Response.IsClientConnected) Then
  78. Exit Function
  79. End If
  80. Loop
  81.  
  82. 'assign the array as return value of the function:
  83. RandomNoDuplicates = RndArr
  84. End Function
  85.  
  86. Function InArray(arr, val)
  87. Dim x
  88. InArray=True
  89. For x=0 To UBound(arr)
  90. If arr(x)=val Then
  91. Exit Function
  92. End If
  93. Next
  94. InArray=False
  95. End Function
  96.  
  97. 'usage:
  98. Dim arrTest
  99. arrTest = Array(5, 8, 10, 15, 2, 30)
  100. Call Shuffle(arrTest)
  101. Response.Write(Join(arrTest, "<br />"))

Report this snippet  

You need to login to post a comment.