cve - プログラム倉庫

Function ut(s As Single, th1, th2, ct As Single, yt As Single) As Single
Dim lx As Single
Dim cx As Single
Dim px As Single
lx = yt / th1(s)
cx = ct
px = 0
If cx < 0.01 Then px = 1
If lx < 0.01 Then px = 1
If px = 1 Then cx = 0.5
If px = 1 Then lx = 0.5
ux = Log(cx) - lx ^ (th2(s) + 1) / (th2(s) + 1)
If px = 1 Then ux = -999
ut = ux
End Function

Function countb(bx As Single, bs As Single, h As Single) As Single
Dim zs As Single
Dim z1 As Single
Dim z2 As Single
Dim ct As Single
zs = (bx - bs) / h
z1 = Int(zs)
z2 = z1 + 1
ct = z1
If (zs - z2) ^ 2 < (zs - z1) ^ 2 Then ct = z2
countb = ct
End Function
Function eseekb(th1, th2, gr, c1 As Single, c2 As Single, y1 As Single, y2 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 sumb As Single
sumb = 0
For s = 1 To 100
us = -999
If gr(s) = 10 Then u1 = ut(s, th1, th2, c1, y1)
If gr(s) = 10 Then u2 = ut(s, th1, th2, c2, y2)
If u1 > us Then bs = y1 - c1
If u1 > us Then us = u1
If u2 > us Then bs = y2 - c2
If u2 > us Then us = u2
If gr(s) = 10 Then sumb = sumb + bs
Next
eseekb = sumb
End Function
Function eseeku(th1, th2, gr, c1 As Single, c2 As Single, y1 As Single, y2 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 = ut(s, th1, th2, c1, y1)
If gr(s) = 10 Then u2 = ut(s, th1, th2, c2, y2)
If u1 > us Then us = u1
If u2 > us Then us = u2
If gr(s) = 10 Then sumu = sumu + us
Next
eseeku = sumu
End Function


Function fseekb(th1, th2, gr, c1 As Single, c2 As Single, y1 As Single, y2 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 sumb As Single
sumb = 0
For s = 1 To 100
us = -999
If gr(s) = 0 Then u1 = ut(s, th1, th2, c1, y1)
If gr(s) = 0 Then u2 = ut(s, th1, th2, c2, y2)
If u1 > us Then bs = y1 - c1
If u1 > us Then us = u1
If u2 > us Then bs = y2 - c2
If u2 > us Then us = u2
If gr(s) = 0 Then sumb = sumb + bs
Next
fseekb = sumb
End Function
Function fseeku(th1, th2, gr, c1 As Single, c2 As Single, y1 As Single, y2 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) = 0 Then u1 = ut(s, th1, th2, c1, y1)
If gr(s) = 0 Then u2 = ut(s, th1, th2, c2, y2)
If u1 > us Then us = u1
If u2 > us Then us = u2
If gr(s) = 0 Then sumu = sumu + us
Next
fseeku = sumu
End Function


Function seekb(m As Single, th1, th2, gr, c1 As Single, c2 As Single, c3 As Single, y1 As Single, y2 As Single, y3 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 sumb As Single
sumb = 0
For s = 1 To 100
us = -999
If gr(s) = m Then u1 = ut(s, th1, th2, c1, y1)
If gr(s) = m Then u2 = ut(s, th1, th2, c2, y2)
If gr(s) = m Then u3 = ut(s, th1, th2, c3, y3)
If u1 > us Then bs = y1 - c1
If u1 > us Then us = u1
If u2 > us Then bs = y2 - c2
If u2 > us Then us = u2
If u3 > us Then bs = y3 - c3
If u3 > us Then us = u3
If gr(s) = m Then sumb = sumb + bs
Next
seekb = sumb
End Function
Function seeku(m As Single, th1, th2, gr, c1 As Single, c2 As Single, c3 As Single, y1 As Single, y2 As Single, y3 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 = ut(s, th1, th2, c1, y1)
If gr(s) = m Then u2 = ut(s, th1, th2, c2, y2)
If gr(s) = m Then u3 = ut(s, th1, th2, c3, y3)
If u1 > us Then us = u1
If u2 > us Then us = u2
If u3 > us Then us = u3
If gr(s) = m Then sumu = sumu + us
Next
seeku = sumu
End Function
Function prefer(s As Single, th1, th2, 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 y1 As Single
maxu = -999
For m = 0 To 10
c1 = c(m)
y1 = y(m)
u1 = ut(s, th1, th2, c1, y1)
If u1 > maxu Then maxm = m
If u1 > maxu Then maxu = u1
Next
prefer = maxm
End Function
Private Sub Command1_Click()
Dim s As Single
Dim m As Single
Dim th1(1 To 100) As Single
Dim th2(1 To 100) As Single
Dim gr(1 To 100) As Single
Dim y(0 To 10) As Single
Dim c(0 To 10) As Single
Dim u(1 To 9, -1 To 1, -1 To 1, -1 To 1) As Single
Dim b(1 To 9, -1 To 1, -1 To 1, -1 To 1) As Single
Dim fastu(-1 To 1, -1 To 1) As Single
Dim fastb(-1 To 1, -1 To 1) As Single
Dim endu(-1 To 1, -1 To 1) As Single
Dim endb(-1 To 1, -1 To 1) As Single
Dim endv(-1 To 1, -1 To 1) As Single
Dim endn(-1 To 1, -1 To 1) As Single
Dim endq(-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 goton(1 To 9, -1 To 1, -1 To 1, -100 To 100) As Single
Dim gotoq(1 To 9, -1 To 1, -1 To 1, -100 To 100) As Single
Dim h As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
Dim c1 As Single
Dim c2 As Single
Dim c3 As Single
Dim y1 As Single
Dim y2 As Single
Dim y3 As Single
Dim bx As Single
Dim bs 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
Open "c:/21.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
h = 0.002
t1 = 0
Do Until t1 > 100
For s = 1 To 100
m = prefer(s, th1, th2, c, y)
gr(s) = m
Next
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(th1, th2, gr, c1, c2, y1, y2)
fastb(n1, n2) = fseekb(th1, th2, gr, c1, c2, y1, y2)
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(th1, th2, gr, c1, c2, y1, y2)
endb(n1, n2) = eseekb(th1, th2, gr, c1, c2, y1, y2)
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, th1, th2, gr, c1, c2, c3, y1, y2, y3)
b(m, n1, n2, n3) = seekb(m, th1, th2, gr, c1, c2, c3, y1, y2, y3)
Next
Next
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
bx = fastb(n1, n2)
bs = fastb(0, 0)
q = countb(bx, bs, 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 = u(m, nx, n1, n2)
bx = b(m, nx, n1, n2)
bs = b(m, 0, 0, 0)
qx = q - countb(bx, bs, h)
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 qxs = qx
If v1 > vs Then nxs = nx
If v1 > vs Then vs = v1
Next
gotoq(m, n1, n2, q) = qxs
goton(m, n1, n2, q) = nxs
v(m, n1, n2, q) = vs
Next
Next
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
endv(n1, n2) = -999
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
u1 = endu(n1, n2)
bx = endb(n1, n2)
bs = endb(0, 0)
qx = -countb(bx, bs, h)
v1 = u1 + v(9, n1, n2, qx)
endq(n1, n2) = qx
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
Debug.Print vs
opc(9) = nx1
opc(10) = nx2
opq(9) = endq(opc(9), opc(10))
For t = 1 To 9
m = 10 - t
opc(m - 1) = goton(m, opc(m), opc(m + 1), opq(m))
opq(m - 1) = gotoq(m, opc(m), opc(m + 1), opq(m))
Next
e = 0
For m = 1 To 9
e = e + opc(m) ^ 2
Next
For m = 0 To 10
c(m) = c(m) + opc(m) * h
Next
Debug.Print e
If e < 2 Then h = h / 2
If h < 10 ^ (-5) Then t1 = 1000
t1 = t1 + 1
Loop
maxm = 0
minm = 99
For s = 1 To 100
m = prefer(s, th1, th2, c, y)
If m > maxm Then maxm = m
If m < minm Then minm = m
Next
For m = minm 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