non - プログラム倉庫

Function prefer(s As Single, th, p) As Single
Dim m As Single
Dim maxm As Single
Dim maxu As Single
Dim u1 As Single
Dim p1 As Single
maxu = -999
For m = 0 To 10
p1 = p(m)
u1 = u(s, th, m, p1)
If u1 > maxu Then maxm = m
If u1 > maxu Then maxu = u1
Next
prefer = maxm
End Function

Function u(s As Single, th, q1 As Single, tr As Single) As Single
Dim x1 As Single
x1 = q1
pp = 0
If x1 < 0 Then pp = 1
If pp = 1 Then x1 = 0
u1 = th(s) * Log(x1 + 1) - tr
If pp = 1 Then u1 = -999
u = u1
End Function

Private Sub Command1_Click()
Dim m As Single
Dim s As Single
Dim p(0 To 10) As Single
Dim th(1 To 10) As Single
Dim gr(1 To 10) As Single
Dim rev(1 To 9, -1 To 1, -1 To 1, -1 To 1) As Single
Dim fast(-1 To 1) As Single
Dim sec(-1 To 1, -1 To 1) As Single
Dim endu(-1 To 1, -1 To 1) As Single
Dim v(1 To 9, -1 To 1, -1 To 1) As Single
Dim endv(-1 To 1, -1 To 1) As Single
Dim gotop(2 To 9, -1 To 1, -1 To 1) As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
Dim h As Single
Dim p1 As Single
Dim p2 As Single
Dim p3 As Single
Dim maxm As Single

For s = 1 To 10
th(s) = s
Next
For m = 1 To 10
p(m) = 2 * m
Next
t1 = 0
h = 0.01
Do Until t1 > 100
For s = 1 To 10
m = prefer(s, th, p)
gr(s) = m
Next
For m = 2 To 9
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
p1 = p(m - 1) + n1 * h
p2 = p(m) + n2 * h
p3 = p(m + 1) + n3 * h
r2 = 0
For s = 1 To 10
u1 = u(s, th, m - 1, p1)
u2 = u(s, th, m, p2)
u3 = u(s, th, m + 1, p3)
maxu = u2
maxm = m
If u1 > maxu Then maxm = m - 1
If u1 > maxu Then maxu = u1
If u3 > maxu Then maxm = m + 1
If maxm = m - 1 Then r1 = p1 - cost * maxm
If maxm = m Then r1 = p2 - cost * maxm
If maxm = m + 1 Then r1 = p3 - cost * maxm
If gr(s) = m Then r2 = r2 + r1
Next
rev(m, n1, n2, n3) = r2
Next
Next
Next
Next

For n1 = -1 To 1
p1 = p(1) + n1 * h
r2 = 0
For s = 1 To 10
u2 = u(s, th, 1, p1)
maxu = 0
maxm = 0
If u2 > maxu Then maxm = 1
r1 = 0
If maxm = 1 Then r1 = p1 - cost * maxm
If gr(s) = 0 Then r2 = r2 + r1
Next
fast(n1) = r2
Next

For n1 = -1 To 1
For n2 = -1 To 1
p1 = p(1) + n1 * h
p2 = p(2) + n2 * h
r2 = 0
For s = 1 To 10
u1 = u(s, th, 0, 0)
u2 = u(s, th, 1, p1)
u3 = u(s, th, 2, p2)
maxu = u1
maxm = 0
If u2 > maxu Then maxm = 1
If u2 > maxu Then maxu = u2
If u3 > maxu Then maxm = 2
r1 = 0
If maxm = 1 Then r1 = p1 - cost * maxm
If maxm = 2 Then r1 = p2 - cost * maxm
If gr(s) = 1 Then r2 = r2 + r1
Next
sec(n1, n2) = r2
Next
Next

For n1 = -1 To 1
For n2 = -1 To 1
p1 = p(9) + n1 * h
p2 = p(10) + n2 * h
r2 = 0
For s = 1 To 10
u1 = u(s, th, 9, p1)
u2 = u(s, th, 10, p2)
maxu = u1
maxm = 9
If u2 > maxu Then maxm = 10
r1 = 0
If maxm = 9 Then r1 = p1 - cost * maxm
If maxm = 10 Then r1 = p2 - cost * maxm
If gr(s) = 10 Then r2 = r2 + r1
Next
endu(n1, n2) = r2
Next
Next

For n1 = -1 To 1
For n2 = -1 To 1
v(1, n1, n2) = sec(n1, n2) + fast(n2)
Next
Next

For m = 2 To 9
For n1 = -1 To 1
For n2 = -1 To 1
vs = -999
For nx = -1 To 1
r1 = rev(m, nx, n1, n2)
v1 = r1 + v(m - 1, nx, n1)
If v1 > vs Then nxs = nx
If v1 > vs Then vs = v1
Next
gotop(m, n1, n2) = nxs
v(m, n1, n2) = vs
Next
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
r1 = endu(n1, n2)
vs = -999
For nx = -1 To 1
v1 = r1 + v(9, nx, n1)
If v1 > vs Then vs = v1
Next
endv(n1, n2) = vs
Next
Next
vs = -999
For n1 = -1 To 1
For n2 = -1 To 1
If endv(n1, n2) > vs Then nx1 = n1
If endv(n1, n2) > vs Then nx2 = n2
If endv(n1, n2) > vs Then vs = endv(n1, n2)
Next
Next
Dim op(1 To 10) As Single
op(9) = nx1
op(10) = nx2
For j = 1 To 8
m = 9 - j
op(m) = gotop(m + 1, op(m + 1), op(m + 2))
Next
For m = 1 To 10
p(m) = p(m) + op(m) * h
Next
e = 0
Dim pre(1 To 10) As Single
For s = 1 To 10
m = prefer(s, th, p)
e = e + (p(m) - pre(s)) ^ 2
Next
For s = 1 To 10
m = prefer(s, th, p)
pre(s) = p(m)
Next
If e < 10 ^ (-6) Then h = h / 2
If h < 10 ^ (-6) Then t1 = 1000
Debug.Print t1, e, vs
t1 = t1 + 1
Loop
For s = 1 To 10
m = prefer(s, th, p)
Debug.Print m, p(m)
Next
End Sub