7,763
社区成员
发帖
与我相关
我的任务
分享刷子刷木头的问题。这是个算法问题。请大家指教。
有一根木头棍，有10000米长（总之是很长。）
我拿刷子沾墨汁，
第一次，把2米到4米处刷黑了。
第二次，把3米到7米处刷黑了。
第三次，把2米到8米处刷黑了。
第四次，把12米到15米处刷黑了。
。。。好多好多次。
大家看出来了吧，每次只刷一小段，没有规律，有交叉关系，有包含关系，总之很乱。
如果把每刷一次作为一条记录存入数据库，可以求出一共刷了多少次，累积刷了多少米。
但是，如何知道这根木头棍一共有多少米被刷黑了呢？
大家有什么简便高速的算法呢？
大家给个思想，或者能用VB（或VC或Delphi）给出代码就更好了。多谢多谢。
我拿刷子沾墨汁，
第一次，把2米到4米处刷黑了。
第二次，把3米到7米处刷黑了。
第三次，把2米到8米处刷黑了。
第四次，把12米到15米处刷黑了。
。。。好多好多次。
大家看出来了吧，每次只刷一小段，没有规律，有交叉关系，有包含关系，总之很乱。
如果把每刷一次作为一条记录存入数据库，可以求出一共刷了多少次，累积刷了多少米。
但是，如何知道这根木头棍一共有多少米被刷黑了呢？
大家有什么简便高速的算法呢？
大家给个思想，或者能用VB（或VC或Delphi）给出代码就更好了。多谢多谢。
...全文
请发表友善的回复…
发表回复
shuicaitian 2003-02-10
- 打赏
- 举报
再次感谢“小仙妹”的详细解释。
又一个问题。
想送分给你，表示感谢，怎么做呢？
我是新手，不大会玩。
又一个问题。
想送分给你，表示感谢，怎么做呢？
我是新手，不大会玩。
KiteGirl 2003-02-10
- 打赏
- 举报
表面上看是求实际刷墨长度，其实是求所有被刷墨的段的集合。下面是我的程序里所有函数的简单说明。
SegsViewToPictureBox 在图象上显示，但这个函数没有写完。
SegsViewToListBox 通过ListBox显示一个Segs数组。
SegAddToLine 将一个Seg覆盖(归并)到一个Segs()数组里，这个Segs数组用来记录所有有效的段。
SegsDelItem 在Segs数组里删除一个Seg，只是将它标记为空。
SegsAddItem 向Segs数组里添加一个Seg。值得注意的是数组不可以为空。至少要有个Segs(0)，让Segs(0).Disabled=True就可以了。
SegGetByRndSet 获得一个随机的段[Seg]。
ValueBigRight 保证是右侧变量大于左侧，反之则交换。
ValueSwap 交换两变量的值
最后说一点：在这个程序里，木头的长度限制取决于变量的最大限制。执行速度与木头的长度无关，而与每个刷子的距离以及刷子长度和刷上去的墨迹数量有间接关系。稍加修改可以兼容浮点数。
SegsViewToPictureBox 在图象上显示，但这个函数没有写完。
SegsViewToListBox 通过ListBox显示一个Segs数组。
SegAddToLine 将一个Seg覆盖(归并)到一个Segs()数组里，这个Segs数组用来记录所有有效的段。
SegsDelItem 在Segs数组里删除一个Seg，只是将它标记为空。
SegsAddItem 向Segs数组里添加一个Seg。值得注意的是数组不可以为空。至少要有个Segs(0)，让Segs(0).Disabled=True就可以了。
SegGetByRndSet 获得一个随机的段[Seg]。
ValueBigRight 保证是右侧变量大于左侧，反之则交换。
ValueSwap 交换两变量的值
最后说一点：在这个程序里，木头的长度限制取决于变量的最大限制。执行速度与木头的长度无关，而与每个刷子的距离以及刷子长度和刷上去的墨迹数量有间接关系。稍加修改可以兼容浮点数。
KiteGirl 2003-02-10
- 打赏
- 举报
有四种情况：首尾交叉两中、互相包含两种。
S是一个Seg新元素，N()是Seg的“有效集合”（千万注意，N(I)是有效的Seg集合，而不是全部的Seg集合。所谓有效的Seg集合就是合并后的、互不重合的所有Seg的集合。N()集合是合并操作后的产物，最后的结果将使N()集合只有一个从0 到 10000的元素）。
N(I).SegOn<=S.SegOn And N(I).SegEnd>=S.SegEnd
'S被包含在N(I)里。取消添加操作，因为S被N(I)覆盖了，N(I)已经包含了S。没有添加的必要了。这是首要条件。
直观表示是这样的：[SN]表示S和N重合的部分，下同]
NNNNNNNNNNNNNSNSNSNSNSNSNSNNNNNNNNNNNNNNNNNN
N(I).SegOn>=S.SegOn And N(I).SegEnd<=S.SegEnd
'S包含N(I)。直接删除掉N(I)就可以了。这是次要条件。
后面两个条件是并列条件，也就是说下面这两个条件不是排它的，而是可以同时产生的。
直观表示是这样的：[SN]表示S和N重合的部分，下同]
SSSSSSSSSSSSSSSNSNSNSNSNSNSSSSSSSSSSSSSS
N(I).SegOn<=S.SegOn And N(I).SegEnd>=S.SegOn
'S头部与N(I)的尾部有交叉或者相连接。让S.SegOn=N(I).SegOn，然后删除N(I)。这个时候的S.SegOn是不会与前面的任何一个N().SegOn元素重合，只要在序列里没有重合的Seg元素。实际上如果你从头开始一点点用这个办法Add到序列里是不会出现重合的Seg的。所以一次循环就可以，不用重新循环。
NNNNNNNNNNNNNNSNSNSNSNSSSSSSSSSSSSSSSSSS
N(I).SegOn>=S.SegOn And N(I).SegEnd>=S.SegEnd
'S尾部与N(I)的首部有交叉或者相连接。让S.SegEnd=N(I).SegEnd，然后删除掉N(I)。与前面一样，这个条件不用重新扫描N()集合。
SSSSSSSSSSSSSSSSSNSNSNSNSNNNNNNNNNNNNNNN
第一次，把2米到4米处刷黑了。S(1) 2 To 4
第二次，把3米到7米处刷黑了。S(2) 3 To 7
第三次，把2米到8米处刷黑了。S(3) 2 To 8
第四次，把12米到15米处刷黑了。S(4) 12 To 15
1、N(1)是无效的的。N(1).Disibled=True
2、S=S(1)。由于N(1)是无效的。扫描到最后没有有效元素，所以N(1)=S
3、S=S(2)。3<4 7>4 符合交叉条件，则 N(1)成为无效，S.On=2:S.End=7。扫描到最后，N(2)=S。
4、S=S(3)。2=2 8>7 符合覆盖条件。则 N(2)成为无效，N(3)=S
5、S=S(4)。不符合任何交叉覆盖条件。则N(4)=S。
最后是这样的：
N(1) 无效
N(2) 无效
N(3) 2 To 8
N(4) 12 To 15
至于计算长度我想就不用再提醒你了，只要把每个Seg的长度求和就可以了。
(8-2)=6
(15-12)=3
6+3=9
最后提醒你一下：S()才是所有段的全部集合，而N()只是“有效段”的集合，用来统计实际刷上的长度用的。而0 To 10000这根木头的长度与集合无关，仅仅是元素取值的问题。比如，我是用Int(rnd*10001)来取的随机数。后来为了使程序测试更有演示性采用Int(rnd*20)+(10000-20)这种办法使取得的短更小，增加程序工作的难度。毕竟真实的刷子刷一次的长度是有限的。而真实的刷子的长度其实更接近一个常量 。
S是一个Seg新元素，N()是Seg的“有效集合”（千万注意，N(I)是有效的Seg集合，而不是全部的Seg集合。所谓有效的Seg集合就是合并后的、互不重合的所有Seg的集合。N()集合是合并操作后的产物，最后的结果将使N()集合只有一个从0 到 10000的元素）。
N(I).SegOn<=S.SegOn And N(I).SegEnd>=S.SegEnd
'S被包含在N(I)里。取消添加操作，因为S被N(I)覆盖了，N(I)已经包含了S。没有添加的必要了。这是首要条件。
直观表示是这样的：[SN]表示S和N重合的部分，下同]
NNNNNNNNNNNNNSNSNSNSNSNSNSNNNNNNNNNNNNNNNNNN
N(I).SegOn>=S.SegOn And N(I).SegEnd<=S.SegEnd
'S包含N(I)。直接删除掉N(I)就可以了。这是次要条件。
后面两个条件是并列条件，也就是说下面这两个条件不是排它的，而是可以同时产生的。
直观表示是这样的：[SN]表示S和N重合的部分，下同]
SSSSSSSSSSSSSSSNSNSNSNSNSNSSSSSSSSSSSSSS
N(I).SegOn<=S.SegOn And N(I).SegEnd>=S.SegOn
'S头部与N(I)的尾部有交叉或者相连接。让S.SegOn=N(I).SegOn，然后删除N(I)。这个时候的S.SegOn是不会与前面的任何一个N().SegOn元素重合，只要在序列里没有重合的Seg元素。实际上如果你从头开始一点点用这个办法Add到序列里是不会出现重合的Seg的。所以一次循环就可以，不用重新循环。
NNNNNNNNNNNNNNSNSNSNSNSSSSSSSSSSSSSSSSSS
N(I).SegOn>=S.SegOn And N(I).SegEnd>=S.SegEnd
'S尾部与N(I)的首部有交叉或者相连接。让S.SegEnd=N(I).SegEnd，然后删除掉N(I)。与前面一样，这个条件不用重新扫描N()集合。
SSSSSSSSSSSSSSSSSNSNSNSNSNNNNNNNNNNNNNNN
第一次，把2米到4米处刷黑了。S(1) 2 To 4
第二次，把3米到7米处刷黑了。S(2) 3 To 7
第三次，把2米到8米处刷黑了。S(3) 2 To 8
第四次，把12米到15米处刷黑了。S(4) 12 To 15
1、N(1)是无效的的。N(1).Disibled=True
2、S=S(1)。由于N(1)是无效的。扫描到最后没有有效元素，所以N(1)=S
3、S=S(2)。3<4 7>4 符合交叉条件，则 N(1)成为无效，S.On=2:S.End=7。扫描到最后，N(2)=S。
4、S=S(3)。2=2 8>7 符合覆盖条件。则 N(2)成为无效，N(3)=S
5、S=S(4)。不符合任何交叉覆盖条件。则N(4)=S。
最后是这样的：
N(1) 无效
N(2) 无效
N(3) 2 To 8
N(4) 12 To 15
至于计算长度我想就不用再提醒你了，只要把每个Seg的长度求和就可以了。
(8-2)=6
(15-12)=3
6+3=9
最后提醒你一下：S()才是所有段的全部集合，而N()只是“有效段”的集合，用来统计实际刷上的长度用的。而0 To 10000这根木头的长度与集合无关，仅仅是元素取值的问题。比如，我是用Int(rnd*10001)来取的随机数。后来为了使程序测试更有演示性采用Int(rnd*20)+(10000-20)这种办法使取得的短更小，增加程序工作的难度。毕竟真实的刷子刷一次的长度是有限的。而真实的刷子的长度其实更接近一个常量 。
13161795500 2003-02-09
- 打赏
- 举报
UP!抢分！
foolishtiger 2003-02-09
- 打赏
- 举报
Option Explicit
'每次要刷的起始位置和结束位置
Private Type Seg
Begin As Long
End As Long
End Type
'刷的次数
Private Const TIMES As Long = 3
'用来模拟木头的字符串
Private strResult As String
Private Sub Command2_Click()
Dim aryS(TIMES) As Seg
Dim lngI As Long
'给每次所刷的起点和终点赋初值
aryS(0).Begin = 2
aryS(0).End = 4
aryS(1).Begin = 3
aryS(1).End = 7
aryS(2).Begin = 2
aryS(2).End = 8
aryS(3).Begin = 12
aryS(3).End = 15
'初始化木头
strResult = String(10000, "0")
'开始刷木头
For lngI = LBound(aryS) To UBound(aryS)
Convert aryS(lngI).Begin, aryS(lngI).End
Next
'截去未刷的木头
strResult = Replace(strResult, "0", "")
'计算已刷的长度
MsgBox Len(strResult)
End Sub
Private Sub Convert(ByVal BeginPos As Long, ByVal EndPos As Long)
'模拟刷木头的过程
strResult = Left(strResult, BeginPos - 1) & String(EndPos - BeginPos + 1, "1") & Mid(strResult, EndPos + 1)
End Sub
'每次要刷的起始位置和结束位置
Private Type Seg
Begin As Long
End As Long
End Type
'刷的次数
Private Const TIMES As Long = 3
'用来模拟木头的字符串
Private strResult As String
Private Sub Command2_Click()
Dim aryS(TIMES) As Seg
Dim lngI As Long
'给每次所刷的起点和终点赋初值
aryS(0).Begin = 2
aryS(0).End = 4
aryS(1).Begin = 3
aryS(1).End = 7
aryS(2).Begin = 2
aryS(2).End = 8
aryS(3).Begin = 12
aryS(3).End = 15
'初始化木头
strResult = String(10000, "0")
'开始刷木头
For lngI = LBound(aryS) To UBound(aryS)
Convert aryS(lngI).Begin, aryS(lngI).End
Next
'截去未刷的木头
strResult = Replace(strResult, "0", "")
'计算已刷的长度
MsgBox Len(strResult)
End Sub
Private Sub Convert(ByVal BeginPos As Long, ByVal EndPos As Long)
'模拟刷木头的过程
strResult = Left(strResult, BeginPos - 1) & String(EndPos - BeginPos + 1, "1") & Mid(strResult, EndPos + 1)
End Sub
shuicaitian 2003-02-09
- 打赏
- 举报
感动万分。看到大家的答案。
尤其是热心的小仙女，居然真正做了一个程序？
不过，我的最主要的意思不是要模拟刷木头棍的过程。而是要求部分被刷黑的片断有多长？
小仙妹姐姐给出的数学思想我有点迷糊。
。。。2、如果SegOn小于或者等于集合当中任何一个Seg的SegEnd，则两个Seg可以前后合并成一个Seg。删除原来的被合并的Seg。。。。。
你看，有seg（1）on＝2，seg（1）end＝4；seg（n）on＝6，seg（n）end＝8；合并为seg（x）len＝2+2＝4么？那么删除谁？
或者seg（n）on＝3，seg（n）end＝5；seg（x）len还是2+2＝4么？删除谁？
请详细指教。
野兽派（北方狼，笨老虎，，，，呵呵）的回答可以得出我的要求，但是要开一个大数组。如果我进一步要求精确到小数点后面3位，是不是要开一个10000000的大数组。再大。。。？
并且有10000个这样的木头棍等着我算，应该会很耗时间吧？大家有什么高速一点的数值算法可以实现要求么？
尤其是热心的小仙女，居然真正做了一个程序？
不过，我的最主要的意思不是要模拟刷木头棍的过程。而是要求部分被刷黑的片断有多长？
小仙妹姐姐给出的数学思想我有点迷糊。
。。。2、如果SegOn小于或者等于集合当中任何一个Seg的SegEnd，则两个Seg可以前后合并成一个Seg。删除原来的被合并的Seg。。。。。
你看，有seg（1）on＝2，seg（1）end＝4；seg（n）on＝6，seg（n）end＝8；合并为seg（x）len＝2+2＝4么？那么删除谁？
或者seg（n）on＝3，seg（n）end＝5；seg（x）len还是2+2＝4么？删除谁？
请详细指教。
野兽派（北方狼，笨老虎，，，，呵呵）的回答可以得出我的要求，但是要开一个大数组。如果我进一步要求精确到小数点后面3位，是不是要开一个10000000的大数组。再大。。。？
并且有10000个这样的木头棍等着我算，应该会很耗时间吧？大家有什么高速一点的数值算法可以实现要求么？
KiteGirl 2003-02-09
- 打赏
- 举报
这个程序的效果是这样的：
1、首先，会随着彼此互不包含的段的增加使“有效段”达到一个峰值。体现在图象上是一堆杂乱的片段。
2、接着，有效段的数量将产生短暂的波动。体现在图象上是一堆杂乱的片段的变化。
3、接着，随着有效段逐渐饱和与新数据造成的不断的兼并，使有效段的数量逐渐减少。体现在图象上是一堆杂乱的黑色片段逐渐被新刷的黑色覆盖成一段。
4、最后，将只剩一个从0到1000的有效段。体现在图象上是整根线段都成了黑色。
另外，这个程序用到了记录的添加和删除。由于时间关系，我采用自定义数组实现的。每个Seg有一个Disabled属性，作为删除标记。删除操作仅仅是将Seg标记成删除，而添加操作则是先寻找带删除标记的“空穴”，如果找到的话则添加到第一个找到的“空穴”里，否则才ReDim Preserve数组，添加一个元素。这个方法是比较笨重的办法，实际应用你可以用数据库实现。具体就是SegsDelItem和SegsAddItem函数。这个部分你可以自己重新编写，我仅仅体现一个算法而已。
关键的算法在于SegAddToLine函数，尤其是四种交叉包含情况的处理。
1、首先，会随着彼此互不包含的段的增加使“有效段”达到一个峰值。体现在图象上是一堆杂乱的片段。
2、接着，有效段的数量将产生短暂的波动。体现在图象上是一堆杂乱的片段的变化。
3、接着，随着有效段逐渐饱和与新数据造成的不断的兼并，使有效段的数量逐渐减少。体现在图象上是一堆杂乱的黑色片段逐渐被新刷的黑色覆盖成一段。
4、最后，将只剩一个从0到1000的有效段。体现在图象上是整根线段都成了黑色。
另外，这个程序用到了记录的添加和删除。由于时间关系，我采用自定义数组实现的。每个Seg有一个Disabled属性，作为删除标记。删除操作仅仅是将Seg标记成删除，而添加操作则是先寻找带删除标记的“空穴”，如果找到的话则添加到第一个找到的“空穴”里，否则才ReDim Preserve数组，添加一个元素。这个方法是比较笨重的办法，实际应用你可以用数据库实现。具体就是SegsDelItem和SegsAddItem函数。这个部分你可以自己重新编写，我仅仅体现一个算法而已。
关键的算法在于SegAddToLine函数，尤其是四种交叉包含情况的处理。
KiteGirl 2003-02-09
- 打赏
- 举报
下面是初步写出来的代码，初步测试还没发现问题。我会进一步测试。特别注意下面这个函数：
Function SegGetByRndSet(ByVal pLong As Long, Optional ByVal pMisreg As Long = 0) As tpSegRec
……
'.srSegEnd = Int(Rnd * (pLong + 1)) + pMisreg
.srSegEnd = .srSegOn + Int(Rnd * 20)
……
End Function
.srSegEnd = Int(Rnd * (pLong + 1)) + pMisreg是标准的写法，而.srSegEnd = .srSegOn + Int(Rnd * 20)是为了使每个Seg的长度更短，使程序在很高的负荷下面工作，为了检测代码而修改的。你可以沿用这个语句，但是它并不标准，它生成的随机“段”最长不会超过20，也就是说刷子最长不会刷过超过20个长度的单位。20这个常量可以修改。不过同时将前面的.srSegOn = Int(Rnd * (pLong + 1)) + pMisreg修改成.srSegOn = Int(Rnd * (pLong + 1-20))+ pMisreg或许更标准一些，但是这样一来pLong就不能小于20了。
Module1的代码：
Public tSegs() As tpSegRec
Type tpSegRec
srDisabled As Boolean
srSegOn As Long
srSegEnd As Long
End Type
'[Level 0]
Function SegsViewToPictureBox(pPicture As PictureBox, pSegs() As tpSegRec)
Dim tSegsOn As Long
Dim tSegsEnd As Long
Dim tIndex As Long
tSegsOn = LBound(pSegs)
tSegsEnd = UBound(pSegs)
For tIndex = tSegsOn To tSegsEnd
If Not pSegs(tIndex).srDisabled Then
pPicture.Line (pSegs(tIndex).srSegOn, 5)-(pSegs(tIndex).srSegEnd, 5), RGB(0, 0, 0)
End If
Next
End Function
Function SegsViewToListBox(pListBox As ListBox, pSegs() As tpSegRec)
Dim tSegsOn As Long
Dim tSegsEnd As Long
Dim tIndex As Long
tSegsOn = LBound(pSegs)
tSegsEnd = UBound(pSegs)
pListBox.Clear
For tIndex = tSegsOn To tSegsEnd
If Not pSegs(tIndex).srDisabled Then
pListBox.AddItem pSegs(tIndex).srSegOn & " " & pSegs(tIndex).srSegEnd
End If
Next
End Function
Function SegAddToLine(pSeg As tpSegRec, pSegs() As tpSegRec)
'覆盖一个Seg。如果遇到重合的Seg则合并。
Dim tSegsOn As Long
Dim tSegsEnd As Long
Dim tOverBck As Boolean
Dim tOverPri As Boolean
Dim tOverIns As Boolean
Dim tOverOut As Boolean
Dim tSeg As tpSegRec
Dim tIndex As Long
tSeg = pSeg
tSegsOn = LBound(pSegs)
tSegsEnd = UBound(pSegs)
For tIndex = tSegsOn To tSegsEnd
tOverPri = (tSeg.srSegOn <= pSegs(tIndex).srSegEnd And tSeg.srSegOn >= pSegs(tIndex).srSegOn)
tOverBck = (tSeg.srSegEnd >= pSegs(tIndex).srSegOn And tSeg.srSegEnd <= pSegs(tIndex).srSegEnd)
tOverIns = (tSeg.srSegOn >= pSegs(tIndex).srSegOn And tSeg.srSegEnd <= pSegs(tIndex).srSegEnd)
tOverOut = (tSeg.srSegOn <= pSegs(tIndex).srSegOn And tSeg.srSegEnd >= pSegs(tIndex).srSegEnd)
If Not pSegs(tIndex).srDisabled Then
If tOverIns Then Exit Function
If tOverOut Then
SegsDelItem tIndex, pSegs()
End If
If tOverPri Then
tSeg.srSegOn = pSegs(tIndex).srSegOn
SegsDelItem tIndex, pSegs()
End If
If tOverBck Then
tSeg.srSegEnd = pSegs(tIndex).srSegEnd
SegsDelItem tIndex, pSegs()
End If
End If
Next
SegsAddItem tSeg, pSegs()
End Function
Function SegsDelItem(ByVal pIndex As Long, ByRef pSegs() As tpSegRec)
pSegs(pIndex).srDisabled = True
End Function
Function SegsAddItem(ByRef pSeg As tpSegRec, ByRef pSegs() As tpSegRec)
'添加一个Seg到Segs数组，如果搜索到第一个有删除标记的Seg则添加到对应位置。否则将在数组结尾添加。
Dim tSegsOn As Long
Dim tSegsEnd As Long
Dim tIndex As Long
Dim tInsertOver As Boolean
tSegsOn = LBound(pSegs)
tSegsEnd = UBound(pSegs)
For tIndex = tSegsOn To tSegsEnd
tInsertOver = tInsertOver Or pSegs(tIndex).srDisabled
If tInsertOver Then
pSegs(tIndex) = pSeg
pSegs(tIndex).srDisabled = False
Exit For
End If
Next
If Not tInsertOver Then
tSegsEnd = tSegsEnd + 1
ReDim Preserve pSegs(tSegsEnd)
pSegs(tSegsEnd) = pSeg
End If
End Function
Function SegGetByRndSet(ByVal pLong As Long, Optional ByVal pMisreg As Long = 0) As tpSegRec
Dim tOutSeg As tpSegRec
With tOutSeg
.srSegOn = Int(Rnd * (pLong + 1)) + pMisreg
'.srSegEnd = Int(Rnd * (pLong + 1)) + pMisreg
.srSegEnd = .srSegOn + Int(Rnd * 20)
ValueBigRight .srSegOn, .srSegEnd
End With
SegGetByRndSet = tOutSeg
End Function
'[Level -1]
Function ValueBigRight(ByRef pValL As Long, ByRef pValR As Long)
If pValR < pValL Then ValueSwap pValL, pValR
End Function
Function ValueSwap(ByRef pValA As Long, ByRef pValB As Long)
Dim tT As Long
tT = pValB: pValB = pValA: pValA = tT
End Function
Form1的代码：
Private Sub Command1_Click()
Randomize Timer
Dim tSeg As tpSegRec
tSeg = SegGetByRndSet(1000)
Text1.Text = tSeg.srSegOn & " " & tSeg.srSegEnd
SegAddToLine tSeg, tSegs()
SegsViewToListBox List1, tSegs()
SegsViewToPictureBox Picture1, tSegs()
End Sub
Private Sub Form_Load()
ReDim tSegs(0)
tSegs(0).srDisabled = True
'Text1.Text = tSeg.srSegOn & " " & tSeg.srSegEnd
End Sub
Function SegGetByRndSet(ByVal pLong As Long, Optional ByVal pMisreg As Long = 0) As tpSegRec
……
'.srSegEnd = Int(Rnd * (pLong + 1)) + pMisreg
.srSegEnd = .srSegOn + Int(Rnd * 20)
……
End Function
.srSegEnd = Int(Rnd * (pLong + 1)) + pMisreg是标准的写法，而.srSegEnd = .srSegOn + Int(Rnd * 20)是为了使每个Seg的长度更短，使程序在很高的负荷下面工作，为了检测代码而修改的。你可以沿用这个语句，但是它并不标准，它生成的随机“段”最长不会超过20，也就是说刷子最长不会刷过超过20个长度的单位。20这个常量可以修改。不过同时将前面的.srSegOn = Int(Rnd * (pLong + 1)) + pMisreg修改成.srSegOn = Int(Rnd * (pLong + 1-20))+ pMisreg或许更标准一些，但是这样一来pLong就不能小于20了。
Module1的代码：
Public tSegs() As tpSegRec
Type tpSegRec
srDisabled As Boolean
srSegOn As Long
srSegEnd As Long
End Type
'[Level 0]
Function SegsViewToPictureBox(pPicture As PictureBox, pSegs() As tpSegRec)
Dim tSegsOn As Long
Dim tSegsEnd As Long
Dim tIndex As Long
tSegsOn = LBound(pSegs)
tSegsEnd = UBound(pSegs)
For tIndex = tSegsOn To tSegsEnd
If Not pSegs(tIndex).srDisabled Then
pPicture.Line (pSegs(tIndex).srSegOn, 5)-(pSegs(tIndex).srSegEnd, 5), RGB(0, 0, 0)
End If
Next
End Function
Function SegsViewToListBox(pListBox As ListBox, pSegs() As tpSegRec)
Dim tSegsOn As Long
Dim tSegsEnd As Long
Dim tIndex As Long
tSegsOn = LBound(pSegs)
tSegsEnd = UBound(pSegs)
pListBox.Clear
For tIndex = tSegsOn To tSegsEnd
If Not pSegs(tIndex).srDisabled Then
pListBox.AddItem pSegs(tIndex).srSegOn & " " & pSegs(tIndex).srSegEnd
End If
Next
End Function
Function SegAddToLine(pSeg As tpSegRec, pSegs() As tpSegRec)
'覆盖一个Seg。如果遇到重合的Seg则合并。
Dim tSegsOn As Long
Dim tSegsEnd As Long
Dim tOverBck As Boolean
Dim tOverPri As Boolean
Dim tOverIns As Boolean
Dim tOverOut As Boolean
Dim tSeg As tpSegRec
Dim tIndex As Long
tSeg = pSeg
tSegsOn = LBound(pSegs)
tSegsEnd = UBound(pSegs)
For tIndex = tSegsOn To tSegsEnd
tOverPri = (tSeg.srSegOn <= pSegs(tIndex).srSegEnd And tSeg.srSegOn >= pSegs(tIndex).srSegOn)
tOverBck = (tSeg.srSegEnd >= pSegs(tIndex).srSegOn And tSeg.srSegEnd <= pSegs(tIndex).srSegEnd)
tOverIns = (tSeg.srSegOn >= pSegs(tIndex).srSegOn And tSeg.srSegEnd <= pSegs(tIndex).srSegEnd)
tOverOut = (tSeg.srSegOn <= pSegs(tIndex).srSegOn And tSeg.srSegEnd >= pSegs(tIndex).srSegEnd)
If Not pSegs(tIndex).srDisabled Then
If tOverIns Then Exit Function
If tOverOut Then
SegsDelItem tIndex, pSegs()
End If
If tOverPri Then
tSeg.srSegOn = pSegs(tIndex).srSegOn
SegsDelItem tIndex, pSegs()
End If
If tOverBck Then
tSeg.srSegEnd = pSegs(tIndex).srSegEnd
SegsDelItem tIndex, pSegs()
End If
End If
Next
SegsAddItem tSeg, pSegs()
End Function
Function SegsDelItem(ByVal pIndex As Long, ByRef pSegs() As tpSegRec)
pSegs(pIndex).srDisabled = True
End Function
Function SegsAddItem(ByRef pSeg As tpSegRec, ByRef pSegs() As tpSegRec)
'添加一个Seg到Segs数组，如果搜索到第一个有删除标记的Seg则添加到对应位置。否则将在数组结尾添加。
Dim tSegsOn As Long
Dim tSegsEnd As Long
Dim tIndex As Long
Dim tInsertOver As Boolean
tSegsOn = LBound(pSegs)
tSegsEnd = UBound(pSegs)
For tIndex = tSegsOn To tSegsEnd
tInsertOver = tInsertOver Or pSegs(tIndex).srDisabled
If tInsertOver Then
pSegs(tIndex) = pSeg
pSegs(tIndex).srDisabled = False
Exit For
End If
Next
If Not tInsertOver Then
tSegsEnd = tSegsEnd + 1
ReDim Preserve pSegs(tSegsEnd)
pSegs(tSegsEnd) = pSeg
End If
End Function
Function SegGetByRndSet(ByVal pLong As Long, Optional ByVal pMisreg As Long = 0) As tpSegRec
Dim tOutSeg As tpSegRec
With tOutSeg
.srSegOn = Int(Rnd * (pLong + 1)) + pMisreg
'.srSegEnd = Int(Rnd * (pLong + 1)) + pMisreg
.srSegEnd = .srSegOn + Int(Rnd * 20)
ValueBigRight .srSegOn, .srSegEnd
End With
SegGetByRndSet = tOutSeg
End Function
'[Level -1]
Function ValueBigRight(ByRef pValL As Long, ByRef pValR As Long)
If pValR < pValL Then ValueSwap pValL, pValR
End Function
Function ValueSwap(ByRef pValA As Long, ByRef pValB As Long)
Dim tT As Long
tT = pValB: pValB = pValA: pValA = tT
End Function
Form1的代码：
Private Sub Command1_Click()
Randomize Timer
Dim tSeg As tpSegRec
tSeg = SegGetByRndSet(1000)
Text1.Text = tSeg.srSegOn & " " & tSeg.srSegEnd
SegAddToLine tSeg, tSegs()
SegsViewToListBox List1, tSegs()
SegsViewToPictureBox Picture1, tSegs()
End Sub
Private Sub Form_Load()
ReDim tSegs(0)
tSegs(0).srDisabled = True
'Text1.Text = tSeg.srSegOn & " " & tSeg.srSegEnd
End Sub
KiteGirl 2003-02-09
- 打赏
- 举报
纯数学方法是这样的：
1、设置一个Seg集合，有SegOn和SegEnd两个参数。其中SegEnd必须大于SegOn（颠倒了可以交换一下）。
Type tpSeg
SegOn As Long
SegEnd As long
End Type
2、如果SegOn小于或者等于集合当中任何一个Seg的SegEnd，则两个Seg可以前后合并成一个Seg。删除原来的被合并的Seg。
3、如果SegEnd大于或者等于集合当中任何一个Seg的SegOn，则两个Seg可以前后结合成一个Seg。删除原来的被合并的Seg。
4、如果SegOn小于或者等于集合当中任何一个Seg，同时SegEnd大于或者等于集合当中任何一个Seg。则三个Seg可以结合成一个Seg。删除原来的被合并的Seg。
5、统计所有的存活下来的Seg的程度，就是总共的长度。
这个算法的速度取决于Seg的总数量，并且间接和木头的长度有关，与刷木头的次数成反比关系。刷得越多，存活下来的Seg越少，而Seg的程度越长。但是这个算法不稳定，没有稳定的执行时间。
这是一个很有趣的程序，稍后我会做个简单的样子出来。不过其中要用到添加和删除，恐怕用纯VB实现有点困难。如果用在数据库会很方便的。
1、设置一个Seg集合，有SegOn和SegEnd两个参数。其中SegEnd必须大于SegOn（颠倒了可以交换一下）。
Type tpSeg
SegOn As Long
SegEnd As long
End Type
2、如果SegOn小于或者等于集合当中任何一个Seg的SegEnd，则两个Seg可以前后合并成一个Seg。删除原来的被合并的Seg。
3、如果SegEnd大于或者等于集合当中任何一个Seg的SegOn，则两个Seg可以前后结合成一个Seg。删除原来的被合并的Seg。
4、如果SegOn小于或者等于集合当中任何一个Seg，同时SegEnd大于或者等于集合当中任何一个Seg。则三个Seg可以结合成一个Seg。删除原来的被合并的Seg。
5、统计所有的存活下来的Seg的程度，就是总共的长度。
这个算法的速度取决于Seg的总数量，并且间接和木头的长度有关，与刷木头的次数成反比关系。刷得越多，存活下来的Seg越少，而Seg的程度越长。但是这个算法不稳定，没有稳定的执行时间。
这是一个很有趣的程序，稍后我会做个简单的样子出来。不过其中要用到添加和删除，恐怕用纯VB实现有点困难。如果用在数据库会很方便的。
northwolves 2003-02-08
- 打赏
- 举报
DIM BLACK(10000)AS BOOLEAN
1.BLACK(2)=TRUE,BLACK(3)=TRUE,BLACK(4)=TRUE
2......
3......
再对black(i)[i=0 to 10000]进行"OR"运算
1.BLACK(2)=TRUE,BLACK(3)=TRUE,BLACK(4)=TRUE
2......
3......
再对black(i)[i=0 to 10000]进行"OR"运算
