魔方吧·中文魔方俱乐部

标题: 【更新源码】N厘米长尺子刻度问题的解及我写的求解程序 [打印本页]

作者: jimofc 时间: 2012-1-15 14:31:09 标题: 【更新源码】N厘米长尺子刻度问题的解及我写的求解程序

不含镜像有12组解，6个刻度也是有解情况下最少的刻度。1115554，这也是比较容易得到的解法，剩下的解法1185331.1229161.1237441.1266412.1317262.1335811.1447321.1513822.1537222.1619122.1619221。程序有两个版本，标准版求解速度快，求解这个(22，6)问题用了8秒，debug版可以即时显示分割、计算、判断的过程，但速度慢，算(22，6)用了三分钟。至于程序和源码等有机会用电脑上网再发…程序还可以优化，应该能更快的

这个程序又修改了一部分算法，运算（22,6）的速度由8秒提高到了1秒。

发现了一个可能出现重复解得BUG,重新计算得到（22,6）有9组解：
1,6,1,9,1,2,2
1,5,3,7,2,2,2
1,5,1,3,8,2,2
1,3,1,7,2,6,2
1,2,6,6,4,1,2
1,2,3,7,4,4,1
1,2,2,9,1,6,1
1,1,8,5,3,3,1
1,1,1,5,5,5,4

计算（17,5）得到6组解：
1,7,3,2,2,2
1,3,6,2,3,2
1,1,6,4,3,2
1,1,6,4,2,3
1,1,4,4,4,3
1,1,1,5,5,4
与之前的17厘米那道题含镜像的12组解一致。

程序源码：

Dim r As Variant
Dim dd() As Boolean
Dim h, e_s As Integer
Dim en As Boolean
Dim sum, sq, wt As Integer
Dim qwe, ewq As String
Dim xx() As String

Private Sub Check2_Click()
PB1.Visible = Check2.Value
PB1.Enabled = PB1.Enabled
End Sub

Private Sub Command1_Click()
PB1.Value = 0
Text3.Text = ""
sq = 0
wt = 0
Label5.Caption = "???"
AutoRedraw = True
Dim M As Integer, L As Integer
Dim mp() As Integer
Dim s(), ss(), x As Integer
Dim sp, i, j As Long
Dim nsp As Double
Dim a, d
Dim b() As Variant
x = Val(Text1.Text) - 3
ReDim a(x)
ReDim xx(Slider1.Value * 50)
L = UBound(a)
For i = 0 To L
a(i) = i
Next i
M = Val(Text2.Text) - 1
If M > L + 1 Then
MsgBox "刻度数量不能超过" & L + 1
Exit Sub
End If
ReDim mp(M - 1)
nsp = 1
For i = 1 To M
nsp = nsp * (L + 2 - i)
nsp = nsp / (M + 1 - i)
Next
ReDim s(CLng(nsp))
ReDim ss(CLng(nsp), M + 1)
For i = 0 To M - 1
mp(i) = i
s(0) = s(0) & a(mp(i))
ss(0, i + 1) = a(mp(i))
Next
If M + 1 + 1 >= x + 3 - M - 1 Then
sq = sq + 1
For i = 1 To M + 1
Text3.Text = Text3.Text & "1,"
Next
Text3.Text = Text3.Text & Trim(Str(x - M + 2)) & vbCrLf
End If
sp = 1
Do Until arrM(mp, M, L) = False
DoEvents
For i = 0 To M - 1
s(sp) = s(sp) & a(mp(i)) & ","
ss(sp, i + 1) = a(mp(i))
Next

qwe = "1,"
qwe = qwe & Trim(Str(Val(ss(sp, 1)) + 1)) & ","
For iii = 3 To M + 1
qwe = qwe & Trim(Str(Val(ss(sp, iii - 1)) - Val(ss(sp, iii - 2)))) & ","
Next iii
qwe = qwe & Trim(Str(x - Val(ss(sp, M)) + 1))
If Check1.Value = 1 Then
Text6.Text = qwe
Call Command2_Click
Else
Call Command3_Click
End If
If en Then

For iii = 1 To wt
If qwe = xx(iii) Then qwe = ""
Next iii
If Right(qwe, 1) = "1" Then
wt = wt + 1
ewq = "1"
ewq = Trim(Str(Val(ss(sp, 1)) + 1)) & "," & ewq
For iii = 3 To M + 1
ewq = Trim(Str(Val(ss(sp, iii - 1)) - Val(ss(sp, iii - 2)))) & "," & ewq
Next iii
ewq = Trim(Str(x - Val(ss(sp, M)) + 1)) & "," & ewq
xx(wt) = ewq
End If
If qwe <> "" Then
sq = sq + 1
Text3.Text = Text3.Text + qwe + vbCrLf
End If
End If
sp = sp + 1
PB1.Value = Int(sp / nsp * 100)
Loop
Label5.Caption = Str(sq)
End Sub

Function arrM(mp() As Integer, M As Integer, L As Integer) As Boolean
Dim i As Integer, j As Integer
mp(M - 1) = mp(M - 1) + 1
For i = M - 1 To 0 Step -1
If mp(i) > L - (M - 1) + i Then
If i = 0 Then
arrM = False
Exit Function
End If
mp(i - 1) = mp(i - 1) + 1
For j = i To M - 1
mp(j) = mp(j - 1) + 1
Next
End If
Next
arrM = True
End Function

Private Sub Command2_Click()
Text5.Text = ""
r = Split(Text6.Text, ",")
h = UBound(r)
ReDim dd(100) As Boolean
For ii = 1 To h + 1
For jj = 0 To h - ii + 1
e_s = 0
      For kk = 1 To ii
      e_s = e_s + Val(r(jj + kk - 1))
      Next kk
Text5.Text = Text5.Text + Str(e_s) + ","
dd(e_s) = True
Next jj
Text5.Text = Text5.Text + vbCrLf
Next ii
Text4.Text = ""
en = True
For ii = 1 To e_s
Text4.Text = Text4.Text + Str(ii) + "=" + Str(dd(ii)) + vbCrLf
en = en And dd(ii)
Next ii
If en Then Text4.Text = Text4.Text + "满足条件" Else Text4.Text = Text4.Text + "不满足条件"
End Sub

Private Sub Command3_Click()
r = Split(qwe, ",")
h = UBound(r)
ReDim dd(100) As Boolean
For ii = 1 To h + 1
For jj = 0 To h - ii + 1
e_s = 0
      For kk = 1 To ii
      e_s = e_s + Val(r(jj + kk - 1))
      Next kk
dd(e_s) = True
Next jj
Next ii
en = True
For ii = 1 To e_s
en = en And dd(ii)
Next ii
End Sub

[ 本帖最后由 jimofc 于 2012-1-20 22:05 编辑 ]

附件: 新建位图图像.jpg (2012-1-20 21:07:07, 132.58 KB) / 下载次数 54
http://bbs.mf8-china.com/forum.php?mod=attachment&aid=MTcxNjQ3fGIxMmViNjhhfDE3MzMxNTkxMzh8MHww

附件: 尺子刻度问题 BY JIMO.zip (2012-1-20 21:07:07, 11.51 KB) / 下载次数 6
http://bbs.mf8-china.com/forum.php?mod=attachment&aid=MTcxNjQ4fDE1NjZmODBlfDE3MzMxNTkxMzh8MHww

附件: 尺子刻度问题VBP工程源文件.zip (2012-1-20 21:07:07, 3.67 KB) / 下载次数 4
http://bbs.mf8-china.com/forum.php?mod=attachment&aid=MTcxNjQ5fDc2NTdiNDJmfDE3MzMxNTkxMzh8MHww

作者: mrmnm 时间: 2012-1-15 20:46:39

有心了~~

作者: 钟七珍 时间: 2012-1-15 23:36:56

如果原题改成：23厘米，6个刻度。不知是否有解？

作者: mowxqq 时间: 2012-1-17 11:02:39

原帖由 钟七珍 于 2012-1-15 23:36 发表
如果原题改成：23厘米，6个刻度。不知是否有解？

1，3，6，6，2，3，2

作者: 骰迷 时间: 2012-1-19 22:30:39

8秒不是很理想嘛...看來不是P問題

作者: jimofc 时间: 2012-1-20 22:07:38 标题: 回复 3# 的帖子

23,6只有两解：
1,3,6,6,2,3,2
1,1,9,4,3,3,2

作者: 钟七珍 时间: 2012-1-23 15:24:02

　　谢谢楼主提供的解法程序！！
　　使用楼主编码的程序，我输入长度为２９，刻度数为７，得到了三个解。从９之后，１３、１７、２３、２９均是质数。不知下一个最大长度是否为３７！
　　我输入长度３６，刻度数８。运行后显示：内存不足！？未能得出结果。
　　再次谢谢楼主！编制的程序！

作者: 钟七珍 时间: 2012-1-23 16:22:41

　　将楼主程序的“数组内存分配数”增大为７４，重新运行了一遍程序，大约花了四、五十分钟，得出：３６长度、８个刻度，只有一个解：1,2,3,7,7,7,4,4,1。
　　看来，长度为３７、８个刻度不可能有解了。

欢迎光临魔方吧·中文魔方俱乐部 (http://bbs.mf8-china.com/)