连连看处理.bas

用VB写的连连看游戏

Attribute VB_Name = "Module1"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'使用栈实现回朔法
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'1.使用一个顺序栈来完成路径的记录，要求栈记录走过的路径，并且记录是否是转弯点和弯点的方向
'2.退栈条件：1.已经没有路可以走（不能走已经走过的路）2.已经有两次以上的转弯记录
'3.退栈的方式：1.对于第一种退栈条件只需要退一个记录。2.对于第二种条件需要退到弯点处
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'栈的结构
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'数据类型如下：
'Type nodestack
'x As Integer '记录走过路径的X坐标
'y As Integer '记录走过路径的y坐标
'flag As Integer '方向记录
'wd As Integer '记录是否是一个转弯点
'End Type
''''''''''''''''''''''''''''''''''''''''''
'初始化游戏算法分析
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'1.初始化算法必须保证游戏能够继续下去
'2.如果时间到了，必须计算出是否存在无法继续下去的情况，如果不能继续下去必须重新初始化
'方案一：
'使用完全随机分配
'方案二：
'使用算法进行随机分配
'随机方案根据时间计算，使用时间做一个种子数
'分配的要求是成对出现
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''
'栈结构的结点
''''''''''''''''''''''''
Type nodestack
    X As Integer             '记录走过路径的X坐标
    Y As Integer             '记录走过路径的y坐标
    flag As Integer          '方向记录
    wd As Integer            '记录是否是一个转弯点
    n As Integer             '记录转过弯的次数
End Type
''''''''''''''''''''''
'游戏存储的结点
''''''''''''''''''''''
Type yxyx
    X As Integer             '记录游戏方块存放的X坐标
    Y As Integer             '记录游戏方块存放的Y坐标
    flag As Integer          '记录是否存在方块
    lx As Integer            '记录方块的类型
End Type
''''''''''''''''''''''''''
'鼠标点击记录
''''''''''''''''''''''''''
Type mousexy
    flag As Integer          '是否是第一次点击鼠标1:表示第一次.0:表示第二次
    x1 As Integer            '定义点击鼠标的X坐标(前)
    y1 As Integer            '定义点击鼠标的Y坐标(前)
    x2 As Integer            '定义点击鼠标的X坐标(后)
    y2 As Integer            '定义点击鼠标的Y坐标(后)
End Type
'''''''''''''''''''''''''''''
'约瑟夫环结点
'''''''''''''''''''''''''''''
Type ysfhnode '约瑟夫环结点
    data As Integer          '结点的密码
    flag  As Integer         '标识结点是否在环内
End Type
'''''''''''''''''''''''''''''''''''
'公共变量
''''''''''''''''''''''''''''''''''''
Public helpn As Integer      '帮助次数
Public passn As Integer      '等级
Public gamenum As Integer    '记录下连接方块的个数
Public overflag As Boolean   '表示游戏结束
Public playflag As Boolean   '表示是否是在进行游戏
Public gametime As Integer   '游戏时间
Public stopflag As Boolean   '用于判断暂停
Public time1 As Integer      '用于连接效果的延时
Public can1 As Boolean       '用于判断是否能继续游戏变量
Public alrealy As Boolean    '用于表示是否有方块连接
Public ret1 As nodestack     '用于返回下一个探测点的变量
Public gettopret As nodestack '取得栈顶元素的变量
Public popret As nodestack   '取得出栈的元素的变量
Public mousedo As mousexy    '定义MOUSEDO为记录点击方块的变量
Public stack_n As Integer    '记录栈的位置变量
Public jl(1 To 12, 1 To 16) As yxyx    '定义一个12*16的游戏存储区用于存储游戏结果
Public stack(1 To 193) As nodestack    '定义一个可以记录193步的顺序栈
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'初始化游戏随机函数
'参数说明
'upper:随机数上限，lower:随机数下限，zz:随机函数的种子数
'功能说明：使用系统时间的秒做为随机函数的种子数，可以产生较好的随机效果
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function rand(ByVal upper As Integer, ByVal lower As Integer, ByVal zz As Integer)
    Dim a  As Integer
    a = (Int(upper - lower + 1) * Rnd() + zz) Mod (upper - lower + 1) + lower    '产生一个有时间参与的随机函数
    rand = a
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'约瑟夫环
'功能说明:在一个区间内产生一个唯一的随机数
'目的:为了能使得图块分配更随机
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ysfh(ret() As Integer)
    Dim i, j, n, m, star  As Integer
    Dim a(1 To 140) As ysfhnode
    Dim ks As Integer
    n = 1: ks = 1
    For i = 1 To 140         '随机分配给每个结点密码
        a(i).data = rand(30, 1, Second(Time))
    Next i
    star = rand(10, 1, Second(Time))
    For n = 1 To 140
        Do
            ks = ks + 1
            If ks = 141 Then ks = 1    '做一个循环点
            If a(ks).flag = 0 Then star = star - 1
        Loop Until star <= 0
        a(ks).flag = 1
        star = a(ks).data
        ret(n) = ks
    Next n
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'游戏界面是一个12*16的游戏界面,其中外围是空路
'模块负责初始化游戏的界面
'分配的要求是成对出现.由于图形必须是成对出现的，所以必须进行修正
'模块功能说明:随机产生20个可以分配6个方块的类型,5个可以分配4个方块的类型
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub initstar()
    Dim i, j, m, a(1 To 25), lx, Y(1 To 20), low, ret(1 To 140) As Integer
    m = 0
    '''''''''''''''''''''''''''''''
    '随机确定20个可以分配6个方块的类型
    low = rand(5, 1, Second(Time))
    For i = 1 To 20
        Y(i) = i + low
    Next i
    '''''''''''''''''''''''''
    '根据前面的情况进行分配
    Call ysfh(ret)
    For m = 1 To 140
        i = (ret(m) - 1) \ 14
        j = ret(m) Mod 14
        If i = 0 Then
            i = 2
        Else
            i = i + 2
        End If
        If j = 0 Then
            j = 15
        Else
            j = j + 1
        End If
        jl(i, j).X = 40 * j
        jl(i, j).Y = 40 * i
        jl(i, j).flag = 1
        lx = rand(25, 1, Second(Time))    '随机分配图形类型
11:         If a(lx) < 4 Or (a(lx) < 6 And lx = Y(1)) Or (a(lx) < 6 And lx = Y(2)) Or (a(lx) < 6 And lx = Y(3)) Or (a(lx) < 6 And lx = Y(4)) Or (a(lx) < 6 And lx = Y(5)) Or (a(lx) < 6 And lx = Y(6)) Or (a(lx) < 6 And lx = Y(7)) Or (a(lx) < 6 And lx = Y(8)) Or (a(lx) < 6 And lx = Y(9)) Or (a(lx) < 6 And lx = Y(10)) Or (a(lx) < 6 And lx = Y(11)) Or (a(lx) < 6 And lx = Y(12)) Or (a(lx) < 6 And lx = Y(13)) Or (a(lx) < 6 And lx = Y(14)) Or (a(lx) < 6 And lx = Y(15)) Or (a(lx) < 6 And lx = Y(16)) Or (a(lx) < 6 And lx = Y(17)) Or (a(lx) < 6 And lx = Y(18)) Or (a(lx) < 6 And lx = Y(19)) Or (a(lx) < 6 And lx = Y(20)) Then
            jl(i, j).lx = lx
            a(lx) = a(lx) + 1 '统计出分配各方块的数目
        Else
            lx = rand(25, 1, Second(Time))    '随机分配图形类型
            GoTo 11
        End If
    Next m
    overflag = False         '游戏没有结束
    playflag = True          '表示开始游戏中
    gametime = 150           '初始化游戏进行时间长度
    gamenum = 0              '初始化连接方块的个数
    Form1.Timer2.Enabled = True    '开始记时
    Form1.Picture3.PaintPicture Form2.Picture4.Picture, 0, 0, 450, 10, , , , , vbSrcCopy    '初始化时间效果图
    Call pass(ByVal passn)   '跳关
End Sub

''''''''''''''''''''''''''''''''''''
'以下是对栈的操作
'PUSH,GETTOP,POP
''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'入栈PUSH
'功能说明：将走过的路径记录下,用于回朔功能
'x:方块的X坐标,y:方块的Y坐标,flag:方向标志,wd:记录是否经过弯点
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function push(ByVal X As Integer, ByVal Y As Integer, ByVal flag As Integer, ByVal wd As Integer, ByVal n As Integer)
''''''''''''''''''''''''''
'程序算法导致BUG问题
'细节退栈问题导致栈内数据重复
'''''''''''''''''''''''''
    If stack_n > 2 Then
        If stack(stack_n - 1).X = X And stack(stack_n - 1).Y = Y Then
            stack(stack_n - 1).flag = flag
            push = stack_n
            Exit Function
        End If
    End If
    '''''''''''''''''''''''''''
    stack(stack_n).X = X
    stack(stack_n).Y = Y
    stack(stack_n).flag = flag
    stack(stack_n).wd = wd
    stack(stack_n).n = n
    stack_n = stack_n + 1
    push = stack_n
End Function
'''''''''''''''''''''''''
'获取栈顶元素
'功能说明:返回栈顶的结点
''''''''''''''''''''''''
Sub gettop()
    gettopret.X = stack(stack_n - 1).X
    gettopret.Y = stack(stack_n - 1).Y
    gettopret.flag = stack(stack_n - 1).flag
    gettopret.wd = stack(stack_n - 1).wd
    gettopret.n = stack(stack_n - 1).n
End Sub
''''''''''''''''''''''''''''''''''''''
'出栈操作
'功能说明:返回1表示错误,返回0表示真确
'可以在操作时检查错误
''''''''''''''''''''''''''''''''''''''
Sub pop()
    stack_n = stack_n - 1
    If stack_n = 0 Then      '如果出栈出现非法操作
        MsgBox ("程序执行错误!")
        End
    Else                     '如果是合法操作返回退出的栈内元素
        popret = stack(stack_n)
    End If
End Sub
''''''''''''''''''''''''''''''''''''
'判断栈是否是空栈
'0表示是一个空栈,1表示是一个非空栈
''''''''''''''''''''''''''''''''''''
Function stackempty()
    Dim m As Integer
    If stack_n = 1 Then
        m = 0
        stackempty = m
    Else
        m = 1
        stackempty = m
    End If
End Function
Sub ceshi(ByVal X As Integer, ByVal Y As Integer, ByVal flag As Integer, ByVal k As Integer)
    Dim starx, stary, endx, endy, wd, n As Integer
    Call abled
    ret1.X = X: ret1.Y = Y: ret1.flag = flag
    Do
        starx = ret1.X: stary = ret1.Y: flag = ret1.flag: k = ret1.n
        Call sdpd(starx, stary, flag, k)
        If ret1.X = 0 And ret1.Y = 0 And ret1.wd = 0 And ret1.flag = 0 And ret1.n = 0 Then
            Exit Sub
        End If
    Loop Until stackempty = 0 And ret1.flag > 4    '直到栈空
    Call init
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'单点的判断
'功能说明:用于判断是否边上有障碍1:表示有障碍物.0:表示没有障碍物2:表示连接上图形相同的图块
'参数说明:x:当前方块的X坐标.Y:当前方块的Y坐标.FLAG:当前方块的探测方向
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ts(ByVal X As Integer, ByVal Y As Integer, ByVal flag As Integer)
    Dim m As Integer
    Select Case flag
        Case 1               '向右判断
            If Y + 1 >= 17 Then    '如果下一个位置是右边墙壁
                m = 1
            Else
                If jl(X, Y + 1).flag = 1 Then
                    m = 1
                Else
                    m = 0
                End If
                If jl(X, Y + 1).lx = jl(mousedo.x1, mousedo.y1).lx And mousedo.x2 = X And mousedo.y2 = Y + 1 Then m = 2
            End If
        Case 2               '向下判断
            If X + 1 >= 13 Then    '如果下一个位置是下边墙壁
                m = 1
            Else
                If jl(X + 1, Y).flag = 1 Then
                    m = 1
                Else
                    m = 0
                End If
                If jl(X + 1, Y).lx = jl(mousedo.x1, mousedo.y1).lx And mousedo.x2 = X + 1 And mousedo.y2 = Y Then m = 2
            End If
        Case 3               '向左判断
            If Y - 1 <= 0 Then    '如果下一个位置是左边墙壁
                m = 1
            Else
                If jl(X, Y - 1).flag = 1 Then
                    m = 1
                Else
                    m = 0
                End If
                If jl(X, Y - 1).lx = jl(mousedo.x1, mousedo.y1).lx And mousedo.x2 = X And mousedo.y2 = Y - 1 Then m = 2
            End If
        Case 4               '向上判断
            If X - 1 <= 0 Then    '如果下一个位置是上边墙壁
                m = 1
            Else
                If jl(X - 1, Y).flag = 1 Then
                    m = 1
                Else
                    m = 0
                End If
                If jl(X - 1, Y).lx = jl(mousedo.x1, mousedo.y1).lx And mousedo.x2 = X - 1 And mousedo.y2 = Y Then m = 2
            End If
    End Select
    ts = m
End Function
''''''''''''''''''''''''''''''''''''''''''
'回头路径的判断
'用于判断是否是一个回头的路径
'对于已经走过的路径来说也作为一个障碍判断
'功能模块说明:用于判断是否需要调用检测模块
'参数说明:FLAG用来标识位置的探索方向
'返回1:方向冲突.0:表示方向不冲突
'''''''''''''''''''''''''''''''''''''''''''
Function htjc(ByVal flag As Integer)
    Dim m As Integer
    m = 0
    If stack_n > 2 Then
        Call gettop          '获取栈顶元素
        If flag = 1 And gettopret.flag = 3 Then m = 1
        If flag = 2 And gettopret.flag = 4 Then m = 1
        If flag = 3 And gettopret.flag = 1 Then m = 1
        If flag = 4 And gettopret.flag = 2 Then m = 1
    End If
    htjc = m
End Function
''''''''''''''''''''''''''''''''''''''''''''''
'取得下一个判断点的x坐标
'参数说明：X表示活点的坐标。FLAG表示活点的方向
'''''''''''''''''''''''''''''''''''''''''''''''
Function xfx(ByVal X As Integer, ByVal flag As Integer)
    Dim m As Integer
    Select Case flag
        Case 1
            m = X
        Case 2
            m = X + 1
        Case 3
            m = X
        Case 4
            m = X - 1
    End Select
    xfx = m
End Function
'''''''''''''''''''''''''''''''''''''''''''''
'取得下一个判断点的y坐标
'参数说明:Y表示活点的坐标.FLAG表示活点的方向
''''''''''''''''''''''''''''''''''''''''''''''
Function yfx(ByVal Y As Integer, ByVal flag As Integer)
    Dim m As Integer
    Select Case flag
        Case 1
            m = Y + 1
        Case 2
            m = Y
        Case 3
            m = Y - 1
        Case 4
            m = Y
    End Select
    yfx = m
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'判断该点是否是一个死点
'如果不是一个死点就向活方向继续探测
'如果是一个死点的话就进行退栈
'需要使用:单点判断,回头路径的判断
'参数说明:X,Y表示探测点的位置.FLAG表示探测的方向,wd表示是否是一个转弯点,n记录转弯的次数
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub sdpd(ByVal X As Integer, ByVal Y As Integer, ByVal flag As Integer, ByVal n As Integer)
    Dim m, k, wd, i, n1 As Integer    'k用来记录栈顶的位置,wd用来判断是否是一个转弯点
''''''''''''''''''''''''''''''''''
    Dim flag1, u, uk, q, n2 As Integer