种子填充的递归算法!

by827 2004-11-07 01:49:24
Dim c As Single
'种子填充的递归算法过程
Private Sub seed_filling(xStart As Single, yStart As Single, fill_color As Single, boundary_color As Single)
c = Point(xStart, yStart) '取得当前象素的颜色
If ((c <> boundary_colr) And (c <> fill_color)) Then
Picture1.PSet (yStart, yStart), fill_color '填一个象素点
Call seed_filling(xStart + 1, yStart, fill_color, boundary_color)
Call seed_filling(xStart - 1, yStart, fill_color, boundary_color)
Call seed_filling(xStart, yStart + 1, fill_color, boundary_color)
Call seed_filling(xStart, yStart - 1, fill_color, boundary_color)
End If
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call seed_filling(X, Y, Picture1.ForeColor, Picture1.ForeColor)
End Sub

Private Sub Picture1_Paint()
Picture1.Circle (1000, 1000), 1000 '先画一个圆,然后要在这个圆填充颜色!
End Sub

这是一个种子填色算法的实现
运行时左击圆内时出现"out of stack space"错误提示!我要运行时左击圆内实现圆的填充!
该怎么改呀?
请高人指教!
...全文
378 12 打赏 收藏 转发到动态 举报
写回复
用AI写文章
12 条回复
切换为时间正序
请发表友善的回复…
发表回复
by827 2004-11-09
  • 打赏
  • 举报
回复
小仙妹可是高人呀!
eduxh 2004-11-09
  • 打赏
  • 举报
回复
原来小仙妹也是搞VB的啊,而且还很厉害嘛
by827 2004-11-08
  • 打赏
  • 举报
回复
先感谢KiteGirl(小仙妹)吧@@@!!!!
KiteGirl 2004-11-08
  • 打赏
  • 举报
回复
少等!我给你一个!
KiteGirl 2004-11-08
  • 打赏
  • 举报
回复
改进后的Seed_Filling。先把原来的改名为Seed_Filling2,然后复制该函数到模块里。可以看出两个函数的明显区别。

Public Sub Seed_Filling(ByRef pPicture As PictureBox, ByRef pStartPoint As tpPoint, ByRef pPointTable() As tpPoint, ByVal pFillColor As Long, ByVal pBoundAryColor As Long)
Dim tTableIndex As Long
Dim tTableLength As Long
Dim tFillingOver As Boolean
Dim tFillNext As Boolean
Dim tFillPointColor As Long
Dim tPoint As tpPoint
Dim tPointNew As tpPoint
Dim tNewLength As Long
Dim tBackBuffer() As Boolean
ReDim tBackBuffer(pPicture.Width, pPicture.Height)

PointTable_AddItem pStartPoint, pPointTable()

Do

tPoint = pPointTable(tTableLength)
tNewLength = tTableLength - 1
If tNewLength >= 0 Then ReDim Preserve pPointTable(tNewLength) '以上三句是模拟堆栈的出栈

If tBackBuffer(tPoint.fcX, tPoint.fcY) Then
tFillNext = Not tBackBuffer(tPoint.fcX, tPoint.fcY)
Else
tFillPointColor = pPicture.Point(tPoint.fcX, tPoint.fcY)
tFillNext = (tFillPointColor <> boundary_colr) And (tFillPointColor <> fill_color)
End If

If tFillNext Then
pPicture.PSet (tPoint.fcX, tPoint.fcY), pFillColor
tBackBuffer(tPoint.fcX, tPoint.fcY) = True
'如果点有效,则将临近点推入堆栈。
tPointNew.fcX = tPoint.fcX: tPointNew.fcY = tPoint.fcY - 1
PointTable_AddItem tPointNew, pPointTable()
tPointNew.fcX = tPoint.fcX: tPointNew.fcY = tPoint.fcY + 1
PointTable_AddItem tPointNew, pPointTable()
tPointNew.fcX = tPoint.fcX - 1: tPointNew.fcY = tPoint.fcY
PointTable_AddItem tPointNew, pPointTable()
tPointNew.fcX = tPoint.fcX + 1: tPointNew.fcY = tPoint.fcY
PointTable_AddItem tPointNew, pPointTable()
End If
'tTableIndex = tTableIndex + 1
tTableLength = UBound(pPointTable()) '取堆栈尺寸
'If N < tTableLength Then N = tTableLength
tFillingOver = tTableLength = 0 '如果堆栈为0,则说明工作完毕。
Loop Until tFillingOver
Form1.Text1.Text = "Max:" & N
End Sub

另外,我正在研究一个更新的办法(并非算法,而是对图象的操作方式),可以加快速度。
by827 2004-11-08
  • 打赏
  • 举报
回复
真是非常感谢高人KiteGirl(小仙妹)的指教!!!


KiteGirl 2004-11-08
  • 打赏
  • 举报
回复
你再UP一下!我发现了一个新办法,稍后改进一下代码,可以加入“废弃”功能。
KiteGirl 2004-11-08
  • 打赏
  • 举报
回复
PictureBox和From的ScaleMode一定要用Pixel,否则在取点的颜色的时候会出现错误,导致运行终止。
KiteGirl 2004-11-08
  • 打赏
  • 举报
回复
用的就是你的算法。缺点是消耗大量内存。如果把坐标堆改成链表加入废弃机制,可以改善。只是没时间搞了。

测试代码:
Private Sub Form_Load()
Form1.Show
Picture1.Circle (100, 100), 100, 0
Dim tPoint As tpPoint
Dim tPointTable() As tpPoint

tPoint.fcX = 100
tPoint.fcY = 100

Seed_Filling Picture1, tPoint, tPointTable(), 0, 0
End Sub

核心代码:

Type tpPoint
fcX As Long
fcY As Long
End Type

Public Sub PointTable_AddItem(ByRef pPoint As tpPoint, ByRef pPointTable() As tpPoint)

Dim tTableLength As Long
Dim tTableLengthNew As Long

Err.Clear
On Error Resume Next

tTableLength = UBound(pPointTable())

If CBool(Err.Number) Then
tTableLengthNew = 0
Else
tTableLengthNew = tTableLength + 1
End If

ReDim Preserve pPointTable(tTableLengthNew)

pPointTable(tTableLengthNew) = pPoint

End Sub

Public Sub Seed_Filling(ByRef pPicture As PictureBox, ByRef pStartPoint As tpPoint, ByRef pPointTable() As tpPoint, ByVal pFillColor As Long, ByVal pBoundAryColor As Long)
Dim tTableIndex As Long
Dim tTableLength As Long
Dim tFillingOver As Boolean
Dim tFillNext As Boolean
Dim tFillPointColor As Long
Dim tPoint As tpPoint
Dim tPointNew As tpPoint

PointTable_AddItem pStartPoint, pPointTable()

Do
tPoint = pPointTable(tTableIndex)
tFillPointColor = pPicture.Point(tPoint.fcX, tPoint.fcY)
tFillNext = (tFillPointColor <> boundary_colr) And (tFillPointColor <> fill_color)
If tFillNext Then
pPicture.PSet (tPoint.fcX, tPoint.fcY), pFillColor
tPointNew.fcX = tPoint.fcX: tPointNew.fcY = tPoint.fcY - 1
PointTable_AddItem tPointNew, pPointTable()
tPointNew.fcX = tPoint.fcX: tPointNew.fcY = tPoint.fcY + 1
PointTable_AddItem tPointNew, pPointTable()
tPointNew.fcX = tPoint.fcX - 1: tPointNew.fcY = tPoint.fcY
PointTable_AddItem tPointNew, pPointTable()
tPointNew.fcX = tPoint.fcX + 1: tPointNew.fcY = tPoint.fcY
PointTable_AddItem tPointNew, pPointTable()
End If
tTableLength = UBound(pPointTable())
tTableIndex = tTableIndex + 1
tFillingOver = tTableIndex > tTableLength
Loop Until tFillingOver
End Sub
by827 2004-11-07
  • 打赏
  • 举报
回复
上面这位高人说得对,就是out of stack space
这么说,这个算法不能实现了???
晕!!!!
有没有办法呀
AprilSong 2004-11-07
  • 打赏
  • 举报
回复
要么改算法
要么把圆半径改小
不然肯定堆栈溢出
by827 2004-11-07
  • 打赏
  • 举报
回复
高人走过路过,请帮帮忙

7,759

社区成员

发帖
与我相关
我的任务
社区描述
VB 基础类
社区管理员
  • VB基础类社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧