きｈ￥ - プログラム倉庫

Function fprefer(s As Single, z1, z2, th1, th2, c, y1, y2) As Single
Dim m As Single
Dim maxu As Single
Dim maxm As Single
Dim u1 As Single
Dim c1 As Single
Dim my As Single
Dim fy As Single
Dim i As Single
Dim j As Single
maxu = -999
For i = -1 To 1
For j = -1 To 1
m1 = z1(s) + i
m2 = z2(s) + j
If m1 > 10 Then m1 = 10
If m1 < 0 Then m1 = 0
If m2 > 10 Then m2 = 10
If m2 < 0 Then m2 = 0
c1 = c(m1, m2)
my = y1(m1)
fy = y2(m2)
u1 = u(s, th1, th2, c1, my, fy)
If u1 > maxu Then maxm = m2
If u1 > maxu Then maxu = u1
Next
Next
fprefer = maxm
End Function
Function mprefer(s As Single, z1, z2, th1, th2, c, y1, y2) As Single
Dim m As Single
Dim maxu As Single
Dim maxm As Single
Dim u1 As Single
Dim c1 As Single
Dim my As Single
Dim fy As Single
Dim i As Single
Dim j As Single
maxu = -999
For i = -1 To 1
For j = -1 To 1
m1 = z1(s) + i
m2 = z2(s) + j
If m1 > 10 Then m1 = 10
If m1 < 0 Then m1 = 0
If m2 > 10 Then m2 = 10
If m2 < 0 Then m2 = 0
c1 = c(m1, m2)
my = y1(m1)
fy = y2(m2)
u1 = u(s, th1, th2, c1, my, fy)
If u1 > maxu Then maxm = m1
If u1 > maxu Then maxu = u1
Next
Next
mprefer = maxm
End Function

Function secprefer(s As Single, th1, th2, c, y1, y2) As Single
Dim m As Single
Dim maxu As Single
Dim maxm As Single
Dim u1 As Single
Dim c1 As Single
Dim my As Single
Dim fy As Single
maxu = -999
For m1 = 0 To 10
For m2 = 0 To 10
c1 = c(m1, m2)
my = y1(m1)
fy = y2(m2)
u1 = u(s, th1, th2, c1, my, fy)
If u1 > maxu Then maxm = m2
If u1 > maxu Then maxu = u1
Next
Next
secprefer = maxm
End Function
Function fastprefer(s As Single, th1, th2, c, y1, y2) As Single
Dim m As Single
Dim maxu As Single
Dim maxm As Single
Dim u1 As Single
Dim c1 As Single
Dim my As Single
Dim fy As Single
maxu = -999
For m1 = 0 To 10
For m2 = 0 To 10
c1 = c(m1, m2)
my = y1(m1)
fy = y2(m2)
u1 = u(s, th1, th2, c1, my, fy)
If u1 > maxu Then maxm = m1
If u1 > maxu Then maxu = u1
Next
Next
fastprefer = maxm
End Function
Function u(s As Single, th1, th2, cp As Single, yp1 As Single, yp2 As Single) As Single
Dim lx As Single
Dim cx As Single
Dim px As Single
l1 = yp1 / th1(s)
l2 = yp2 / th2(s)
cx = cp
px = 0
If cx < 0.01 Then px = 1
If l1 > 0.99 Then px = 1
If l2 > 0.99 Then px = 1
If px = 1 Then cx = 0.5
If px = 1 Then l1 = 0.5
If px = 1 Then l2 = 0.5
ux = Log(cx) + Log(1 - l1) + Log(1 - l2)
If px = 1 Then ux = -999
u = ux
End Function

Function bud(z1, z2, th1, th2, c, y1, y2) As Single
Dim b1 As Single
Dim s As Single
Dim m1 As Single
Dim m2 As Single
b1 = 0
For s = 1 To 100
m1 = mprefer(s, z1, z2, th1, th2, c, y1, y2)
m2 = fprefer(s, z1, z2, th1, th2, c, y1, y2)
b1 = b1 + y1(m1) + y2(m2) - c(m1, m2)
Next
bud = b1
End Function
Function wel(z1, z2, th1, th2, c, y1, y2) As Single
Dim w1 As Single
Dim s As Single
Dim m As Single
Dim c1 As Single
Dim my As Single
Dim fy As Single
w1 = 0
For s = 1 To 100
m1 = mprefer(s, z1, z2, th1, th2, c, y1, y2)
m2 = fprefer(s, z1, z2, th1, th2, c, y1, y2)
c1 = c(m1, m2)
my = y1(m1)
fy = y2(m2)
w1 = w1 + u(s, th1, th2, c1, my, fy)
Next
wel = w1
End Function

Private Sub Command1_Click()
Dim s As Single
Dim m As Single
Dim th1(1 To 100) As Single
Dim th2(1 To 100) As Single
Dim z1(1 To 100) As Single
Dim z2(1 To 100) As Single
Dim y1(0 To 10) As Single
Dim y2(0 To 10) As Single
Dim c(0 To 10, 0 To 10) As Single
Dim cs(0 To 10, 0 To 10) As Single
Dim x(0 To 10, 0 To 10) As Single
Dim tl As Single
Dim tk As Single
Dim tr As Single
Dim s1 As Single
Dim c1 As Single
Dim w1 As Single
Dim w2 As Single
Dim x1 As Single
Dim maxw As Single
s1 = 1
s2 = 1
For s = 1 To 100
th1(s) = 0.2 * s1
th2(s) = 0.1 * s2
s1 = s1 + 1
If s1 = 11 Then s2 = s2 + 1
If s1 = 11 Then s1 = 1
Next
For m = 0 To 10
y1(m) = 0.1 * m
Next
For m = 0 To 10
y2(m) = 0.05 * m
Next
Open "c:/lupin.txt" For Input As #2
Do Until EOF(2)
Input #2, a1, a2, a3
m1 = a1
m2 = a2
cs(m1, m2) = a3
Loop
Close #2
For m1 = 0 To 10
For m2 = 0 To 10
c(m1, m2) = cs(m1, m2)
Next
Next
For s = 1 To 100
z1(s) = fastprefer(s, th1, th2, c, y1, y2)
z2(s) = secprefer(s, th1, th2, c, y1, y2)
Next
maxw = -999
h = 0.0005
t2 = 0
Do Until t2 > 5
t1 = 0
Do Until t1 > 1000
For m1 = 0 To 10
For m2 = 0 To 10
Randomize
x1 = Rnd()
x(m1, m2) = 0
If x1 > 0.7 Then x(m1, m2) = 1
If x1 < 0.3 Then x(m1, m2) = -1
Next
Next
For m1 = 0 To 10
For m2 = 0 To 10
c(m1, m2) = cs(m1, m2) + h * x(m1, m2)
Next
Next
w1 = wel(z1, z2, th1, th2, c, y1, y2)
b1 = bud(z1, z2, th1, th2, c, y1, y2)
If b1 < 0 Then w1 = -999
For s = 1 To 100
If w1 > maxw Then z1(s) = fastprefer(s, th1, th2, c, y1, y2)
If w1 > maxw Then z2(s) = secprefer(s, th1, th2, c, y1, y2)
Next
For m1 = 0 To 10
For m2 = 0 To 10
If w1 > maxw Then cs(m1, m2) = c(m1, m2)
Next
Next
t1 = t1 + 1
If w1 > maxw Then maxw = w1
Loop
Debug.Print t2, maxw
h = h / 2
t2 = t2 + 1
Loop
End Sub