[分享]我参与18期竞赛题后写的一个编程经验总结

qygds · 发表于 2006-12-25 21:44

这个看不明白，但楼主真的用心做了佩服

山山好又快 · 发表于 2011-10-14 14:54

下来学习。

香川群子 · 发表于 2011-10-14 15:40

本帖最后由香川群子于 2011-10-14 16:12 编辑

有趣。

说一下我的思路：
1. 逐个检查数值，如果是>2的数值，并且它的前面是【空值，或0，或>2】，则可以马上置换成字母。
2. 余下数值用递归法组合后置换。

下面是第一步的预处理代码。

如果没有1、2数字出现的话，到这里就已经结束置换，直接输出结果了。

Sub codecombin()
Randomize
[a1] = Int(10 ^ (Rnd() * 10))
s = "0" & [a1]
l = Len(s)
t = Left(s, 1)
For i = 2 To l
t0 = t
t = Mid(s, i, 1)
If t > "2" Then
If t0 > "2" Or t0 = "0" Then
s = Left(s, i - 1) & Chr(64 + Val(t)) & Right(s, l - i)
End If
ElseIf t = 0 Then
If t0 = "1" Or t0 = "2" Then
Else
s = Left(s, i - 1) & " " & Right(s, l - i)
End If
End If
Next
s = Replace(Mid(s, 2), " ", "")
[a2] = s
End Sub

复制代码

香川群子 · 发表于 2011-10-14 21:38

本帖最后由香川群子于 2011-10-15 00:44 编辑

winland 发表于 2006-12-25 12:41
我把我的递归方法改了一下, 用上了数组, 速度也快了很多, 23个1大概两到三秒.

我自己写的递归迭代方法，23个1 ，光计算是0.6秒，连写入单元格是2.8秒。而楼主最快的第6稿代码在我的机子上是8.14秒。
因此，显然比楼主的代码快多了。

Public brr(), k As Long
Sub codecombin()
[c2] = Timer
Randomize
[a:b].Clear
s = Int(10 ^ (Rnd() * 10))
Do
l = InStr(s, 0)
If l = 0 Then Exit Do
t = Mid(s, l - 1, 1)
If t > "2" Or t = " " Then
s = Left(s, l - 1) & Mid(s, l + 1)
Else
s = Left(s, l - 1) & "o" & Mid(s, l + 1)
End If
Loop
s = Replace(s, "o", 0)
'以上为得到随机数值，并检查、去掉不合理和多余的0
' s = String(23, "1") '最大23个重复1的检测
' s = "6" '调试bug
[a1] = "' " & s
[c1] = Timer
If Len(s) = 1 Then
s = Chr(64 + Val(s))
[a2] = s
[b2] = CodeChk(s)
[c1] = Timer - [c1]
[c2] = Timer - [c2]
Exit Sub
End If
'以上为一位数值时直接转换为字母并结束。
s = " " & s & " "
l = Len(s)
t = Left(s, 1)
For i = 2 To l - 2
t0 = t
t = Mid(s, i, 1)
If t = "0" Then
s = Left(s, i - 2) & " " & Chr(64 + Val(Mid(s, i - 1, 2))) & Right(s, l - i)
ElseIf t = "1" Then
If t0 = " " Or t0 = "0" Or t0 > "2" Then
If Mid(s, i + 2, 1) = "0" Or Mid(s, i + 1, 2) = " " Then
s = Left(s, i - 1) & "A" & Right(s, l - i)
' s = Left(s, i - 1) & Chr(64 + Val(t)) & Right(s, l - i)
End If
End If
ElseIf t = "2" Then
If t0 = " " Or t0 = "0" Or t0 > "2" Then
If Mid(s, i + 1, 1) > "6" Or Mid(s, i + 2, 1) = "0" Or Mid(s, i + 1, 2) = " " Then
s = Left(s, i - 1) & "B" & Right(s, l - i)
' s = Left(s, i - 1) & Chr(64 + Val(t)) & Right(s, l - i)
End If
End If
ElseIf t > "2" Then
If t0 = " " Or t0 = "0" Or t0 > "2" Or (t0 = "2" And t > "6") Then
s = Left(s, i - 1) & Chr(64 + Val(t)) & Right(s, l - i)
End If
End If
Next
'以上为检查各数值，如无分歧则直接转换为字母。
s = Replace(Mid(s, 2), " ", "")
[a2] = s
n1 = InStr(s, 1): n2 = InStr(s, 2)
If n1 * n2 Then
If n1 < n2 Then t = n1 Else t = n2
Else
t = n1 + n2
End If
'以上为检查转换结果中是否还含有数字1或2。
If t = 0 Then
[b2] = CodeChk(s)
[c1] = Timer - [c1]
[c2] = Timer - [c2]
Exit Sub
End If
'以上为，检查结果中已经不含1或2时，肯定没有分歧了，可以直接输出转换字母结果。
k = 0
ReDim brr(1 To 65536, 1 To 2)
dg s, t
'开始递归过程……
[c1] = Timer - [c1]
'递归结束，已经得到储存在数组brr中的最终结果。
s = "'" & [a1]
For i = 1 To k
brr(i, 2) = CodeChk(brr(i, 1))
If brr(i, 2) <> s Then
MsgBox "Err"
End If
Next
'以上为对转换字母结果逐一确认，再转换为数值时是否相同。
[a2].Resize(k, 2) = brr 'WorksheetFunction.Transpose(brr)
[c2] = Timer - [c2]
'以上为把数组brr中的最终结果输出到工作表，结束。
End Sub
Sub dg(A, n)
b = Mid(A, n, 1)
If IsNumeric(b) Then
If b > "2" Then
A = Left(A, n - 1) & Chr(64 + Val(b)) & Right(A, Len(A) - n)
' ElseIf b = "0" Then
' A = Left(A, n - 1) & Right(A, Len(A) - n)
Else
a1 = Left(A, n - 1) & Chr(64 + Val(b)) & Right(A, Len(A) - n)
If n < Len(a1) Then
dg a1, n + 1
Else
k = k + 1
brr(k, 1) = a1
Exit Sub
End If
If IsNumeric(Mid(A, n + 1, 1)) Then
a2 = Left(A, n - 1) & Chr(64 + Val(Mid(A, n, 2))) & Right(A, Len(A) - n - 1)
For i = n + 1 To Len(a2)
If IsNumeric(Mid(a2, i, 1)) Then
dg a2, i
Exit Sub
End If
Next
k = k + 1
brr(k, 1) = a2
End If
Exit Sub
End If
End If
n1 = InStr(A, 1): n2 = InStr(A, 2)
If n1 * n2 Then
If n1 < n2 Then t = n1 Else t = n2
Else
t = n1 + n2
If t = 0 Then
k = k + 1
brr(k, 1) = A
Exit Sub
End If
End If
dg A, t
End Sub
Function CodeChk(A)
t = "' "
For i = 1 To Len(A)
t = t & Asc(Mid(A, i, 1)) - 64
Next
CodeChk = t
End Function

复制代码

香川群子 · 发表于 2011-10-14 21:44

本帖最后由香川群子于 2011-10-15 00:43 编辑

这个，实际上是我第一次独立写递归迭代的过程代码。

很有纪念意义地说。

下面是递归过程代码。

Sub dg(A, n)
b = Mid(A, n, 1)
If IsNumeric(b) Then
If b > "2" Then
A = Left(A, n - 1) & Chr(64 + Val(b)) & Right(A, Len(A) - n)
' ElseIf b = "0" Then
' A = Left(A, n - 1) & Right(A, Len(A) - n)
Else
a1 = Left(A, n - 1) & Chr(64 + Val(b)) & Right(A, Len(A) - n)
If n < Len(a1) Then
dg a1, n + 1
Else
k = k + 1
brr(k, 1) = a1
Exit Sub
End If
If IsNumeric(Mid(A, n + 1, 1)) Then
a2 = Left(A, n - 1) & Chr(64 + Val(Mid(A, n, 2))) & Right(A, Len(A) - n - 1)
For i = n + 1 To Len(a2)
If IsNumeric(Mid(a2, i, 1)) Then
dg a2, i
Exit Sub
End If
Next
k = k + 1
brr(k, 1) = a2
End If
Exit Sub
End If
End If
n1 = InStr(A, 1): n2 = InStr(A, 2)
If n1 * n2 Then
If n1 < n2 Then t = n1 Else t = n2
Else
t = n1 + n2
If t = 0 Then
k = k + 1
brr(k, 1) = A
Exit Sub
End If
End If
dg A, t
End Sub

复制代码

香川群子 · 发表于 2011-10-15 00:41

前面代码中，加入一段，去掉了随机产生数中不合理的、多余的0

s = Int(10 ^ (Rnd() * 10))
Do
l = InStr(s, 0)
If l = 0 Then Exit Do
t = Mid(s, l - 1, 1)
If t > "2" Or t = " " Then
s = Left(s, l - 1) & Mid(s, l + 1)
Else
s = Left(s, l - 1) & "o" & Mid(s, l + 1)
End If
Loop
s = Replace(s, "o", 0)

复制代码

最后，增加了一个检查所得字母按密码转换的结果，可以判断所得字母是否正确。、

Function CodeChk(A)
t = "' "
For i = 1 To Len(A)
t = t & Asc(Mid(A, i, 1)) - 64
Next
CodeChk = t
End Function

复制代码

请看附件。

或许还可以再优化一点。

香川群子 · 发表于 2011-10-15 20:25

本帖最后由香川群子于 2011-10-15 20:42 编辑

前面的递归，是对数字的计算，查找、判断后把数值置换为相应字母。

下面重新写了一个代码，做法是先把数值全部转化为标准字母，
然后，对于含"A"和"B"字母的部分，再作二次迭代置换。

虽然速度上改进不大，但是代码相当简洁好读了。

Public brr() As String, d, k As Long
Sub CodeRp()
tms = Timer
[g2].CurrentRegion.Clear '清空将要输出数据的区域
s = [e1] '获取要置换的数值
s = Replace(s, 10, "J") '先把10置换为J
s = Replace(s, 20, "T") '再把20置换为T
s = Replace(s, 0, "") '如果还有多余的0，去除。
For i = 1 To 9
s = Replace(s, i, Chr(i + 64)) '把1-9，分别置换为A,B,C,D,E,F,G,H,I的字母。
Next
[g1] = s '这样，已经得到了最标准的一个置换答案的文字列了。
If InStr(s, "A") + InStr(s, "B") Then '检查如果该文字列还含有A或B字符，则需要二次置换。
Set d = CreateObject("Scripting.Dictionary") '首先设置二次置换用的置换规则词典
For i = 1 To 9 '字典中加入AA,AB,AC,AD,AE,AF,AG,AH,AI 共9个单词，对应置换结果为K,L,M,N,O,P,Q,R,S
d("A" & Chr(i + 64)) = Chr(10 + i + 64)
Next
For i = 1 To 6 '字典中加入BA,BB,BC,BD,BE,BF 共6个单词，对应置换结果为U,V,W,X,Y,Z
d("B" & Chr(i + 64)) = Chr(20 + i + 64)
Next
ReDim brr(1 To 65536) As String '定义结果数组brr
k = 1: brr(k) = s '加入第一标准置换结果。（含未置换的A,B字符）
rp s, 1 '调用迭代递归过程代码rp，第一参数为需要检查置换的对象文字列s，第二参数为检查起始位置n=1。
End If
[g2].Resize(k) = WorksheetFunction.Transpose(brr) '输出数组brr结果到工作表。
End Sub

复制代码

上面是过程主代码，下面是递归(迭代)过程代码，做法相当简单。

Sub rp(t, n) '对文字列t，从第n个字符开始检查置换，直至最后
For i = n To Len(t) - 1 '检查开始字符n 会随着迭代计算过程的进行而改变
If Mid(t, i, 1) = "A" Or Mid(t, i, 1) = "B" Then '从n开始逐个检查字符，如果有A或B则需要检查
If d.Exists(Mid(t, i, 2)) Then '检查如果该字符即后面的2个字符符合置换条件（即在词典中存在）
t1 = Left(t, i - 1) & d(Mid(t, i, 2)) & Mid(t, i + 2) '则按字典规则置换
k = k + 1: brr(k) = t1 '置换结果写入结果数组brr
If InStr(t1, "A") + InStr(t1, "B") Then '接着检查确认新的文字列t1中，是否还含有A或B需要置换
rp t1, i + 1 '如果含有A或B，则使用迭代过程继续进行递归计算。
End If
End If
End If
Next '检查所有字符直至结束
End Sub

复制代码

香川群子 · 发表于 2011-10-15 22:43

本帖最后由香川群子于 2011-10-15 22:48 编辑

4种代码比较：

6楼winland 递归置换代码速度最快。
唯一缺点是对0的处理尚存bug。

我14楼贴出的数值递归置换代码与之相对应，
速度稍慢，但解决了0的问题。

上面二个代码，得到的最后结果，很自然就已经是按照A-Z排序的结果了。
呵呵。这个大概是因为置换顺序本来就是升序的。

而我17楼的按字母方式递归置换代码，
速度稍快些，但仍不及6楼winland的效率高。

但是有一个显而易见的优点，代码简洁易懂。尤其是递归部分，简单到不能再简单了吧。

但是，带来的一个后果，所有组合结果的顺序，并不是A-Z从小到大升序排列，而是比较乱。
原因当然是置换规则造成的啦。

最后，是楼主2006年的代码。

虽然一再改进，但因为是在一个过程内反复检查循环，所以速度和递归无法比，大约要慢20倍。
估计无法进一步改善了。（因为重复检查实际上相当多。）

最后是结果排序方面，也是比较乱的。

香川群子 · 发表于 2011-10-15 23:16

现在又发现新情况。

在做随机测试时，发现楼主的代码有严重缺陷……漏数据。

测试: 1398213134 时，应该有12个结果：
ACIHBACACD
ACIHBACMD
ACIHBMACD
ACIHBMMD
ACIHUCACD
ACIHUCMD
MIHBACACD
MIHBACMD
MIHBMACD
MIHBMMD
MIHUCACD
MIHUCMD

但楼主代码只有7个：
ACIHBACACD
MIHBACACD
ACIHUCACD
MIHBMACD
MIHUCACD
MIHBMMD
MIHUCMD

少了最后置换的5个：
ACIHBACMD
ACIHBMACD
ACIHBMMD
ACIHUCMD
MIHBACMD

…………
然后，用123123123
以及121212等数据做检查，再次发现同样的缺漏。

并且，我检查了楼主所有6个稿，
最后结论，很不幸地，楼主的6个稿，结果都存在这样的严重缺陷。

只能不及格了。

呵呵。

请看附件，4种代码都放进去了，可以比较一下。

香川群子 · 发表于 2011-10-19 10:36

初步确认，楼主的代码，能够处理111111……

但不能处理222222……的转化。

详细原因待确认。

		自动登录	找回密码
密码			免费注册

[分享]我参与18期竞赛题后写的一个编程经验总结

评分

浏览过的版块