by konisi » 2006年2月26日(日) 23:44
面倒なので各関数の使用方法などは後述。
関数群のコード↓(注:まだバグフィッシュが完全では無い可能性あり。)
コード: 全て選択
Sub Syokika(A As *Word,B As Word)(C As Long)
Dim i As Long
if C=0 then
C=Keta
End If
for i=0 to C
A(i)=B
Next i
End Sub
Sub Ireru(A As *Word,B As *Word)
Dim i As Long
For i=0 To Keta
A(i)=B(i)
Next i
End Sub
Sub Ireru_l(A As *Word,B As *Long)
Dim i As Long
For i=0 To Keta
A(i)=B(i) As Word
Next i
End Sub
Sub Ireru_dw(A As *Word,B As *DWord)
Dim i As Long
For i=0 To Keta
A(i)=B(i) As Word
Next i
End Sub
Sub Ireru_w(A As *Word,B As *Word)
Ireru(A,B)
End Sub
Sub Hikaku(A As *Word,B As *Word,ByRef K As Long)(ByRef L As Long)
Dim i As Long
For i=Keta To 0 Step -1
if A(i)>B(i) then
K=1
L=i+1
Exit Sub
Elseif A(i)<B(i) then
K=-1
L=i+1
Exit Sub
End If
Next i
K=0
L=0
End Sub
Sub Kuriagari_w(A As *Word)
Dim i As Long
For i=0 To Keta
if A(i)>Max then
A(i+1)=A(i+1)+Fix(A(i)/Max)
A(i)=A(i)-Fix(A(i)/Max)*Max
End If
Next i
End Sub
Sub Kuriagari_dw(A As *DWord)(B As Long)
Dim i As Long
if B=0 then
B=Keta
End If
For i=0 To B
if A(i)>Max then
A(i+1)=A(i+1)+Fix(A(i)/Max)
A(i)=A(i)-Fix(A(i)/Max)*Max
End If
Next i
End Sub
Sub Tasu(A As *Word,B As *Word,C As *Word)
Dim i As Long
for i=0 To Keta
A(i)=B(i)+C(i)
Next i
Kuriagari_w(A)
End Sub
Sub Hiku(A As *Word,B As *Word,C As *Word)
Dim i As Long
Dim d(Keta) As Long
For i=0 To Keta
d(i)=B(i)-C(i)
Next i
For i=0 To Keta
if d(i)<0 then
d(i)=d(i)+Max
d(i+1)=d(i+1)-1
i=i-1
End If
Next i
Ireru_l(A,d)
End Sub
Sub Kakeru(A As *Word,B As *Word,C As Word)
Dim i As Long
Dim d(Keta) As DWord
For i=0 To Keta
d(i)=B(i)*C
Next i
Kuriagari_dw(d)
Ireru_dw(A,d)
End Sub
Sub Kakeru_t(A As *Word,B As *Word,C As *Word)
Dim i As Long
Dim j As Long
Dim d(Keta*2+1) As DWord
For i=0 To Keta
For j=0 To Keta
d(i+j)=B(i)*C(j)
Next j
Kuriagari_dw(d,Keta*2+1)
Next i
Ireru_dw(A,d)
End Sub
Sub Waru(A As *Word,B As *Word,C As Word)
Dim i As Long
Dim d(Keta) As Word
Dim e(Keta) As Word
Ireru(e,B)
For i=Keta To 1 Step -1
A(i)=Fix(e(i)/C)
d(i)=e(i)-A(i)*C
e(i-1)=e(i-1)+d(i)*Max
Next i
A(0)=Fix(e(i)/C)
End Sub
Sub Waru_t(A As *Word,B As *Word,C As *Word)
Dim i As Long
Dim j As Long
Dim k As Long
Dim d(Keta) As Word
Syokika(A,0)
For i=Keta To 0 Step -1
if C(i)<>0 then
Exit For
End If
Next i
i=Keta-i
j=100
A(i)=j
Do
Kakeru_t(d,A,C)
Hikaku(d,B,k)
if k=1 then
A(i)=A(i)-j
j=j/10 As Long
if j<1 then
i=i-1
j=1000
End If
Elseif K=0 then
Exit Do
Elseif K=-1 then
A(i)=A(i)+j
End If
if i<0 then
Exit Do
End If
Loop
End Sub
Sub Rujo(A As *Word,B As *Word,C As Word)
Dim i As Long
Dim d(Keta) As Word
Syokika(A,0)
if C=0 then
A(0)=1
Exit Sub
Elseif C=1 then
Ireru(A,B)
Exit Sub
End If
Ireru(A,B)
For i=2 To C
Kakeru_t(d,A,B)
Ireru(A,d)
Next i
End Sub
Sub WriteToFile_t(FileName As BytePtr,A As *Word)
Dim i As Long
Dim j As Long
Dim a$ As String
For i=Keta To 0 Step -1
if A(i)<>0 then
Exit For
End If
Next i
a$=Str$(A(i))
j=0
i=i-1
Open FileName For Output As #1
Do
a$=a$+Str2$(A(i))
i=i-1
if i=-1 then Exit Do
j=j+1
if j=25 then
Print #1,a$
a$=""
j=0
End If
Loop
if a$<>"" then
Print #1,a$
End If
Close #1
End Sub
Function Str2$(A As Word) As String
Dim a$ As String
a$=Str$(A)
Select Case Len(a$)
Case 1
a$="000"+a$
Case 2
a$="00"+a$
Case 3
a$="0"+a$
End Select
Str2$=a$
End Function
Const Max=10000
Const Keta=2500
'差分そのいち
Sub Print_t(A As *Word)
Dim i As Long
Dim j As Long
Dim a$ As String
For i=Keta To 0 Step -1
if A(i)<>0 then
Exit For
End If
Next i
if i=-1 then
Print "0"
Exit Sub
End If
a$=Str$(A(i))
j=0
i=i-1
Do
a$=a$+Str2$(A(i))
i=i-1
if i=-1 then Exit Do
j=j+1
if j=20 then
Print a$
a$=""
j=0
End If
Loop
if a$<>"" then Print a$
End Sub
'差分そのに
Sub Mod_t(A As *Word,B As *Word,C As *Word)
Dim i As Long
Dim d(Keta) As Word
Dim e(Keta) As Word
Waru_t(d,B,C)
Kakeru_t(e,d,C)
Hiku(A,B,e)
End Sub
'差分そのさん
Sub Val_t(A As *Word,A$ As String)
Dim i As Long
Dim a$ As String
Dim b$ As String
a$=A$
i=0
while Len(a$)>4
b$=Mid$(a$,Len(a$)-3,4)
A(i)=Val(b$)
i=i+1
a$=Left$(a$,Len(a$)-4)
Wend
if a$<>"" then
A(i)=Val(a$)
End If
End Sub
Sub Input_t(A As *Word)
Dim a$ As String
Input a$
Val_t(A,a$)
End Sub
sbpファイルに分けることを推奨。
面倒なので各関数の使用方法などは後述。
関数群のコード↓(注:まだバグフィッシュが完全では無い可能性あり。)
[code]Sub Syokika(A As *Word,B As Word)(C As Long)
Dim i As Long
if C=0 then
C=Keta
End If
for i=0 to C
A(i)=B
Next i
End Sub
Sub Ireru(A As *Word,B As *Word)
Dim i As Long
For i=0 To Keta
A(i)=B(i)
Next i
End Sub
Sub Ireru_l(A As *Word,B As *Long)
Dim i As Long
For i=0 To Keta
A(i)=B(i) As Word
Next i
End Sub
Sub Ireru_dw(A As *Word,B As *DWord)
Dim i As Long
For i=0 To Keta
A(i)=B(i) As Word
Next i
End Sub
Sub Ireru_w(A As *Word,B As *Word)
Ireru(A,B)
End Sub
Sub Hikaku(A As *Word,B As *Word,ByRef K As Long)(ByRef L As Long)
Dim i As Long
For i=Keta To 0 Step -1
if A(i)>B(i) then
K=1
L=i+1
Exit Sub
Elseif A(i)<B(i) then
K=-1
L=i+1
Exit Sub
End If
Next i
K=0
L=0
End Sub
Sub Kuriagari_w(A As *Word)
Dim i As Long
For i=0 To Keta
if A(i)>Max then
A(i+1)=A(i+1)+Fix(A(i)/Max)
A(i)=A(i)-Fix(A(i)/Max)*Max
End If
Next i
End Sub
Sub Kuriagari_dw(A As *DWord)(B As Long)
Dim i As Long
if B=0 then
B=Keta
End If
For i=0 To B
if A(i)>Max then
A(i+1)=A(i+1)+Fix(A(i)/Max)
A(i)=A(i)-Fix(A(i)/Max)*Max
End If
Next i
End Sub
Sub Tasu(A As *Word,B As *Word,C As *Word)
Dim i As Long
for i=0 To Keta
A(i)=B(i)+C(i)
Next i
Kuriagari_w(A)
End Sub
Sub Hiku(A As *Word,B As *Word,C As *Word)
Dim i As Long
Dim d(Keta) As Long
For i=0 To Keta
d(i)=B(i)-C(i)
Next i
For i=0 To Keta
if d(i)<0 then
d(i)=d(i)+Max
d(i+1)=d(i+1)-1
i=i-1
End If
Next i
Ireru_l(A,d)
End Sub
Sub Kakeru(A As *Word,B As *Word,C As Word)
Dim i As Long
Dim d(Keta) As DWord
For i=0 To Keta
d(i)=B(i)*C
Next i
Kuriagari_dw(d)
Ireru_dw(A,d)
End Sub
Sub Kakeru_t(A As *Word,B As *Word,C As *Word)
Dim i As Long
Dim j As Long
Dim d(Keta*2+1) As DWord
For i=0 To Keta
For j=0 To Keta
d(i+j)=B(i)*C(j)
Next j
Kuriagari_dw(d,Keta*2+1)
Next i
Ireru_dw(A,d)
End Sub
Sub Waru(A As *Word,B As *Word,C As Word)
Dim i As Long
Dim d(Keta) As Word
Dim e(Keta) As Word
Ireru(e,B)
For i=Keta To 1 Step -1
A(i)=Fix(e(i)/C)
d(i)=e(i)-A(i)*C
e(i-1)=e(i-1)+d(i)*Max
Next i
A(0)=Fix(e(i)/C)
End Sub
Sub Waru_t(A As *Word,B As *Word,C As *Word)
Dim i As Long
Dim j As Long
Dim k As Long
Dim d(Keta) As Word
Syokika(A,0)
For i=Keta To 0 Step -1
if C(i)<>0 then
Exit For
End If
Next i
i=Keta-i
j=100
A(i)=j
Do
Kakeru_t(d,A,C)
Hikaku(d,B,k)
if k=1 then
A(i)=A(i)-j
j=j/10 As Long
if j<1 then
i=i-1
j=1000
End If
Elseif K=0 then
Exit Do
Elseif K=-1 then
A(i)=A(i)+j
End If
if i<0 then
Exit Do
End If
Loop
End Sub
Sub Rujo(A As *Word,B As *Word,C As Word)
Dim i As Long
Dim d(Keta) As Word
Syokika(A,0)
if C=0 then
A(0)=1
Exit Sub
Elseif C=1 then
Ireru(A,B)
Exit Sub
End If
Ireru(A,B)
For i=2 To C
Kakeru_t(d,A,B)
Ireru(A,d)
Next i
End Sub
Sub WriteToFile_t(FileName As BytePtr,A As *Word)
Dim i As Long
Dim j As Long
Dim a$ As String
For i=Keta To 0 Step -1
if A(i)<>0 then
Exit For
End If
Next i
a$=Str$(A(i))
j=0
i=i-1
Open FileName For Output As #1
Do
a$=a$+Str2$(A(i))
i=i-1
if i=-1 then Exit Do
j=j+1
if j=25 then
Print #1,a$
a$=""
j=0
End If
Loop
if a$<>"" then
Print #1,a$
End If
Close #1
End Sub
Function Str2$(A As Word) As String
Dim a$ As String
a$=Str$(A)
Select Case Len(a$)
Case 1
a$="000"+a$
Case 2
a$="00"+a$
Case 3
a$="0"+a$
End Select
Str2$=a$
End Function
Const Max=10000
Const Keta=2500
'差分そのいち
Sub Print_t(A As *Word)
Dim i As Long
Dim j As Long
Dim a$ As String
For i=Keta To 0 Step -1
if A(i)<>0 then
Exit For
End If
Next i
if i=-1 then
Print "0"
Exit Sub
End If
a$=Str$(A(i))
j=0
i=i-1
Do
a$=a$+Str2$(A(i))
i=i-1
if i=-1 then Exit Do
j=j+1
if j=20 then
Print a$
a$=""
j=0
End If
Loop
if a$<>"" then Print a$
End Sub
'差分そのに
Sub Mod_t(A As *Word,B As *Word,C As *Word)
Dim i As Long
Dim d(Keta) As Word
Dim e(Keta) As Word
Waru_t(d,B,C)
Kakeru_t(e,d,C)
Hiku(A,B,e)
End Sub
'差分そのさん
Sub Val_t(A As *Word,A$ As String)
Dim i As Long
Dim a$ As String
Dim b$ As String
a$=A$
i=0
while Len(a$)>4
b$=Mid$(a$,Len(a$)-3,4)
A(i)=Val(b$)
i=i+1
a$=Left$(a$,Len(a$)-4)
Wend
if a$<>"" then
A(i)=Val(a$)
End If
End Sub
Sub Input_t(A As *Word)
Dim a$ As String
Input a$
Val_t(A,a$)
End Sub
[/code]
sbpファイルに分けることを推奨。