2008 01 - プログラム倉庫

Public Class Form1
    'Imports System.Math
    Function mlx(ByVal s1 As Single, ByVal s2 As Single, ByVal tk As Single, ByVal tl As Single, ByVal tr As Single) As Single
        Dim w1 As Single
        Dim w2 As Single
        Dim l1 As Single
        Dim l2 As Single
        Dim th1(10) As Single
        Dim th2(10) As Single
        For s = 1 To 10
            th1(s) = 0.2 * s
            th2(s) = 0.1 * s
        Next

        w1 = (1 - tk) * th1(s1)
        w2 = (1 - tl) * th2(s2)
        l1 = 1 - (w1 + w2 + tr) / (3 * w1)
        l2 = 1 - (w1 + w2 + tr) / (3 * w2)
        If l2 < 0 Then l1 = 1 - (w1 + tr) / (2 * w1)
        If l1 < 0 Then l1 = 0
        mlx = l1
    End Function
    Function flx(ByVal s1 As Single, ByVal s2 As Single, ByVal tk As Single, ByVal tl As Single, ByVal tr As Single) As Single
        Dim w1 As Single
        Dim w2 As Single
        Dim l1 As Single
        Dim l2 As Single

        Dim th1(10) As Single
        Dim th2(10) As Single
        For s = 1 To 10
            th1(s) = 0.2 * s
            th2(s) = 0.1 * s
        Next
        w1 = (1 - tk) * th1(s1)
        w2 = (1 - tl) * th2(s2)
        l1 = 1 - (w1 + w2 + tr) / (3 * w1)
        l2 = 1 - (w1 + w2 + tr) / (3 * w2)
        If l1 < 0 Then l2 = 1 - (w2 + tr) / (2 * w2)
        If l2 < 0 Then l2 = 0
        flx = l2
    End Function

    Function cx(ByVal s1 As Single, ByVal s2 As Single, ByVal tk As Single, ByVal tl As Single, ByVal tr As Single) As Single
        Dim w1 As Single
        Dim w2 As Single
        Dim l1 As Single
        Dim l2 As Single
        Dim th1(10) As Single
        Dim th2(10) As Single
        For s = 1 To 10
            th1(s) = 0.2 * s
            th2(s) = 0.1 * s
        Next
        w1 = (1 - tk) * th1(s1)
        w2 = (1 - tl) * th2(s2)
        l1 = mlx(s1, s2, tk, tl, tr)
        l2 = flx(s1, s2, tk, tl, tr)
        cx = w1 * l1 + w2 * l2 + tr
    End Function

    Function u(ByVal c1 As Single, ByVal l1 As Single, ByVal l2 As Single) As Single
        u = Math.Log(c1) + Math.Log(1 - l1) + Math.Log(1 - l2)
    End Function
    Function tls(ByVal th1, ByVal th2) As Single
        Dim n As Single
        Dim tl As Single
        Dim tk As Single
        Dim tr As Single
        Dim c(10, 10) As Single
        Dim maxw As Single
        Dim maxtl As Single
        Dim w1 As Single
        maxw = -999
        For m = 1 To 50
            For n = 1 To 50
                tk = 0.01 * m
                tl = 0.01 * n
                tr = trs(tk, tl)
                w1 = wel(tk, tl, tr)
                If w1 > maxw Then maxtl = tl
                If w1 > maxw Then maxw = w1
            Next
        Next
        tls = maxtl
    End Function
    Function tks(ByVal tl As Single) As Single
        Dim m As Single
        Dim tk As Single
        Dim tr As Single
        Dim maxw As Single
        Dim maxtk As Single
        Dim w1 As Single
        maxw = -999
        For m = 1 To 50
            tk = 0.01 * m
            tr = trs(tk, tl)
            w1 = wel(tk, tl, tr)
            If w1 > maxw Then maxtk = tk
            If w1 > maxw Then maxw = w1
        Next
        tks = maxtk
    End Function


    Function trs(ByVal tk As Single, ByVal tl As Single) As Single
        Dim m As Single
        Dim tr1 As Single
        Dim tr2 As Single
        Dim tr3 As Single
        Dim b1 As Single
        Dim b2 As Single
        Dim b3 As Single
        Dim t As Single
        tr1 = 0.01
        b1 = bud(tk, tl, tr1)
        tr2 = 0.5
        b2 = bud(tk, tl, tr2)
        t = 0
        Do Until t > 100
            tr3 = (tr1 + tr2) / 2
            b3 = bud(tk, tl, tr3)
            If b3 > 0 Then b1 = b3
            If b3 > 0 Then tr1 = tr3
            If b3 < 0 Then b2 = b3
            If b3 < 0 Then tr2 = tr3
            If b3 ^ 2 < 10 ^ (-5) Then t = 1000
            t = t + 1
        Loop
        trs = tr1
    End Function
    Function bud(ByVal tk As Single, ByVal tl As Single, ByVal tr As Single) As Single
        Dim b1 As Single
        Dim s As Single
        Dim s1 As Single
        Dim s2 As Single
        Dim l1 As Single
        Dim l2 As Single
        Dim c1 As Single
        Dim th1(10) As Single
        Dim th2(10) As Single
        For s = 1 To 10
            th1(s) = 0.2 * s
            th2(s) = 0.1 * s
        Next
        b1 = 0
        For s1 = 1 To 10
            For s2 = 1 To 10
                l1 = mlx(s1, s2, tk, tl, tr)
                l2 = flx(s1, s2, tk, tl, tr)
                c1 = cx(s1, s2, tk, tl, tr)
                b1 = b1 + th1(s1) * l1 + th2(s2) * l2 - c1
            Next
        Next
        bud = b1
    End Function
    Function wel(ByVal tk As Single, ByVal tl As Single, ByVal tr As Single) As Single
        Dim w1 As Single
        Dim l2 As Single
        Dim l1 As Single
        Dim c1 As Single
        Dim s1 As Single
        Dim s2 As Single
        w1 = 0
        For s1 = 1 To 10
            For s2 = 1 To 10
                l1 = mlx(s1, s2, tk, tl, tr)
                l2 = flx(s1, s2, tk, tl, tr)
                c1 = cx(s1, s2, tk, tl, tr)
                w1 = w1 + u(c1, l1, l2)
            Next
        Next
        wel = w1
    End Function
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        Dim s As Single
        Dim th1(10) As Single
        Dim th2(10) As Single
        Dim y1(10, 10) As Single
        Dim y2(10, 10) As Single
        Dim c(10, 10) As Single
        Dim tl As Single
        Dim tk As Single
        Dim tr As Single
        Dim s1 As Single
        Dim s2 As Single
        For s = 1 To 10
            th1(s) = 0.2 * s
            th2(s) = 0.1 * s
        Next
        tl = tls(th1, th2)
        tk = tks(tl)
        tr = trs(tk, tl)
        For s1 = 1 To 10
            For s2 = 1 To 10
                y1(s1, s2) = th1(s1) * mlx(s1, s2, tk, tl, tr)
                y2(s1, s2) = th2(s2) * flx(s1, s2, tk, tl, tr)
                c(s1, s2) = cx(s1, s2, tk, tl, tr)
            Next
        Next
        Button1.Text = tl
    End Sub

End Class