ｍぽぉ - プログラム倉庫

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 fprefer(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
fprefer = maxm
End Function
Function mprefer(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
mprefer = maxm
End Function

Function mselect(s As Single, mgr, fgr, th1, th2, c, y1, y2) As Single
Dim m As Single
Dim maxu As Single
Dim maxm As Single
Dim nu1 As Single
Dim nu2 As Single
Dim u1 As Single
Dim c1 As Single
Dim my As Single
Dim fy As Single
maxu = -999
For nu1 = -1 To 1
For nu2 = -1 To 1
m1 = mgr(s) + nu1
m2 = fgr(s) + nu2
If m1 > 10 Then m1 = 10
If m2 > 10 Then m2 = 10
If m1 < 0 Then m1 = 0
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
mselect = maxm
End Function
Function fselect(s As Single, mgr, fgr, 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 nu1 As Single
Dim nu2 As Single
maxu = -999
For nu1 = -1 To 1
For nu2 = -1 To 1
m1 = mgr(s) + nu1
m2 = fgr(s) + nu2
If m1 > 10 Then m1 = 10
If m2 > 10 Then m2 = 10
If m1 < 0 Then m1 = 0
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
fselect = maxm
End Function

Private Sub Command1_Click()
Dim s As Single
Dim sumy As Single
Dim sumu As Single
Dim m As Single
Dim m1 As Single
Dim m2 As Single
Dim th1(1 To 100) As Single
Dim th2(1 To 100) As Single
Dim y1(0 To 10) As Single
Dim y2(0 To 10) As Single
Dim opc(0 To 10) As Single
Dim opq(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 mgr(1 To 100) As Single
Dim fgr(1 To 100) As Single
Dim gu(1 To 9, -1 To 1, -1 To 1, -1 To 1) As Single
Dim gb(1 To 9, -1 To 1, -1 To 1, -1 To 1) As Single
Dim v(0 To 9, -1 To 1, -1 To 1, -100 To 100) As Single
Dim gotoc(0 To 9, -1 To 1, -1 To 1, -100 To 100) As Single
Dim gotoq(0 To 9, -1 To 1, -1 To 1, -100 To 100) As Single
Dim fastu(-1 To 1, -1 To 1) As Single
Dim fastb(-1 To 1, -1 To 1) As Single
Dim endb(-1 To 1, -1 To 1) As Single
Dim endu(-1 To 1, -1 To 1) As Single
Dim endv(-1 To 1, -1 To 1, -100 To 100) As Single
Dim endq(-1 To 1, -1 To 1, -100 To 100) 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
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
c(m1, m2) = a3
Loop
Close #2
h = 0.01
t = 0
Do Until t > 100
For s = 1 To 100
mgr(s) = mprefer(s, th1, th2, c, y1, y2)
fgr(s) = fprefer(s, th1, th2, c, y1, y2)
Next
For m = 1 To 9
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
For m1 = 0 To 10
For m2 = 0 To 10
cs(m1, m2) = c(m1, m2)
Next
Next
cs(m - 1, 0) = c(m - 1, 0) + n1 * h
cs(m, 0) = c(m, 0) + n2 * h
cs(m + 1, 0) = c(m + 1, 0) + n3 * h
sumu = 0
sumy = 0
For s = 1 To 100
m1 = mselect(s, mgr, fgr, th1, th2, cs, y1, y2)
m2 = fselect(s, mgr, fgr, th1, th2, cs, y1, y2)
u1 = u(s, th1, th2, cs(m1, m2), y1(m1), y2(m2))
If mgr(s) = m Then sumu = sumu + u1
If mgr(s) = m Then sumy = sumy + y1(m1) + y2(m2) - cs(m1, m2)
Next
gu(m, n1, n2, n3) = sumu
gb(m, n1, n2, n3) = sumy
Next
Next
Next
Debug.Print m
Next
For n1 = -1 To 1
For n2 = -1 To 1
For m1 = 0 To 10
For m2 = 0 To 10
cs(m1, m2) = c(m1, m2)
Next
Next
cs(0, 0) = c(m - 1, 0) + n1 * h
cs(1, 0) = c(m, 0) + n2 * h
sumu = 0
sumy = 0
For s = 1 To 100
m1 = mselect(s, mgr, fgr, th1, th2, cs, y1, y2)
m2 = fselect(s, mgr, fgr, th1, th2, cs, y1, y2)
u1 = u(s, th1, th2, cs(m1, m2), y1(m1), y2(m2))
If mgr(s) = 0 Then sumu = sumu + u1
If mgr(s) = 0 Then sumy = sumy + y1(m1) + y2(m2) - cs(m1, m2)
Next
fastu(n1, n2) = sumu
fastb(n1, n2) = sumy
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
For m1 = 0 To 10
For m2 = 0 To 10
cs(m1, m2) = c(m1, m2)
Next
Next
cs(9, 0) = c(m - 1, 0) + n1 * h
cs(10, 0) = c(m, 0) + n2 * h
sumu = 0
sumy = 0
For s = 1 To 100
m1 = mselect(s, mgr, fgr, th1, th2, cs, y1, y2)
m2 = fselect(s, mgr, fgr, th1, th2, cs, y1, y2)
u1 = u(s, th1, th2, cs(m1, m2), y1(m1), y2(m2))
If mgr(s) = 10 Then sumu = sumu + u1
If mgr(s) = 10 Then sumy = sumy + y1(m1) + y2(m2) - cs(m1, m2)
Next
endu(n1, n2) = sumu
endb(n1, n2) = sumy
Next
Next
For m = 0 To 9
For n1 = -1 To 1
For n2 = -1 To 1
For q = -100 To 100
v(m, n1, n2, q) = -999
Next
Next
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
q = fastb(n1, n2) - fastb(0, 0)
q = Int(q / h)
v(0, n1, n2, q) = fastu(n1, n2)
Next
Next
For m = 1 To 9
For n1 = -1 To 1
For n2 = -1 To 1
For q = -100 To 100
vs = -999
For nx = -1 To 1
u1 = gu(m, nx, n1, n2)
q1 = gb(m, nx, n1, n2) - gb(m, 0, 0, 0)
q1 = Int(q1 / h)
qx = q - q1
pp = 0
If qx > 100 Then pp = 1
If qx < -100 Then pp = 1
If pp = 1 Then qx = 0
v1 = u1 + v(m - 1, nx, n1, qx)
If pp = 1 Then v1 = -999
If v1 > vs Then nxs = nx
If v1 > vs Then qs = qx
If v1 > vs Then vs = v1
Next
gotoc(m, n1, n2, q) = nxs
gotoq(m, n1, n2, q) = qs
v(m, n1, n2, q) = vs
Next
Next
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
For q = -100 To 100
u1 = endu(n1, n2)
q1 = endb(n1, n2) - endb(0, 0)
qx = q - Int(q1 / h)
endv(n1, n2, q) = u1 + v(9, n1, n2, qx)
endq(n1, n2, q) = qx
Next
Next
Next
maxv = -999
For n1 = -1 To 1
For n2 = -1 To 1
For q = -opq(10) To 100
If endv(n1, n2, q) > maxv Then nx1 = n1
If endv(n1, n2, q) > maxv Then nx2 = n2
If endv(n1, n2, q) > maxv Then qs = q
If endv(n1, n2, q) > maxv Then maxv = endv(n1, n2, q)
Next
Next
Next
opc(10) = nx2
opc(9) = nx1
opq(10) = qs
opq(9) = endq(opc(9), opc(10), opq(10))
For j = 1 To 9
m = 9 - j
opc(m) = gotoc(m + 1, opc(m + 1), opc(m + 2), opq(m + 1))
opq(m) = gotoc(m + 1, opc(m + 1), opc(m + 2), opq(m + 1))
Next
For m = 0 To 10
c(m, 0) = c(m, 0) + opc(m) * h
Next
e = 0
For m = 0 To 9
e = e + opc(m) ^ 2
Next
If e < 1 Then h = h / 2
If h < 10 ^ (-5) Then t = 1000
Debug.Print t, e, maxv
t = t + 1
Loop
For m = 1 To 8
c1 = c(m + 1, 0) - c(m, 0)
yp = y1(m + 1) - y1(m)
Debug.Print y1(m), 1 - c1 / yp
Next
End Sub