ppo - プログラム倉庫

Function endf(gr, th, fee, n1 As Single, n2 As Single) As Single
Dim q1 As Single
Dim q2 As Single
Dim q3 As Single
Dim f1 As Single
Dim f2 As Single
Dim f3 As Single
Dim u1 As Single
Dim u2 As Single
Dim u3 As Single
Dim s As Single
Dim cost As Single
cost = 1
rxs = 0
For s = 1 To 20
q1 = 5
q2 = 6
f1 = fee(5) + n1
f2 = fee(6) + n2
us = 0
u1 = u(s, th, q1, f1)
u2 = u(s, th, q2, f2)
rs = 0
If u1 > us Then rs = f1 - cost * q1
If u1 > us Then us = u1
If u2 > us Then rs = f2 - cost * q2
If u2 > us Then us = u2
If gr(s) = 6 Then rxs = rxs + rs
Next
endf = rxs
End Function
Function seekf(m As Single, gr, th, fee, n1 As Single, n2 As Single, n3 As Single) As Single
Dim q1 As Single
Dim q2 As Single
Dim q3 As Single
Dim f1 As Single
Dim f2 As Single
Dim f3 As Single
Dim u1 As Single
Dim u2 As Single
Dim u3 As Single
Dim s As Single
Dim cost As Single
cost = 1
rxs = 0
For s = 1 To 20
q1 = m - 1
q2 = m
q3 = m + 1
f1 = fee(m - 1) + n1
f2 = fee(m) + n2
f3 = fee(m + 1) + n3
u1 = u(s, th, q1, f1)
u2 = u(s, th, q2, f2)
u3 = u(s, th, q3, f3)
us = -999
If u1 > us Then rs = f1 - cost * q1
If u1 > us Then us = u1
If u2 > us Then rs = f2 - cost * q2
If u2 > us Then us = u2
If u1 > us Then rs = f3 - cost * q3
If u2 > us Then us = u3
If gr(s) = m Then rxs = rxs + rs
Next
seekf = rxs
End Function

Function fastf(gr, th, fee, n1 As Single, n2 As Single) As Single
Dim q1 As Single
Dim q2 As Single
Dim q3 As Single
Dim f1 As Single
Dim f2 As Single
Dim f3 As Single
Dim u1 As Single
Dim u2 As Single
Dim u3 As Single
Dim s As Single
Dim cost As Single
cost = 1
rxs = 0
For s = 1 To 20
q1 = 0
q2 = 1
q3 = 2
f1 = 0
f2 = fee(1) + n1
f3 = fee(2) + n2
us = 0
u2 = u(s, th, q2, f2)
u3 = u(s, th, q3, f3)
rs = 0
If u2 > us Then rs = f2 - cost * q2
If u2 > us Then us = u2
If u3 > us Then rs = f3 - cost * q3
If gr(s) = 1 Then rxs = rxs + rs
Next
fastf = rxs
End Function
Function zerof(gr, th, fee, n1 As Single) As Single
Dim q1 As Single
Dim q2 As Single
Dim q3 As Single
Dim f1 As Single
Dim f2 As Single
Dim f3 As Single
Dim u1 As Single
Dim u2 As Single
Dim u3 As Single
Dim s As Single
Dim cost As Single
cost = 1
rxs = 0
For s = 1 To 20
q1 = 1
f1 = fee(1) + n1
us = 0
u1 = u(s, th, q1, f1)
rs = 0
If u1 > us Then rs = f1 - cost * q1
If gr(s) = 0 Then rxs = rxs + rs
Next
zerof = rxs
End Function


Function u(s As Single, th, q As Single, f1 As Single) As Single
u = th(s) * q - q ^ 2 - f1
End Function
Function prefer(s As Single, th, fee) As Single
Dim q As Single
Dim qs As Single
Dim f1 As Single
Dim us As Single
us = -999
For q = 0 To 10
f1 = fee(q)
u1 = u(s, th, q, f1)
If u1 > us Then qs = q
If u1 > us Then us = u1
Next
prefer = qs
End Function

Function rev(th, fee) As Single
Dim s As Single
Dim q As Single
Dim cost As Single
Dim r1 As Single
cost = 1
r1 = 0
For s = 1 To 20
q = prefer(s, th, fee)
r1 = r1 + fee(q) - cost * q
Next
rev = r1
End Function
Private Sub Command1_Click()
Dim s As Single
Dim m As Single
Dim th(1 To 20) As Single
Dim fee(0 To 10) As Single
Dim gr(1 To 20) As Single
Dim f(1 To 6, -1 To 1, -1 To 1, -1 To 1) As Single
Dim zero(-1 To 1) As Single
Dim end6(-1 To 1, -1 To 1) As Single
Dim v(2 To 6, -1 To 1, -1 To 1) As Single
Dim gotof(2 To 6, -1 To 1, -1 To 1) As Single
Dim fastv(-1 To 1, -1 To 1) As Single
Dim q As Single
Dim price As Single
Dim ps As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
For s = 1 To 20
th(s) = s
Next
For price = 1 To 10
For q = 0 To 10
fee(q) = price * q
Next
r1 = rev(th, fee)
If r1 > rs Then ps = price
If r1 > rs Then rs = r1
Next
price = ps
For q = 0 To 6
fee(q) = price * q
Next
For q = 7 To 10
fee(q) = 500
Next
t1 = 0
Do Until t1 > 5
For s = 1 To 20
gr(s) = prefer(s, th, fee)
Next
For n1 = -1 To 1
zero(n1) = zerof(gr, th, fee, n1)
Next
m = 1
For n1 = -1 To 1
For n2 = -1 To 1
f(m, 0, n1, n2) = fastf(gr, th, fee, n1, n2)
Next
Next
For m = 2 To 5
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
f(m, n1, n2, n3) = seekf(m, gr, th, fee, n1, n2, n3)
Next
Next
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
end6(n1, n2) = endf(gr, th, fee, n1, n2)
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
fastv(n1, n2) = zero(n1) + f(1, 0, n1, n2)
Next
Next
m = 2
For n1 = -1 To 1
For n2 = -1 To 1
vs = -999
For nx = -1 To 1
f1 = f(m, nx, n1, n2)
v1 = f1 + fastv(nx, n1)
If v1 > vs Then vs = v1
Next
v(m, n1, n2) = vs
Next
Next
For m = 3 To 5
For n1 = -1 To 1
For n2 = -1 To 1
vs = -999
For nx = -1 To 1
f1 = f(m, nx, n1, n2)
v1 = f1 + v(m - 1, nx, n1)
If v1 > vs Then nxs = nx
If v1 > vs Then vs = v1
Next
v(m, n1, n2) = vs
gotof(m, n1, n2) = nxs
Next
Next
Next
Dim endv(-1 To 1, -1 To 1) As Single
For n1 = -1 To 1
For n2 = -1 To 1
u1 = end6(n1, n2)
endv(n1, n2) = u1 + v(5, n1, n2)
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
Debug.Print t1, vs
Dim op(1 To 6) As Single
op(6) = nx2
op(5) = nx1
op(4) = gotof(5, op(5), op(6))
op(3) = gotof(4, op(4), op(5))
op(2) = gotof(3, op(3), op(4))
op(1) = gotof(2, op(2), op(3))
For m = 1 To 6
If vs > vp Then fee(m) = fee(m) + op(m)
Next
If vp > vs Then t1 = 1000
vp = vs
t1 = t1 + 1
Loop
For m = 1 To 6
Debug.Print m, fee(m)
Next

End Sub