pppp - プログラム倉庫

Function gprefer(s As Single, q, pr, th) As Single
Dim u1 As Single
Dim us As Single
Dim qs As Single
Dim q1 As Single
us = 0
For m = 1 To 7
q1 = q(m)
u1 = u(s, q1, th) - pr(m)
If u1 > us Then qs = q1
If u1 > us Then us = u1
Next
gprefer = qs
End Function


Function rev(p As Single, th) As Single
Dim r1 As Single
Dim s As Single
Dim q As Single
Dim cost As Single
cost = 1
r1 = 0
For s = 1 To 20
q = prefer(s, p, th)
r1 = r1 + (p - cost) * q
Next
rev = r1
End Function

Function prefer(s As Single, p As Single, th) As Single
Dim u1 As Single
Dim us As Single
Dim qs As Single
Dim q As Single
us = 0
For q = 0 To 10
u1 = u(s, q, th) - p * q
If u1 > us Then qs = q
If u1 > us Then us = u1
Next
prefer = qs
End Function
Function u(s As Single, q As Single, th) As Single
u = th(s) * q - q ^ 2
End Function
Private Sub Command1_Click()
Dim s As Single
Dim m As Single
Dim p As Single
Dim th(1 To 20) As Single
Dim q(1 To 7) As Single
Dim pr(1 To 10) As Single
Dim gr(1 To 20) As Single
Dim rev(2 To 6, -1 To 1, -1 To 1, -1 To 1) As Single
Dim rs As Single
Dim ps As Single
Dim r As Single
Dim n1 As Single
Dim n2 As Single
Dim p1 As Single
Dim p2 As Single
For s = 1 To 20
th(s) = s
Next
rs = 0
For p = 2 To 10
r = rev(p, th)
If r > rs Then ps = p
If r > rs Then rs = r
Next
For m = 1 To 7
q(m) = m - 1
pr(m) = ps * q(m)
Next
For s = 1 To 20
gr(s) = gprefer(s, q, pr, th)
Next
n1 = 0
p1 = pr(1) + n1
For s = 1 To 20
If gr(s) = 0 Then pp = 1
End Sub