p0[ - プログラム倉庫

Function trs(tl As Single, th1, th2, y) As Single
Dim b1 As Single
Dim b2 As Single
Dim bs As Single
Dim tr1 As Single
Dim tr2 As Single
Dim tr3 As Single
Dim c(0 To 10) As Single
tr1 = 0.01
tr2 = 0.3
For m = 0 To 10
c(m) = (1 - tl) * y(m) + tr1
Next
b1 = bud(th1, th2, c, y)
For m = 0 To 10
c(m) = (1 - tl) * y(m) + tr2
Next
b2 = bud(th1, th2, c, y)
t = 0
Do Until t > 100
tr3 = (tr1 + tr2) / 2
For m = 0 To 10
c(m) = (1 - tl) * y(m) + tr3
Next
bs = bud(th1, th2, c, y)
If bs > 0 Then tr1 = tr3
If bs < 0 Then tr2 = tr3
If bs ^ 2 < 10 ^ (-5) Then t = 1000
t = t + 1
Loop
trs = tr3
End Function

Function wel(th1, th2, c, y) As Single
Dim m As Single
Dim s1 As Single
Dim s2 As Single
Dim w1 As Single
w1 = 0
For s1 = 1 To 10
For s2 = 1 To 10
m = prefer(s1, s2, th1, th2, c, y)
w1 = w1 + u(m, s1, s2, th1, th2, c, y)
Next
Next
wel = w1
End Function
Function bud(th1, th2, c, y) As Single
Dim m As Single
Dim s1 As Single
Dim s2 As Single
Dim b1 As Single
b1 = 0
For s1 = 1 To 10
For s2 = 1 To 10
m = prefer(s1, s2, th1, th2, c, y)
b1 = b1 + y(m) - c(m)
Next
Next
bud = b1
End Function
Function u(m As Single, s1 As Single, s2 As Single, th1, th2, c, y) As Single
Dim y1 As Single
Dim y2 As Single
Dim l1 As Single
Dim l2 As Single
y2 = (th2(s2) - th1(s1) + y(m)) / 2
y1 = (th1(s1) - th2(s1) + y(m)) / 2
If y2 < 0 Then y1 = y(m)
If y2 < 0 Then y2 = 0
If y1 < 0 Then y2 = y(m)
If y1 < 0 Then y1 = 0
l1 = y1 / th1(s1)
l2 = y2 / th2(s2)
pp = 0
c1 = c(m)
If l1 > 0.99 Then pp = 1
If l2 > 0.99 Then pp = 1
If c1 < 0.01 Then pp = 1
If pp = 1 Then l1 = 0.5
If pp = 1 Then l2 = 0.5
If pp = 1 Then c1 = 0.5
u1 = Log(c1) + Log(1 - l1) + Log(1 - l2)
If pp = 1 Then u1 = -999
u = u1
End Function
Function prefer(s1 As Single, s2 As Single, th1, th2, c, y) As Single
Dim m As Single
Dim u1 As Single
Dim us As Single
Dim ms As Single
us = -999
For m = 0 To 10
u1 = u(m, s1, s2, th1, th2, c, y)
If u1 > us Then ms = m
If u1 > us Then us = u1
Next
prefer = ms
End Function


Private Sub Command1_Click()
Dim m As Single
Dim n As Single
Dim s1 As Single
Dim s2 As Single
Dim th1(1 To 10) As Single
Dim th2(1 To 10) As Single
Dim y(0 To 10) As Single
Dim c(0 To 10) As Single
Dim tl As Single
Dim tr As Single
For s1 = 1 To 10
th1(s1) = 0.1 * s1
Next
For s2 = 1 To 10
th2(s2) = 0.1 * s2
Next
For m = 0 To 10
y(m) = 0.1 * m
Next
ws = -999
For n = 20 To 50
tl = 0.01 * n
tr = trs(tl, th1, th2, y)
For m = 0 To 10
c(m) = (1 - tl) * y(m) + tr
Next
w1 = wel(th1, th2, c, y)
If w1 > ws Then tls = tl
If w1 > ws Then ws = w1
Next
tl = tls
tr = trs(tl, th1, th2, y)
For m = 0 To 10
c(m) = (1 - tl) * y(m) + tr
Debug.Print c(m), y(m)
Next



End Sub