论坛 › 模拟退火法 › 传统 模拟退火算法 源代码（VB.net)

xttataat 发表于 2012-1-13 19:26

传统 模拟退火算法 源代码（VB.net)

贴上本人自己写的模拟退火算法的源代码，开发环境 Visual Basic.net 2005
觉得有用的给个回复，拉拉人气..


Public Class CSA

    Public Function obFun(ByVal x As Double) As Double
        Return 2 * Math.Pow(x, 2) - x - 1
    End Function

    ''' <summary>
    ''' 传统的模拟退火算法
    ''' </summary>
    ''' <param name="Ux ">参数的取值范围上限</param>
    ''' <param name="Lx ">参数的取值范围下限</param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function CSA(ByVal Ux As Double, ByVal Lx As Double) As Double
        Dim init_temperature As Double, total_numk As Double, step_size As Double '定义初始温度,温度k时循环总次数，步长
        Dim x As Double, receivnum As Double '定义变量当前值，前一个值，内循环的接受数据

        '初始化SA参数
        init_temperature = 0.01
        total_numk = 1000
        step_size = 0.001
        receivnum = 50
        x = (Lx - Ux) * Rnd() + Ux '随机产生变量x

        Dim k As Integer = 0 '温度下降次数控制变量
        Dim temperature_k As Double = init_temperature '定义第k次温度
        Dim best_x As Double
        Dim de As Double = 0.0
        Dim fcur As Double = 0.0
        Dim xi As Double

        Dim fprevs As Double = obFun(x)
        Dim xprevs As Double = x
        'SA算法核心
        Do
            'xprevs = x '保留前一个变量值

            '以下三个参数用于估算接受概率
            Dim rec_num As Integer = 0 '接受次数计数器
            Dim temp_i As Double = 0 '记录下面for循环的循环次数
            Dim temp_num = 0 '记录fxi<fx的次数

            For i As Integer = 1 To total_numk
                '产生满足要求的下一个数
                Do
                    xi = x + (2 * Rnd() - 1) * step_size
                Loop While (xi > Ux Or xi < Lx)

                fcur = obFun(xi)
                de = fcur - fprevs

                If de < 0 Then '函数值小的直接进入下次迭代
                    best_x = xi
                    x = xi
                    rec_num += 1
                    temp_num += 1
                    fprevs = fcur
                Else
                    Dim p As Double, r As Double
                    p = Math.Exp(-de / temperature_k)
                    r = Rnd()

                    If p > r Then
                        '以概率的形式接受使函数值变大的数
                        x = xi
                        rec_num += 1
                        fprevs = fcur
                    End If
                End If
                If rec_num > receivnum Then
                    temp_i = i - 1
                    Exit For
                End If
            Next

            k += 1
            temperature_k = init_temperature / (k + 1) '温度下降原则

            If Math.Abs(best_x - 0.25) < 0.00001 Then Exit Do

        Loop While (k < 5000 )
        xprevs = x

        Return best_x
    End Function

End Class


算法测试：
在窗口中添加一个按钮
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
    Dim csa As CSA_Cnhup = New CSA_Cnhup

    Dim x1 As Double, x2 As Double
    x1 = 2 'CDbl(InputBox("参数上限", "参数范围", 2) & " ")
    x2 = -2 'CDbl(InputBox("参数下限", "参数范围", -2) & " ")
    Dim y As Double

    For i As Integer = 0 To 19
        y = csa.CSA(x1, x2)
        Debug.Print("(" & y.ToString & "," & csa.obFun(y).ToString & ")")
    Next
    Debug.Print((New System.Text.StringBuilder).Append("-", 60).ToString)
End Sub

孤寂冷逍遥 发表于 2012-1-13 22:37

{:3_59:}{:3_59:}

IIvEvII 发表于 2012-2-8 22:07

{:3_41:}{:3_41:} 高手啊

李扬@ 发表于 2012-2-8 23:39

顶一个！！！！！！！！！！

喜欢♀讨厌 发表于 2012-2-20 14:28

VB不懂，有C的吗

wadeangle 发表于 2012-6-30 23:02

好    东西  啊v  

瀞沫 发表于 2012-9-8 20:01

这个不错~~

安树庭 发表于 2012-9-13 15:12

表示什么都看不懂  支持一下

wyxxbcy 发表于 2013-1-26 15:08

顶一个。。。。。。。

savcfss 发表于 2013-3-27 21:30

楼主辛苦，多谢！

查看完整版本: 传统 模拟退火算法 源代码（VB.net)