lamdsa - プログラム倉庫

Function wel(th, c, y) As Single
Dim w1 As Single
Dim s As Single
Dim m As Single
w1 = 0
For s = 1 To 100
m = prefer(s, th, c, y)
w1 = w1 + Log(c(m)) + Log(1 - y(m) / th(s))
Next
wel = w1
End Function
Function bud(th, c, y) As Single
Dim b1 As Single
Dim s As Single
Dim m As Single
b1 = 0
For s = 1 To 100
m = prefer(s, th, c, y)
b1 = b1 + y(m) - c(m)
Next
bud = b1
End Function
Function seeku(m As Single, th, gr, c1 As Single, c2 As Single, c3 As Single, y1 As Single, y2 As Single, y3 As Single, lam As Single) As Single
Dim s As Single
Dim u1 As Single
Dim u2 As Single
Dim u3 As Single
Dim us As Single
Dim sumu As Single
sumu = 0
For s = 1 To 100
us = -999
If gr(s) = m Then u1 = Log(c1) + Log(1 - y1 / th(s))
If gr(s) = m Then u2 = Log(c2) + Log(1 - y2 / th(s))
If gr(s) = m Then u3 = Log(c3) + Log(1 - y3 / th(s))
zs = 0
If u1 > us Then zs = lam * (y1 - c1)
If u1 > us Then us = u1
If u2 > us Then zs = lam * (y2 - c2)
If u2 > us Then us = u2
If u3 > us Then zs = lam * (y3 - c3)
If u3 > us Then us = u3
If gr(s) = m Then sumu = sumu + us + zs
Next
seeku = sumu
End Function

Function eseeku(th, gr, c1 As Single, c2 As Single, y1 As Single, y2 As Single, lam As Single) As Single
Dim s As Single
Dim u1 As Single
Dim u2 As Single
Dim u3 As Single
Dim us As Single
Dim sumu As Single
sumu = 0
For s = 1 To 100
us = -999
If gr(s) = 10 Then u1 = Log(c1) + Log(1 - y1 / th(s))
If gr(s) = 10 Then u2 = Log(c2) + Log(1 - y2 / th(s))
zs = 0
If u1 > us Then zs = lam * (y1 - c1)
If u1 > us Then us = u1
If u2 > us Then zs = lam * (y2 - c2)
If u2 > us Then us = u2
If gr(s) = 10 Then sumu = sumu + us + zs
Next
eseeku = sumu
End Function

Function fseeku(th, gr, c1 As Single, c2 As Single, y1 As Single, y2 As Single, lam) As Single
Dim s As Single
Dim u1 As Single
Dim u2 As Single
Dim u3 As Single
Dim us As Single
Dim sumu As Single
sumu = 0
For s = 1 To 100
us = -999
If gr(s) = 0 Then u1 = Log(c1) + Log(1 - y1 / th(s))
pp = 0
l2 = y2 / th(s)
If l2 > 0.99 Then pp = 1
If l2 > 0.99 Then l2 = 0.5
If gr(s) = 0 Then u2 = Log(c2) + Log(1 - l2)
If pp = 1 Then u2 = -999
zs = 0
If u1 > us Then zs = lam * (y1 - c1)
If u1 > us Then us = u1
If u2 > us Then zs = lam * (y2 - c2)
If u2 > us Then us = u2
If gr(s) = 0 Then sumu = sumu + us + zs
Next
fseeku = sumu
End Function

Function prefer(s As Single, th, c, y) As Single
Dim m As Single
Dim maxu As Single
Dim maxm As Single
Dim u1 As Single
Dim c1 As Single
Dim l1 As Single
maxu = -999
For m = 0 To 10
c1 = c(m)
l1 = y(m) / th(s)
pp = 0
If l1 > 0.99 Then pp = 1
If l1 > 0.99 Then l1 = 0.5
If c1 < 0.01 Then pp = 1
If c1 < 0.01 Then c1 = 0.5
u1 = Log(c1) + Log(1 - l1)
If pp = 1 Then u1 = -999
If u1 > maxu Then maxm = m
If u1 > maxu Then maxu = u1
Next
prefer = maxm
End Function
Private Sub Command1_Click()
Dim th(1 To 100) As Single
Dim gr(1 To 100) As Single
Dim c(0 To 10) As Single
Dim y(0 To 10) As Single
Dim fastu(-1 To 1, -1 To 1) As Single
Dim endu(-1 To 1, -1 To 1) As Single
Dim u(1 To 9, -1 To 1, -1 To 1, -1 To 1) As Single
Dim v(1 To 9, -1 To 1, -1 To 1) As Single
Dim goton(1 To 9, -1 To 1, -1 To 1) As Single
Dim endv(-1 To 1, -1 To 1) As Single
Dim m As Single
Dim s As Single
Dim y1 As Single
Dim y2 As Single
Dim c1 As Single
Dim c2 As Single
Dim c3 As Single
Dim y3 As Single
Dim lam As Single
Open "c:/101.txt" For Input As #1
Do Until EOF(1)
Input #1, a1, a2, a3
m = a1
y(m) = a2
c(m) = a3
Loop
Close #1
For s = 1 To 100
th(s) = 0.02 * s
Next
For s = 1 To 100
m = prefer(s, th, c, y)
gr(s) = m
Next
h = 0.001
lam = (Log(0.5 + h) - Log(0.5)) / h
lam = lam - 0.05
t1 = 0
Do Until t1 > 100
y1 = y(0)
y2 = y(1)
For n1 = -1 To 1
For n2 = -1 To 1
c1 = c(0) + n1 * h
c2 = c(1) + n2 * h
fastu(n1, n2) = fseeku(th, gr, c1, c2, y1, y2, lam)
Next
Next
y1 = y(9)
y2 = y(10)
For n1 = -1 To 1
For n2 = -1 To 1
c1 = c(9) + n1 * h
c2 = c(10) + n2 * h
endu(n1, n2) = eseeku(th, gr, c1, c2, y1, y2, lam)
Next
Next
For m = 1 To 9
y1 = y(m - 1)
y2 = y(m)
y3 = y(m + 1)
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
c1 = c(m - 1) + n1 * h
c2 = c(m) + n2 * h
c3 = c(m + 1) + n3 * h
u(m, n1, n2, n3) = seeku(m, th, gr, c1, c2, c3, y1, y2, y3, lam)
Next
Next
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
vs = -999
For nx = -1 To 1
u1 = u(1, nx, n1, n2)
v1 = u1 + fastu(nx, n1)
If v1 > vs Then nxs = nx
If v1 > vs Then vs = v1
Next
goton(1, n1, n2) = nxs
v(1, n1, n2) = vs
Next
Next
For m = 2 To 9
For n1 = -1 To 1
For n2 = -1 To 1
vs = -999
For nx = -1 To 1
u1 = u(m, nx, n1, n2)
v1 = u1 + v(m - 1, nx, n1)
If v1 > vs Then nxs = nx
If v1 > vs Then vs = v1
Next
goton(m, n1, n2) = nxs
v(m, n1, n2) = vs
Next
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
u1 = endu(n1, n2)
v1 = u1 + v(9, n1, n2)
endv(n1, n2) = v1
Next
Next
Dim opc(0 To 10) As Single
Dim opq(0 To 10) As Single
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
opc(9) = nx1
opc(10) = nx2
opc(8) = goton(9, opc(9), opc(10))
For t = 1 To 8
m = 9 - t
opc(m - 1) = goton(m, opc(m), opc(m + 1))
Next
e = 0
For m = 0 To 9
e = e + opc(m) ^ 2
Next
For m = 0 To 10
c(m) = c(m) + opc(m) * h
Next
t1 = t1 + 1
If e < 2 Then h = h / 2
If h < 10 ^ (-5) Then t1 = 1000
Loop
Debug.Print lam, bud(th, c, y), wel(th, c, y)
Dim maxm As Single
For s = 1 To 100
m = prefer(s, th, c, y)
If m > maxm Then maxm = m
Next
Debug.Print maxm
For m = 0 To maxm - 1
y1 = y(m + 1) - y(m)
c1 = c(m + 1) - c(m)
Debug.Print y(m), 1 - c1 / y1
Next



End Sub