原题是:
本程序段的功能是重新排列数组a中元素的值,使相等元素值存放在一起,并且保持它们在数组中首次出现的相对次序.
例如:原数组:4,3,2,3,4,4,5,5,6,4,3,5,6
重排后:4,4,4,4,3,3,3,2,5,5,5,6,6书上给出一种解法如下:
原理是:先删去重复元素,再根据各元素在数组中出现的次数排列.
Dim n As Integer
Dim i As Integer, j As Integer, k As Integer, t As Integer, m As Integer
Dim a() As Integer, b() As Integer
n = 10
ReDim a(n), b(n)
a(1) = 1: a(2) = 2: a(3) = 4: a(4) = 3: a(5) = 3
a(6) = 3: a(7) = 2: a(8) = 1: a(9) = 4: a(10) = 5
m = 1
t = n
Do While m <= t
k = 1: i = m + 1
Do While i <= t
If a(i) = a(m) Then
k = k + 1
For j = i To t - 1
a(j) = a(j + 1)
Next j
t = t - 1
Else
i = i + 1
End If
Loop
b(m) = k: m = m + 1
Loop
t = n
For i = m - 1 To 1 Step -1
For j = 1 To b(i)
a(t) = a(i)
t = t - 1
Next j
Next i
For j = 1 To n
Print a(j)
Next j要求用另外一种解法解题,拜托各位大虾帮忙哦!
本程序段的功能是重新排列数组a中元素的值,使相等元素值存放在一起,并且保持它们在数组中首次出现的相对次序.
例如:原数组:4,3,2,3,4,4,5,5,6,4,3,5,6
重排后:4,4,4,4,3,3,3,2,5,5,5,6,6书上给出一种解法如下:
原理是:先删去重复元素,再根据各元素在数组中出现的次数排列.
Dim n As Integer
Dim i As Integer, j As Integer, k As Integer, t As Integer, m As Integer
Dim a() As Integer, b() As Integer
n = 10
ReDim a(n), b(n)
a(1) = 1: a(2) = 2: a(3) = 4: a(4) = 3: a(5) = 3
a(6) = 3: a(7) = 2: a(8) = 1: a(9) = 4: a(10) = 5
m = 1
t = n
Do While m <= t
k = 1: i = m + 1
Do While i <= t
If a(i) = a(m) Then
k = k + 1
For j = i To t - 1
a(j) = a(j + 1)
Next j
t = t - 1
Else
i = i + 1
End If
Loop
b(m) = k: m = m + 1
Loop
t = n
For i = m - 1 To 1 Step -1
For j = 1 To b(i)
a(t) = a(i)
t = t - 1
Next j
Next i
For j = 1 To n
Print a(j)
Next j要求用另外一种解法解题,拜托各位大虾帮忙哦!
解决方案 »
- [新手提问]菜单打勾.checked遇到的问题
- 在sql中,如果想将表t1字段d1的数值和t2字段d2下的数值全部复制到新表t3字段d3下(d1,d2和d3的类型一样,记录数不一样,表t3的记录数为0),这个语句应该怎么写啊??
- 璇烽棶濡備綍璇诲彇CPU娓╁害锛熶緥濡俶obmeter灏辫兘璇诲彇寰堝绉嶉厤缃紝杞欢鏈韩鎻愬強閭d箞灏忥紝搴旇鏄‖浠舵棤鍏崇殑
- 测试软件:Fantasia Photo 2.0 Beta1,BUG有分。(刚刚发贴有发现,没人关注VB图像处理类软件?这帖带了点资料)
- 请教关于DataGrid1、Adodc1更新的问题。
- 如何在设计时使自制控件font同时变化?
- Windows的传真功能或WinFax传真软件:发一个传真究竟如何收费?
- 做过outlook AddIn的高手请进
- 如何用vb6.0编写dll 文件 ?
- VB将access差异导入到mysql表中
- 请问VB+SQL 在VB中写数据库恢复 怎么写(内详)?? 谢谢
- 关于动态链接库(急救)
Dim msg As String
chongpai msg, 4, 3, 2, 3, 4, 4, 5, 5, 6, 4, 3, 5, 6
MsgBox msg
End Sub
Sub chongpai(ByRef out As String, ParamArray a())
Dim x As New Collection, y As New Collection, i As Long 'defineFor i = LBound(a) To UBound(a) 'add elements to collection x
x.Add a(i)
NextDo While Not x.Count = 0 ' do circle
y.Add x(1)
x.Remove 1
For i = x.Count To 1 Step -1
If x(i) = y(y.Count) Then
x.Remove i
y.Add y(y.Count)
End If
Next
LoopFor i = LBound(a) To UBound(a) ' copy results to an array
a(i) = y(i + 1 - LBound(a))
Nextout = Join(a, ",") ' output a string
Set x = Nothing
Set y = Nothing
End Sub
输入表:7 5 5 2 3 7 0 7 8 7 0 输入编码表:4 0 2 3 0 1 0 0 5 (输入数组最大值是多少,则该表就有多少个元素)
输出解码表:7 5 2 3 0 8
连续表:0 1 1 2 3 0 4 0 5 0 4
直方图:4 2 1 1 2 1 (记录连续表每个值出现的次数)以直方图产生的连续序列:0 0 0 0 1 1 2 3 4 4 5 解码后的不连续序列:7 7 7 7 5 5 2 3 0 0 8(最终结果)本算法优点是:不需要查找,计算量非常少,因此速度也非常快。缺点是对数组的最大绝对值(最大值减最小值的绝对值)有限制,需要消耗的内存空间和取值范围成正比。适合Integer以下类型或者预料取值范围小的场合。
该算法是小仙妹原创的一个算法,在我这里一种戏称“摆地摊算法”的变种——以适当空间换取速度的一种算法。Function ValueSort(ByRef pValues() As Long) As Long()
Dim tOutValues() As Long
Dim tOutValues_Index As Long
Dim tValues() As Long
Dim tInTable() As Long '输入编码表
Dim tInTable_Back() As Boolean '输入编码表底表
Dim tInTable_Index As Long '输入编码表索引
Dim tOutTable() As Long '输出解码表
Dim tSumTable() As Long '直方图
Dim tIndex As Long
Dim tIndex2 As Long
Dim tAddToInTable
Dim tInTableSum As Long
ReDim tInTable(0)
ReDim tInTable_Back(0)
ReDim tValues(UBound(pValues()))
For tIndex = 0 To UBound(pValues())
tInTable_Index = pValues(tIndex)
If UBound(tInTable()) < tInTable_Index Then
ReDim Preserve tInTable(tInTable_Index)
ReDim Preserve tInTable_Back(tInTable_Index)
End If
If Not tInTable_Back(tInTable_Index) Then
tInTable_Back(tInTable_Index) = True
tInTable(tInTable_Index) = tInTableSum
ReDim Preserve tOutTable(tInTableSum)
ReDim Preserve tSumTable(tInTableSum)
tOutTable(tInTableSum) = tInTable_Index
tInTableSum = tInTableSum + 1
End If
tValues(tIndex) = tInTable(tInTable_Index)
tSumTable(tValues(tIndex)) = tSumTable(tValues(tIndex)) + 1
Next
For tIndex = 0 To UBound(tSumTable())
For tIndex2 = 1 To tSumTable(tIndex)
ReDim Preserve tOutValues(tOutValues_Index)
tOutValues(tOutValues_Index) = tOutTable(tIndex)
tOutValues_Index = tOutValues_Index + 1
Next
Next
'ValueSort = tValues()
'ValueSort = tSumTable()
ValueSort = tOutValues()
End Function
Private Sub Command1_Click()
Dim tValues() As Long
Dim tValues2() As Long
ReDim tValues(1000000)
For tIndex = 0 To 100000
tValues(tIndex) = Int(Rnd * 10)
Next
'Text1.Text = ValuesGetString(tValues)
tOnTimer = Timer
tValues2() = ValueSort(tValues())
Text1.Text = Timer - tOnTimer
'Text2.Text = ValuesGetString(tValues2)
End Sub你可以看看计算1000000次需要多少时间(前提是取值范围要小,我这里取0到9之间。建议取值范围不超过65536。你如果取值在2000000000左右,别说内存,连硬盘都受不了!千万小心!)。
你好,很高兴又见到你的回帖,上次在某一个帖子里看到你提出的“跳虱算法”,觉得很新鲜有趣,而且也高效。昨晚看见你的回帖,又想起了那个算法,但在睡觉的时候,想着想着,却觉得“跳虱算法”在随机性方面好像会有一点点缺陷,今早一起来想找回那张帖子看看源代码是不是真有这个问题,却忘了叫什么名字,你能不能找回那张帖子?我过去那边向你请教。
借了楼主的宝地说了些与本帖无关的事,请楼主多多包涵谢谢。。
1、依次将数组的第i个元素与随机元素进行交换,可以获得一组随机不重复数列。
2、如果一个数组全部元素数量为M,将前N个元素(N<M)与随机元素交换,则前N个元素必定是随机不重复数列。由于以上算法(2)的特性,产生N个元素组成的随机不重复的序列只要N次。“摆地摊”算法是这样:
1、确定一组数字S()的最大值和最小值(这个值最好应当是已知的)。
2、定义一个“直方图表”P()(一个一维数组),该数组的元素数量为最大值与最小值的差。
3、将每个S()的元素减去最小值,然后对直方图表的第i个元素进行各种操作。
该算法可以替代某些需要查找的算法。比如:确定一个数组里每个元素出现的次数。针对一个值来说并没有优势,但是对于某些巨大的数组进行的一些操作有非常高效的用途。该算法典型用途是在图象处理领域。用途:
1、根据对照文件产生不同编码互相对应的解码、编码表。
2、统计数组中每个元素出现的次数。
3、将数组中的元素排序。(也可以用比较小的空间来存储一组特定情况的数据)
1、依次将数组的第i个元素与随机元素进行交换,可以获得一组随机不重复数列。
2、如果一个数组全部元素数量为M,将前N个元素(N<M)与随机元素交换,则前N个元素必定是随机不重复数列。
=============================================
例如,十个元素的数组1,2,3,4,5,6,7,8,9,10。将它们不重复地随机排列。。按照跳蚤算法,假如第一次取的数是3,之后就会将3的位置赋值为10,之后再取随机数,假如取得6,则会将6的位置取值为9,同时,每次取值后,都会将下次取随机数的范围减一。。如此不断循环直至取完数为之不知我有没有理解错???
而我的疑惑是这样的:
假如一个特殊的结果序列前几个数是:3,10,9,8,7,6,5。。如果按照常规方法,机会应该是604800分之一,但按照“跳蚤”算法,则需要每次取的随机数都等于3才行,但按照概率来说,随机数连续出现7次3的机会会不会比604800分之一更小?????
(3) (10) <1> 4 5 6 7 8 9 <2> - 10
(3) (10) (9) 4 5 6 7 8 <1> <2> - 93 10 9 8 5 6 7 4 1 2 - 83 10 9 8 7 6 5 3 1 2 - 73 10 9 8 7 6 5 3 1 2 - 63 10 9 8 7 6 5 3 1 2 - 5随机数:3 10 9 8 7 6 5
序列:3 10 9 8 7 6 5初步结论:如果随机数r总小于等于i;(i为当前正在操作元素的索引;r在合法取值范围内);且随机数序列本身不重复;则取得的序列和随机数序列是一样的。这是一种特殊情况,究竟是不是这样,还需要验证。如果真的成立,是一个很有趣的现象。1 2 3 4 5 6 7 8 9 10
如果随机数重复,比如连续得到两次随机数9
(9) 2 3 4 5 6 7 8 <1> 10 - 9
(9) (1) 3 4 5 6 7 8 <2> 10 - 9
(9) (3) (1) 4 5 6 7 8 <1> 10 - 2
(9) (4) (1) (3) 5 6 7 8 <2> 10 - 2随机数:9 9 2 2
得到序列:9 4 1 3你可以捕捉随机数,与产生的序列进行对比。
1 2 3 4 5 6 7 8 9 10,取这10个数的不重复随机排列,例如:4,7,9,3,6,2,1,10,5,8我的代码是这样的:
Private Sub Command1_Click()
Dim a(1 To 10) As Integer
Dim b(1 To 10) As Integer
Randomize
For i = 1 To 10
a(i) = i
Next
For k = 1 To 10
num = Int((11 - k) * Rnd + 1)
b(k) = a(num)
a(num) = a(11 - k)
Next
For j = 1 To 10
Print b(j)
Next
End Sub现在,我在考虑的,是一些比较特殊的结果序列,例如我上次提到的:"假如一个特殊的结果序列前几个数是:3,10,9,8,7,6,5。。如果按照常规方法,机会应该是604800分之一,但按照“跳蚤”算法,则需要每次取的随机数都等于3才行,但按照概率来说,随机数连续出现7次3的机会会不会比604800分之一更小?????"..意思是说,在上面的代码中,num头七次的随机取值都必须等于3,才可能出现这样的结果序列但不知道num头七次的随机取值等于3的几率是否等于常规取数取出这样序列的几率??(常规取数要取出这样的结果序列,几率好像是1/(10*9*8*7*6*5*4),即604800分之一)。。
按你上面所说的,你的算法跟代码都应该不一样。。但苦于找不到以前那张帖子,不能比较分析。
Private Sub Command1_Click()
Dim A() As Long
ReDim A(1 To 10) As Long
Dim I As Long
For I = 1 To 10
A(I) = I
Next
For I = 1 To 10
R = Int(Rnd * 10 + 1)
'R = 3
ValueSwap A(I), A(R)
Next
For I = 1 To 10
Text1.Text = Text1.Text & " " & CStr(A(I))
Next
End Sub每个元素都可能是交换目标:如果你想以数组B()取前A()的前N个元素出来,千万不要这样:
For I = 1 To N
R = Int(Rnd * 10 + 1)
ValueSwap A(I), A(R)
B(I)=A(I)
Next
一定要这样:
For I = 1 To N
R = Int(Rnd * 10 + 1)
ValueSwap A(I), A(R)
Next
For I = 1 To N
B(I)=A(I)
Next
因为A()中任何一个值,都可能是被交换的目标。交换次数的影响:如果你想取前3个,有两个选择:
标准算法
For I = 1 To 10
R = Int(Rnd * 10 + 1)
ValueSwap A(I), A(R)
Next
快速算法
For I = 1 To 3
R = Int(Rnd * 10 + 1)
ValueSwap A(I), A(R)
Next
取出前3个(假设如此,还可以直接用A(),只要保证别取第3个之后)
For I = 1 To 3
B(I)=A(I)
Next
标准算法和快速算法可以达到同一个目的,但是获得的结果不一样。
数列:3 3 3 3 3 3 3 3 3 3对应3 1 10 2 4 5 6 7 8 9 ,但产生3 1 10 2 4 5 6 7可能未必一定是序列3 3 3 3 3 3 3 3 3 3。多个不同的随机序列可能产生同一个不重复序列。因此,取得序列3 1 10 2 4 5 6 7 8 9与两个因素有关:1、产生3 3 3 3 3 3 3 3 3 3的几率
2、由3 3 3 3 3 3 3 3 3 3 序列产生3 1 10 2 4 5 6 7 8 9的几率。(因为3 1 10 2 4 5 6 7 8 9可能由其他序列产生)因此,产生3 1 10 2 4 5 6 7 8 9的几率和常数产生3 1 10 2 4 5 6 7 8 9的几率可能是不同的,具体情况或许更复杂。Private Sub Command1_Click()
Dim A() As Long
ReDim A(1 To 10) As Long
Dim I As Long
For I = 1 To 10
A(I) = I
Next
For I = 1 To 10
R = Int(Rnd * 10 + 1)
'R = 3
ValueSwap A(I), A(R)
Next
For I = 1 To 10
Text1.Text = Text1.Text & " " & CStr(A(I))
Next
End SubPrivate Sub Command2_Click()
Dim tA() As Long
Dim tR() As Long
ReDim tA(10)
ReDim tR(10)
For I = 0 To 10
tA(I) = I
tR(I) = Int(Rnd * 11)
Next
tA() = ArrayTaxisBySwapTable2(tA(), tR())
Text1.Text = ""
Text2.Text = ""
For I = 0 To 10
Text1.Text = Text1.Text & tA(I) & " "
Text2.Text = Text2.Text & tR(I) & " "
Next
End Sub'overlap
Function ArrayTaxisBySwapTable2(ByRef pArrays() As Long, ByRef pSwapTables() As Long) As Long()
'根据一组交换序列,从源序列获得一个随机不重复序列。
'
'参数:long pArrays() 源序列
' long pSwapTables() 交换序列(最大值<pArray的数量,元素数量允许大于pArrray的元素数量。)
'返回:long tOutArrays() 随机不重复序列。
Dim tOutArrays() As Long
Dim tArrays() As Long
Dim tArray_Length As Long
Dim tSwapTable_Length As Long
Dim tSwapIndex As Long
tArrays() = pArrays()
tSwapTable_Lenght = UBound(pSwapTables)
tArray_Length = UBound(tArrays())
For tIndex = 0 To tSwapTable_Lenght
tSwapIndex = pSwapTables(tIndex) Mod tArray_Length
ValueSwap tArrays(tIndex), tArrays(tSwapIndex)
Next
ReDim tOutArrays(tSwapTable_Lenght)
For tIndex = 0 To tSwapTable_Lenght
tOutArrays(tIndex) = tArrays(tIndex)
Next
ArrayTaxisBySwapTable2 = tOutArrays()
End FunctionFunction ArrayTaxisBySwapTable(ByRef pArrays() As Long, ByRef pSwapTables() As Long) As Long()
'根据一组交换序列,从源序列获得一个随机不重复序列。
'
'参数:long pArrays() 源序列
' long pSwapTables() 交换序列(最大值<pArray的数量,元素数量不大于pArrray的元素数量。)
'返回:long tOutArrays() 随机不重复序列。
Dim tOutArrays() As Long
Dim tArrays() As Long
Dim tSwapTable_Length As Long
tArrays() = pArrays()
tSwapTable_Lenght = UBound(pSwapTables)
For tIndex = 0 To tSwapTable_Lenght
ValueSwap tArrays(tIndex), tArrays(pSwapTables(tIndex))
Next
ReDim tOutArrays(tSwapTable_Lenght)
For tIndex = 0 To tSwapTable_Lenght
tOutArrays(tIndex) = tArrays(tIndex)
Next
ArrayTaxisBySwapTable = tOutArrays()
End FunctionSub ValueSwap(ByRef pA As Long, ByRef pB As Long)
Dim tT As Long
tT = pA: pA = pB: pB = tT
End Sub
Private Sub Command1_Click()
'你的方法
Dim t As Date
Randomize
Dim a() As Long
ReDim a(1 To 10000000) As Long
Dim I As Long
t = Now
For I = 1 To 10000000
a(I) = I
Next
For I = 1 To 10000000
R = Int(Rnd * 10000000 + 1)
'R = 3
ValueSwap a(I), a(R)
Next
Text1.Text = DateDiff("s", t, Now)
'For I = 1 To 10
' Text1.Text = Text1.Text & " " & CStr(A(I))
' Next
End SubSub ValueSwap(ByRef pA As Long, ByRef pB As Long)
Dim tT As Long
tT = pA: pA = pB: pB = tT
End Sub
Private Sub Command2_Click()
'我的方法
Dim a(1 To 10000000) As Long
Dim b(1 To 10000000) As Long
Dim t As Date
Randomize
t = Now
For I = 1 To 10000000
a(I) = I
Next
For k = 1 To 10000000
num = Int((10000001 - k) * Rnd + 1)
b(k) = a(num)
a(num) = a(10000001 - k)
NextText1.Text = DateDiff("s", t, Now)
'For j = 1 To 10
'Print b(j)
'Next
End Sub用你的方法大约要16秒,而我的方法大约要20秒。
我再看看ArrayTaxisBySwapTable、ArrayTaxisBySwapTable2是干什么用的
再一次感谢你
ArrayTaxisBySwapTable函数,交换数组的长度小于或者等于被交换数组的长度。
ArrayTaxisBySwapTable2函数,原设计是:交换数组的长度可以大于被交换数组的长度。但后来发现该函数有一个位置有缺陷。缺陷在下面的语句:For tIndex = 0 To tSwapTable_Lenght
tOutArrays(tIndex) = tArrays(tIndex)
Next如果交换数组大于被交换的数组,则上述代码会出错。可以在上面的语句前加一个判断:If tSwapTable_Lenght>UBound(tArray) Then tSwapTable_Lenght=UBound(tArray)区别在于:ArrayTaxisBySwapTable2被交换数组的索引是经过与tArrays的最大下标取余的,因此,即使tIndex>tArrays的下标界限也不会出错。ArrayTaxisBySwapTable函数:ValueSwap tArrays(tIndex), tArrays(pSwapTables(tIndex))ArrayTaxisBySwapTable2函数:
(原程序该行和上一行两句都写错了!这才是正确的)
ValueSwap tArrays(tIndex Mod tArray_Length), tArrays(pSwapTables(tIndex))如果是“跳蚤算法”,则是这样:ArrayTaxisBySwapTable不是随机数,而是一个数组。
ValueSwap tArrays(tIndex), tArrays(Int(rnd*UBound(tArrays)+1))pSwapTables()里任何一个值不能大于pArrays()的最大下标,也就是小于等于UBound(pArrays)。同时,该函数假设pArrays()从0开始。