魔方吧·中文魔方俱乐部

 找回密码
 注册
搜索
热搜: 魔方
查看: 1200|回复: 7

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

Rank: 4

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

亚洲纪录(AsR) 六年元老

发表于 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




[ 本帖最后由 jimofc 于 2012-1-20 22:05 编辑 ]
新建位图图像.jpg

尺子刻度问题 BY JIMO.zip

11.51 KB, 下载次数: 6

尺子刻度问题VBP工程源文件.zip

3.67 KB, 下载次数: 4

已有 1 人评分经验 收起 理由
mrmnm + 10 热情回复

总评分: 经验 + 10   查看全部评分

Rank: 7Rank: 7Rank: 7

积分
1106
帖子
739
精华
2
UID
103922

论坛建设奖 魔方结构大师 四年元老

发表于 2012-1-15 20:46:39 |显示全部楼层
有心了~~

使用道具 举报

Rank: 7Rank: 7Rank: 7

积分
3021
帖子
2406
精华
14
UID
12269
性别

智力游戏设计大师 八年元老

发表于 2012-1-15 23:36:56 |显示全部楼层
如果原题改成:23厘米,6个刻度。不知是否有解?
鲁班锁吧http://tieba.baidu.com/f?kw=%C2%B3%B0%E0%CB%F8

使用道具 举报

Rank: 1

积分
172
帖子
141
精华
0
UID
110785
性别
保密
发表于 2012-1-17 11:02:39 |显示全部楼层
原帖由 钟七珍 于 2012-1-15 23:36 发表
如果原题改成:23厘米,6个刻度。不知是否有解?

1,3,6,6,2,3,2

使用道具 举报

红魔

All Blue

Rank: 4

积分
1196
帖子
999
精华
2
UID
38845
性别
发表于 2012-1-19 22:30:39 |显示全部楼层
8秒不是很理想嘛...看來不是P問題
公式D F2 U L2 U B2 U R2 U R' F2 R L U L' R' U R L' U L U L U2 L' U' L U2 L'
数列11121131221231321332223233311

使用道具 举报

Rank: 4

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

亚洲纪录(AsR) 六年元老

发表于 2012-1-20 22:07:38 |显示全部楼层

回复 3# 的帖子

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

使用道具 举报

Rank: 7Rank: 7Rank: 7

积分
3021
帖子
2406
精华
14
UID
12269
性别

智力游戏设计大师 八年元老

发表于 2012-1-23 15:24:02 |显示全部楼层
  谢谢楼主提供的解法程序!!
  使用楼主编码的程序,我输入长度为29,刻度数为7,得到了三个解。从9之后,13、17、23、29均是质数。不知下一个最大长度是否为37!
  我输入长度36,刻度数8。运行后显示:内存不足!?未能得出结果。
  再次谢谢楼主!编制的程序!
鲁班锁吧http://tieba.baidu.com/f?kw=%C2%B3%B0%E0%CB%F8

使用道具 举报

Rank: 7Rank: 7Rank: 7

积分
3021
帖子
2406
精华
14
UID
12269
性别

智力游戏设计大师 八年元老

发表于 2012-1-23 16:22:41 |显示全部楼层
  将楼主程序的“数组内存分配数”增大为74,重新运行了一遍程序,大约花了四、五十分钟,得出:36长度、8个刻度,只有一个解:1,2,3,7,7,7,4,4,1。
  看来,长度为37、8个刻度不可能有解了。
鲁班锁吧http://tieba.baidu.com/f?kw=%C2%B3%B0%E0%CB%F8

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

Archiver|手机版|魔方吧·中文魔方俱乐部

GMT+8, 2024-3-29 14:05

Powered by Discuz! X2

© 2001-2011 Comsenz Inc.

回顶部