查看: 1676|回复: 7

【更新源码】N厘米长尺子刻度问题的解及我写的求解程序 [复制链接]

jimofc

红魔

Rank: 4

积分: 1370
帖子: 1033
精华: 11
UID: 96089
WCA ID: 2010JIMO01
兴趣爱好: 破解

电梯直达

1^#

发表于 2012-1-15 14:31:09 |只看该作者 |倒序浏览

不含镜像有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