常用算法在VB中的实现

[ 今日无聊至此，特转贴一篇以测试一下]

常用算法在VB中的实现

        这是根据网上获得的资料改编的，因为通常的算法都是用C程序实现的，几乎见不到用VB实现的程序，对于不熟悉C语言的人会有许多困难。因此来做一做用VB实现各种算法的尝试，不知是否对大家有点用处。
       
        要使计算机能完成人们预定的工作，就要编写计算机程序。计算机程序要对问题的每个对象和处理规则给出正确详尽的描述，其中程序的数据结构和变量用来描述问题的对象，程序结构、函数和语句用来描述问题的算法。算法和数据结构是程序的两个重要方面。而程序的编写依据则是算法。
        算法是问题求解过程的精确描述，一个算法由有限条可完全机械地执行的、有确定结果的指令组成。指令正确地描述了要完成的任务和它们被执行的顺序。计算机按算法指令所描述的顺序执行算法的指令，能在有限的步骤内终止，或终止于给出问题的解，或终止于指出问题对此输入数据无解。
        通常求解一个问题可能会有多种算法可供选择，选择的主要标准是算法的正确性和可靠性，简单性和易理解性。其次是算法所需要的存储空间少和执行更快等。
        算法设计是一件非常困难的工作，但是算法的设计也有一定的方法，经常采用的算法设计技术主要有迭代法、穷举搜索法、递推法、递归法、贪婪法、回溯法、分治法、动态规划法等等。
        下面就对这些算法做一些简单的介绍，并给出在VB中实现的程序。
        一、迭代法
        迭代算法是用计算机解决问题的一种基本方法。它利用计算机运算速度快、适合做重复性操作的特点，让计算机对一组指令（或一定步骤）进行重复执行，在每次执行这组指令（或这些步骤）时，都从变量的原值推出它的一个新值。
        利用迭代算法解决问题，需要做好以下三个方面的工作：
        一、确定迭代变量。在可以用迭代算法解决的问题中，至少存在一个直接或间接地不断由旧值递推出新值的变量，这个变量就是迭代变量。
        二、建立迭代关系式。所谓迭代关系式，指如何从变量的前一个值推出其下一个值的公式（或关系）。迭代关系式的建立是解决迭代问题的关键，通常可以使用递推或倒推的方法来完成。
        三、对迭代过程进行控制。在什么时候结束迭代过程？这是编写迭代程序必须考虑的问题。不能让迭代过程无休止地重复执行下去。迭代过程的控制通常可分为两种情况：一种是所需的迭代次数是个确定的值，可以计算出来；另一种是所需的迭代次数无法确定。对于前一种情况，可以构建一个固定次数的循环来实现对迭代过程的控制；对于后一种情况，需要进一步分析出用来结束迭代过程的条件。
        例1.验证谷角猜想。日本数学家谷角静夫在研究自然数时发现了一个奇怪现象：对于任意一个自然数n，若n为偶数，则将其除以2；若n为奇数，则将其乘以3，然后再加1。如此经过有限次运算后，总可以得到自然数1。人们把谷角静夫的这一发现叫做“谷角猜想”。
        现在编写一个程序，由键盘输入一个自然数n，把n经过有限次运算后，最终变成自然数1的全过程打印出来。
        分析：定义迭代变量为n，按照谷角猜想的内容，可以得到两种情况下的迭代关系式：当n为偶数时，n=n/2；当n为奇数时，n=n*3+1。这就是需要计算机重复执行的迭代过程。这个迭代过程需要重复执行多少次，才能使迭代变量n最终变成自然数1，这是我们无法计算出来的。因此，还需进一步确定用来结束迭代过程的条件。仔细分析题目要求，不难看出，对任意给定的一个自然数n，只要经过有限次运算后，能够得到自然数1，就已经完成了验证工作。因此，用来结束迭代过程的条件可以定义为：n=1。参考程序如下：
         Cls
         n = InputBox("请输入一个自然数n", "输入")
         Print n
         Do Until n = 1
          If n Mod 2 = 0 Then
           n = n / 2
           Print "n / 2 ="; n
          Else
           n = n * 3 + 1
           Print "n * 3 + 1 ="; n
          End If
         Loop
         Print "谷角猜想对";n;"得到证实。"
       
        例2.假定一对大兔子每月能生一对小兔子，而小兔子过一个月就长大了可以开始生小兔子，问在一年内一对大兔子可以繁殖出多少对大兔子？
        分析：这是一个典型的递推问题，但也可以使用迭代法求解。我们不妨假设第1个月时兔子的对数为u1，第2个月时兔子的对数为u2，第3个月时兔子的对数为u3，……根据题意则有:
        原来有一对大兔子，故u1=1。第二个月，大兔子生了一对小兔子，小兔子未长大，大兔子仍是一对，u2=1。第三个月，小兔子长大了，但还未生小兔子，原来的大兔子又生一对小兔子，所以大兔子是u3=u1+u2=2，....，n个月后，大兔子总数为：
        un+1=un+un-1
        让计算机对这个迭代关系重复执行11次，就可以算出第12个月时的兔子数。参考程序如下：
         x0 = 0                '
         x1 = 1
         For i = 1 To 12
          x = x0 + x1
          x1 = x0
          x0 = x
          Print "一年后大兔子共";x;"对。"
         Next
       
        例3.阿米巴用简单分裂的方式繁殖，它每分裂一次要用3分钟。将若干个阿米巴放在一个盛满营养参液的容器内，45分钟后容器内充满了阿米巴。已知容器最多可以装阿米巴220个。试问，开始的时候往容器内放了多少个阿米巴？请编程序算出。
        分析：根据题意，阿米巴每3分钟分裂一次，那么从开始的时候将阿米巴放入容器里面，到45分钟后充满容器，需要分裂45/3=15次。按题意，阿米巴分裂15次以后得到的个数是2^20。要计算分裂之前的阿米巴数，则可使用倒推的方法，从第15次分裂之后的2^20个，倒推出第14次分裂之后的个数，再进一步倒推出第13次分裂之后、第12次分裂之后、……第1次分裂之后的个数到第1次分裂之前的个数。
        设第1次分裂之前的个数为x0、第1次分裂之后的个数为x1、第2次分裂之后的个数为x2、……第n次分裂之后的个数为xn，则有
        xn=xn-1*2   或   xn-1=xn/2
        因为分裂次数是已知的，如果定义迭代变量为x，则让这个迭代公式重复执行已知次数就可以了。所以可以使用一个固定次数的循环来实现对迭代过程的控制。参考程序如下：
        Cls
        x=2^20
        For i=1 To 15
         x=x/2
        Next
        Print "开始时候容器内放了";x;"个阿米巴。"
       
        迭代法也是用于求方程或方程组近似根的一种常用的算法。设方程为f(x)=0，通过数学变换导出其等价的形式x=g(x)，然后可以按以下步骤执行：
        （1） 选一个方程的近似根，赋给变量x0；
        （2） 将x0的值保存于变量x1，然后计算g(x1)，并将结果存于变量x0；
        （3） 当x0与x1的差的绝对值还小于指定的精度要求时，重复步骤（2）的计算。
        若方程有根，并且用上述方法计算出来的近似根序列收敛，则按上述方法求得的x0就认为是方程的根。
        数学中在解非线性方程时广泛使用的迭代法是牛顿迭代法，它是根据方程f(x)得泰勒展开式取其线性部分构造的迭代式，一般形式为：
        x=x-f(x)/f'(x)
        例4.用牛顿迭代法求一元三次方程f(x)=aX3+bx2+cx+d=0的根。
        f(x)=aX3+bx2+cx+d
        g(x)=f'(x)=3aX2+2bx+c
        其VB程序如下：
         x0 = 1
         Do Until Abs(x - x0) <= y
          x = x0
          f = a * x ^ 3 + b * x ^ 2 + c * x + d
          g = 3 * a * x ^ 2 + 2 * b * x + c
          x0 = x - f / g  
         Loop
         Print x0
        方程的系数a、b、c、d和根的精度y是已知的，或由用户输入。
       
        具体使用迭代法求根时应注意以下两种可能发生的情况：
        （1） 如果方程无解，算法求出的近似根序列就不会收敛，迭代过程会变成死循环，因此在使用迭代算法前应先考察方程是否有解，并在程序中对迭代的次数给予限制；
（2） 方程虽然有解，但迭代公式选择不当，或迭代的初始近似根选择不合理，也会导致迭代失败。

 

2006-5-4 13:56

#1

 

VB计算农历的算法

下面是一个关于VB的农历算法
'日期数据定义方法如下
'前12个字节代表1-12月为大月或是小月，1为大月30天，0为小月29天，
'第13位为闰月的情况，1为大月30天，0为小月29天，第14位为闰月的月
'份，如果不是闰月为0，否则给出月份，10、11、12分别用A、B、C来表
'示，即使用16进制。最后4位为当年家农历新年-即农历1月1日所在公历
'的日期，如0131代表1月31日。
'GetYLDate函数使用方式如下tYear为要输入的年，tMonth为月，tDay为
'日期，YLyear是返回值，返加农历的年份，如甲子年，YLShuXing返回
'的是属象，如鼠。IsGetGl是设置是不是通过农历取公历值，如果是，
'前三个返回相应的公历日期，而且返回值是一个公历日期。

Function GetYLDate(tYear As Integer, tMonth As Integer, tDay As Integer, _
                    YLyear As String, YLShuXing As String, _
                    Optional IsGetGl As Boolean) As String

    On Error Resume Next
    Dim daList(1900 To 2011) As String * 18
    Dim conDate As Date, setDate As Date
    Dim AddMonth As Integer, AddDay As Integer, AddYear As Integer, getDay As Integer
    Dim RunYue As Boolean
    If tYear > 2010 Or tYear < 1901 Then Exit Function '如果不是有效有日期，退出
    '1900 to 1909
    daList(1900) = "010010110110180131"
    daList(1901) = "010010101110000219"
    daList(1902) = "101001010111000208"
    daList(1903) = "010100100110150129"
    daList(1904) = "110100100110000216"
    daList(1905) = "110110010101000204"
    daList(1906) = "011010101010140125"
    daList(1907) = "010101101010000213"
    daList(1908) = "100110101101000202"
    daList(1909) = "010010101110120122"
    daList(1910) = "010010101110000210"
    daList(1911) = "101001001101160130"
    daList(1912) = "101001001101000218"
    daList(1913) = "110100100101000206"
    daList(1914) = "110101010100150126"
    daList(1915) = "101101010101000214"
    daList(1916) = "010101101010000204"
    daList(1917) = "100101101101020123"
    daList(1918) = "100101011011000211"
    daList(1919) = "010010011011170201"
    daList(1920) = "010010011011000220"
    daList(1921) = "101001001011000208"
    daList(1922) = "101100100101150128"
    daList(1923) = "011010100101000216"
    daList(1924) = "011011010100000205"
    daList(1925) = "101011011010140124"
    daList(1926) = "001010110110000213"
    daList(1927) = "100101010111000202"
    daList(1928) = "010010010111120123"
    daList(1929) = "010010010111000210"
    daList(1930) = "011001001011060130"
    daList(1931) = "110101001010000217"
    daList(1932) = "111010100101000206"
    daList(1933) = "011011010100150126"
    daList(1934) = "010110101101000214"
    daList(1935) = "001010110110000204"
    daList(1936) = "100100110111030124"
    daList(1937) = "100100101110000211"
    daList(1938) = "110010010110170131"
    daList(1939) = "110010010101000219"
    daList(1940) = "110101001010000208"
    daList(1941) = "110110100101060127"
    daList(1942) = "101101010101000215"
    daList(1943) = "010101101010000205"
    daList(1944) = "101010101101140125"
    daList(1945) = "001001011101000213"
    daList(1946) = "100100101101000202"
    daList(1947) = "110010010101120122"
    daList(1948) = "101010010101000210"
    daList(1949) = "101101001010170129"
    daList(1950) = "011011001010000217"
    daList(1951) = "101101010101000206"
    daList(1952) = "010101011010150127"
    daList(1953) = "010011011010000214"
    daList(1954) = "101001011011000203"
    daList(1955) = "010100101011130124"
    daList(1956) = "010100101011000212"
    daList(1957) = "101010010101080131"
    daList(1958) = "111010010101000218"
    daList(1959) = "011010101010000208"
    daList(1960) = "101011010101060128"
    daList(1961) = "101010110101000215"
    daList(1962) = "010010110110000205"
    daList(1963) = "101001010111040125"
    daList(1964) = "101001010111000213"
    daList(1965) = "010100100110000202"
    daList(1966) = "111010010011030121"
    daList(1967) = "110110010101000209"
    daList(1968) = "010110101010170130"
    daList(1969) = "010101101010000217"
    daList(1970) = "100101101101000206"
    daList(1971) = "010010101110150127"
    daList(1972) = "010010101101000215"
    daList(1973) = "101001001101000203"
    daList(1974) = "110100100110140123"
    daList(1975) = "110100100101000211"
    daList(1976) = "110101010010180131"
    daList(1977) = "101101010100000218"
    daList(1978) = "101101101010000207"
    daList(1979) = "100101101101060128"
    daList(1980) = "100101011011000216"
    daList(1981) = "010010011011000205"
    daList(1982) = "101001001011140125"
    daList(1983) = "101001001011000213"
    daList(1984) = "1011001001011A0202"
    daList(1985) = "011010100101000220"
    daList(1986) = "011011010100000209"
    daList(1987) = "101011011010060129"
    daList(1988) = "101010110110000217"
    daList(1989) = "100100110111000206"
    daList(1990) = "010010010111150127"
    daList(1991) = "010010010111000215"
    daList(1992) = "011001001011000204"
    daList(1993) = "011010100101030123"
    daList(1994) = "111010100101000210"
    daList(1995) = "011010110010180131"
    daList(1996) = "010110101100000219"
    daList(1997) = "101010110110000207"
    daList(1998) = "100100110110150128"
    daList(1999) = "100100101110000216"
    daList(2000) = "110010010110000205"
    daList(2001) = "110101001010140124"
    daList(2002) = "110101001010000212"
    daList(2003) = "110110100101000201"
    daList(2004) = "010110101010120122"
    daList(2005) = "010101101010000209"
    daList(2006) = "101010101101170129"
    daList(2007) = "001001011101000218"
    daList(2008) = "100100101101000207"
    daList(2009) = "110010010101150126"
    daList(2010) = "101010010101000214"
    daList(2011) = "101101001010000214"
    AddYear = tYear
    RunYue = False
   
    If IsGetGl Then
        AddMonth = Val(Mid(daList(AddYear), 15, 2))
        AddDay = Val(Mid(daList(AddYear), 17, 2))
        conDate = DateSerial(AddYear, AddMonth, AddDay)
        AddDay = tDay
        For i = 1 To tMonth - 1
            AddDay = AddDay + 29 + Val(Mid(daList(tYear), i, 1))
        Next i
        'MsgBox DateDiff("d", conDate, Date)
        setDate = DateAdd("d", AddDay - 1, conDate)
        GetYLDate = setDate
        tYear = Year(setDate)
        tMonth = Month(setDate)
        tDay = Day(setDate)
        Exit Function
    End If
CHUSHIHUA:
    AddMonth = Val(Mid(daList(AddYear), 15, 2))
    AddDay = Val(Mid(daList(AddYear), 17, 2))
    conDate = DateSerial(AddYear, AddMonth, AddDay)
    setDate = DateSerial(tYear, tMonth, tDay)
    getDay = DateDiff("d", conDate, setDate)
    If getDay < 0 Then AddYear = AddYear - 1: GoTo CHUSHIHUA
   ' addday = NearDay
   AddDay = 1: AddMonth = 1
    For i = 1 To getDay
        AddDay = AddDay + 1
        If AddDay = 30 + Mid(daList(AddYear), AddMonth, 1) Or (RunYue And AddDay = 30 + Mid(daList(AddYear), 13, 1)) Then
            If RunYue = False And AddMonth = Val("&H" & Mid(daList(AddYear), 14, 1)) Then
                RunYue = True
            Else
                RunYue = False
                AddMonth = AddMonth + 1
            End If
            AddDay = 1
        End If
        
    Next
  
    md$ = "初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十"
    dd$ = Mid(md$, (AddDay - 1) * 2 + 1, 2)
    mm$ = Mid("正二三四五六七八九十寒腊", AddMonth, 1) + "月"
    YouGetDate = DateSerial(AddYear, AddMonth, AddDay)
    tiangan$ = "甲乙丙丁戊已庚辛壬癸"
    dizhi$ = "子丑寅卯辰巳午未申酉戌亥"
    Dim ganzhi(0 To 59) As String * 2
    For i = 0 To 59
     ganzhi(i) = Mid(tiangan$, (i Mod 10) + 1, 1) + Mid(dizhi$, (i Mod 12) + 1, 1)
    'ff$ = ff$ + ganzhi(i)
    Next i
    'MsgBox ff$, , Len(ff$)
    YLyear = ganzhi((AddYear - 4) Mod 60)
    shu$ = "鼠牛虎兔龙蛇马羊猴鸡狗猪"
    YLShuXing = Mid(shu$, ((AddYear - 4) Mod 12) + 1, 1)
    If RunYue Then mm$ = "闰" + mm$
   
    GetYLDate = mm$ + dd$

End Function

递归与组合

---

  发表时间：2004-8-10
作者：未知[获得此文档时候没有作者记录，深感抱歉，本文档全为转载]  

 

       福利彩票和体育彩票近两年比较火暴，相应在VB论坛上大家讨论也较多。其实选择彩票与集合选择子集相同道理。下面给出一种VB的递归算法（虽然明知存入数组会加快运算速度，但最终也没能满意地实现，请大家多多指教。另外，效率确实不高）
Option Explicit

Private Sub Command1_Click()

Dim temp, i As Long, starttime As Long, endtime As Long
starttime = Timer
temp = cmn(22, 6)
endtime = Timer
Open "d:/mofn.txt" For Binary As #1 '写入文件
Put #1, , temp
Close #1

MsgBox UBound(Split(temp, vbCrLf)) + 1 & " 种组合", 64, "共用时 " & endtime - starttime & " 秒" '计算组合可能情况和耗时

End Sub

 

Function cmn(ByVal m As Integer, ByVal n As Integer) As String ' select n number from 1～m
Dim a() As String, temp As String, i As Long

ReDim a(1 To m) '定义数组
For i = 1 To m
a(i) = i
Next

If m = 3 Then
If n = 1 Then cmn = 1 & vbCrLf & 2 & vbCrLf & 3
If n = 2 Then cmn = "1,2" & vbCrLf & "1,3" & vbCrLf & "2,3"
If n = 3 Then cmn = "1,2,3"

ElseIf m > 3 Then
If n = 1 Then cmn = Join(a, vbCrLf)
If n = m Then cmn = Join(a, ",")
If n > 1 And n < m Then
temp = cmn(m - 1, n - 1)
'Debug.Print m - 1 & "," & n - 1 & vbCrLf & "----------------" & vbCrLf & temp & vbCrLf & "---------------------------" & vbCrLf '可以在立即窗口查看算法过程
temp = Replace(temp, vbCrLf, "," & m & vbCrLf) & "," & m
cmn = cmn(m - 1, n) & vbCrLf & temp
End If

End If

End Function

 

下面给出利用集合实现不重复随机选取某几个号码，这个函数也可用来实现数组全部元素的随机排列。

Function getone(ByVal m As Integer, ByVal n As Integer) As String ' one random option to select n number from 1～m without repeat number
Dim a() As String, temp As New Collection, i As Long, tempi As Long

ReDim a(1 To n) '定义数组
For i = 1 To m
temp.Add i   '可以根据需要更改

Next

Randomize
For i = 1 To n
tempi = Int(Rnd * temp.Count) + 1
a(i) = temp(tempi)
temp.Remove tempi
Next
getone = Join(a, ",")
Set temp = Nothing
Erase a
End Function

Private Sub Command2_Click()'演示用法
MsgBox getone(30, 8), 64, "30选8 的一种选法"
MsgBox getone(100, 100), 64, "1 到100 的一种不重复全排列"
End Sub