この判定式の否定文、つまり IF NOT(A < 0 AND B = 0 OR C >= 5) THEN と
同等となる判定式はどうなるでしょう?
これは、IF 判定式 THEN 命令1 ELSE 命令2
命令1が不要になった場合等にIF NOT(判定式) THEN 命令2
以外の書き方を求めます。
IF 判定式 THEN ELSE 命令2
という書き方もできるようですが、ここではあくまでこの判定式を
否定した書き方を模索します。
これには、一定の規則性があります。
まず、
IF A = 0 THEN です。
この否定文は
IF NOT(A = 0) THEN ですがこれと同等の判定式は
IF A <> 0 THEN です。
また、IF A <> 0 THEN の否定文は
IF A = 0 THEN です。
次は
IF A < 0 THEN です。
この否定文は
IF NOT(A < 0) THEN ですが
IF A > 0 THEN ではありません。
これではA = 0 の場合が含まれていません。
IF A < 0 THEN の否定文は
IF A >= 0 THEN となります。
また
IF A >= 0 THEN の否定文は
IF A < 0 THEN です。
そして
IF A > 0 THEN の否定文は
IF A <= 0 THEN です。
※ ここまでのまとめ
A = B の否定は A <> B (A >< B)
A <> B の否定は A = B
A < B の否定は A >= B (A => B)
A > B の否定は A <= B (A =< B)
A <= B の否定は A > B
A >= B の否定は A < B
では次の2項の判定式ではどうなるでしょうか?
IF A = 0 AND B = 0 THEN
この否定文は
IF NOT(A = 0 AND B = 0) THEN ですが、先程の例から
IF A <> 0 AND B <> 0 THEN でしょうか?
A=0とB=0 以外の場合ですから
A=1,B=2 の場合はうまくいきそうです。
ですが IF A = 0 AND B = 0 THEN はA = 0でもB = 1では成り立ちません。
A=0 AND B=0の否定文ではA=0,B=1が成り立たなければなりません。
IF A <> 0 AND B <> 0 THEN ではA = 0の時、この A <> 0が成り立たずこの式は真になりません。
ですが
IF A <> 0 OR B <> 0 THEN ではA = 0でもB = 1なら成立するので真になります。
つまりANDをORに変えればうまくいきそうです。
そして
IF A <> 0 OR B <> 0 THEN の否定文 IF NOT(A <> 0 OR B <> 0) THEN は
IF A = 0 AND B = 0 THEN と同等になります。
次の6パターンを試してみると全て一致しているのが分かります。
FOR M=1 TO 6
FOR D=0 TO 1
FOR C=0 TO 1
FOR B=0 TO 1
FOR A=0 TO 1
SELECT CASE M
CASE 1
IF NOT(A = B OR C = D) THEN PRINT "NOT(A = B OR C = D) ";A;B;C;D
IF A <> B AND C <> D THEN PRINT "A <> B AND C <> D ";A;B;C;D
CASE 2
IF NOT(A = B OR C <> D) THEN PRINT "NOT(A = B OR C <> D) ";A;B;C;D
IF A <> B AND C = D THEN PRINT "A <> B AND C = D ";A;B;C;D
CASE 3
IF NOT(A < B OR C <> D) THEN PRINT "NOT(A < B OR C <> D) ";A;B;C;D
IF A >= B AND C = D THEN PRINT "A >= B AND C = D ";A;B;C;D
CASE 4
IF NOT(A > B OR C = D) THEN PRINT "NOT(A > B OR C = D) ";A;B;C;D
IF A <= B AND C <> D THEN PRINT "A <= B AND C <> D ";A;B;C;D
CASE 5
IF NOT(A <= B OR C < D) THEN PRINT "NOT(A <= B OR C < D) ";A;B;C;D
IF A > B AND C >= D THEN PRINT "A > B AND C >= D ";A;B;C;D
CASE 6
IF NOT(A >= B OR C<= D) THEN PRINT "NOT( A>= B OR C <= D) ";A;B;C;D
IF A < B AND C > D THEN PRINT "A < B AND C > D ";A;B;C;D
END SELECT
NEXT A
NEXT B
NEXT C
NEXT D
PRINT
NEXT M
END
否定文になると
AND は OR に
OR は AND に変わります。
では冒頭の問題を見てみましょう。
IF A < 0 AND B = 0 OR C >= 5 THEN
この否定文 IF NOT(A < 0 AND B = 0 OR C >= 5) THEN と同等の式はどうなるでしょうか?
これまでの例から
A < 0 は A >= 0 に
B = 0 は B <> 0 に
C >= 5 は C < 5 に
AND は OR に
OR を AND に変えて
LET A=2
LET B=1
LET C=6
IF NOT(A < 0 AND B = 0 OR C >= 5) THEN PRINT "真 1" ELSE PRINT "偽 1"
IF A > =0 OR B <> 0 AND C < 5 THEN PRINT "真 2" ELSE PRINT "偽 2"
END
実は3項以上では注意点があります。
それはANDとORの優先順位です。
IF A < 0 AND B = 0 OR C >= 5 THEN これを正確に書くと
IF (A < 0 AND B = 0) OR C >= 5 THEN です。
よって正解は...
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
↓
IF (A >= 0 OR B <> 0) AND C < 5 THEN
になります。
JIS Full BASIC に Viewportに関する規定があります。
十進BASICのヘルプだと， https://decimalbasic.ninja-web.net/BASICHelp/html/basi8sc4.htm
が該当します。
通常，Viewportの外への描画は無視されます。
例
100 OPTION ANGLE DEGREES
110 SET VIEWPORT 0.5, 1, 0.5, 1
120 SET WINDOW -4,4,-4,4
130 DRAW GRID
140 FOR x=-4 TO 4 STEP 0.01
150 PLOT LINES:x,x^3-3*x;
160 NEXT x
170 SET VIEWPORT 0,0.5 , 0,0.5
180 SET WINDOW -180,540,-4,4
190 DRAW GRID(90,1)
200 FOR x=-180 TO 540
210 PLOT LINES:x,SIN(x);
220 NEXT x
230 END
数字キーの１，２を押すことで表示を切り替えます。
配列の大きさは大きめに確保しておいて，
座標を配列にセットし，
配列と有効な座標の個数を副プログラムdisplayに引き渡し
MAT PLOT LINES, LIMIT文で描画します。
100 OPTION ANGLE DEGREES
110 DIM x1(10000),y1(10000),x2(10000),y2(10000)
120 LET i1=0
130 FOR x=-4 TO 4 STEP 0.01
140 LET i1=i1+1
150 LET x1(i1)=x
160 LET y1(i1)=x^3-3*x
170 NEXT x
180 LET i2=0
190 FOR x=-180 TO 540
200 LET i2=i2+1
210 LET x2(i2)=x
220 LET y2(i2)=SIN(x)
230 NEXT x
240 DO
250 CHARACTER INPUT c$
260 SELECT CASE c$
270 CASE "1"
280 CALL DISPLAY(-4,4,-4,4,x1,y1,i1,1)
290 CASE "2"
300 CALL DISPLAY(-180,540,-4,4,x2,y2,i2,90)
310 CASE ELSE
320 EXIT DO
330 END SELECT
340 LOOP
350 SUB DISPLAY(l,r,b,t,xx(),yy(),i,s)
360 CLEAR
370 SET WINDOW l,r,b,t
380 DRAW grid(s,1)
390 MAT PLOT LINES ,LIMIT i: xx, yy
400 END SUB
410 END
DIM U(3,3),V(3),W(3)
PUBLIC NUMERIC X1(20),X2(20),Y(20),N
RANDOMIZE
LET N=15
LET A0=RND !'テスト係数
LET B0=RND
LET C0=RND
FOR I=1 TO N
LET X1(I)=I/5
LET X2(I)=I^2/10
LET Y(I)=FF(A0,B0,C0,X1(I),X2(I)) !'テストデータ作成
NEXT I
LET A=1 !'初期値
LET B=1
LET C=1
LET EPS=1E-8 !'収束誤差
DO
LET U(1,1)=DIFF(A,2,B,0,C,0)
LET U(1,2)=DIFF(A,1,B,1,C,0)
LET U(1,3)=DIFF(A,1,B,0,C,1)
LET U(2,1)=DIFF(A,1,B,1,C,0)
LET U(2,2)=DIFF(A,0,B,2,C,0)
LET U(2,3)=DIFF(A,0,B,1,C,1)
LET U(3,1)=DIFF(A,1,B,0,C,1)
LET U(3,2)=DIFF(A,0,B,1,C,1)
LET U(3,3)=DIFF(A,0,B,0,C,2)
LET V(1)=-DIFF(A,1,B,0,C,0)
LET V(2)=-DIFF(A,0,B,1,C,0)
LET V(3)=-DIFF(A,0,B,0,C,1)
MAT U=INV(U)
MAT W=U*V
LET A=A+W(1)
LET B=B+W(2)
LET C=C+W(3)
LET L=L+1
IF W(1)^2+W(2)^2+W(3)^2<EPS THEN EXIT DO
IF L>100 THEN
PRINT "収束しません"
STOP
END IF
LOOP
PRINT L
PRINT "A0=";A0,"B0=";B0,"C0=";C0
PRINT " A=";A," B=";B," C=";C !'求めた係数
LET P$="####.########"
FOR I=1 TO N
PRINT "X1=";
PRINT USING P$:X1(I);
PRINT " X2=";
PRINT USING P$:X2(I);
PRINT " Y=";
PRINT USING P$:Y(I);
PRINT " ^Y=";
PRINT USING P$:FF(A,B,C,X1(I),X2(I))
NEXT I
END
EXTERNAL FUNCTION FF(A,B,C,X1,X2) !'パラメータA,B,Cを持ち変数X1,X2の任意の回帰式(重回帰式)
LET FF=A+B*X1+C*X2
!'LET FF=A*EXP(B*X1)*EXP(C*X2)
!'LET FF=A+B*LOG(X1)+C*LOG(X2)
!'LET FF=A*B^X1*C^X2
!'LET FF=A*X1^B*X2^C
END FUNCTION
EXTERNAL FUNCTION FUNC(A,B,C)
FOR I=1 TO N
LET S=S+(Y(I)-FF(A,B,C,X1(I),X2(I)))^2 !'差の2乗和(A=A0,B=B0,C=C0なら最小値S=0)
NEXT I
LET FUNC=S
END FUNCTION
EXTERNAL FUNCTION DIFF(X,M,Y,N,Z,O) !'数値偏微分
LET H=1/1024
IF M>0 THEN
LET DIFF=(-DIFF(X+2*H,M-1,Y,N,Z,O)+8*DIFF(X+H,M-1,Y,N,Z,O)-8*DIFF(X-H,M-1,Y,N,Z,O)+DIFF(X-2*H,M-1,Y,N,Z,O))/(12*H)
EXIT FUNCTION
END IF
IF N>0 THEN
LET DIFF=(-DIFF(X,M,Y+2*H,N-1,Z,O)+8*DIFF(X,M,Y+H,N-1,Z,O)-8*DIFF(X,M,Y-H,N-1,Z,O)+DIFF(X,M,Y-2*H,N-1,Z,O))/(12*H)
EXIT FUNCTION
END IF
IF O>0 THEN
LET DIFF=(-DIFF(X,M,Y,N,Z+2*H,O-1)+8*DIFF(X,M,Y,N,Z+H,O-1)-8*DIFF(X,M,Y,N,Z-H,O-1)+DIFF(X,M,Y,N,Z-2*H,O-1))/(12*H)
EXIT FUNCTION
END IF
IF M=0 OR N=0 OR O=0 THEN LET DIFF=FUNC(X,Y,Z)
END FUNCTION
LET P_B1=.1/100
LET P_B2=1-P_B1
LET P_AB1=95/100
LET P_AB2=3/100
FOR I=1 TO 5
LET P_B1A=P_B1*P_AB1/(P_B1*P_AB1+P_B2*P_AB2)
PRINT P_B1A*100;"%"
LET P_B1=P_B1A !'確率の更新
NEXT I
END
OPTION BASE 0
RANDOMIZE
LET NUM_INPUT=2
LET NUM_HIDDEN=20
DIM TRAIN_X(3,NUM_INPUT),D(3)
MAT READ TRAIN_X,D
DATA 0, 0, -1,0, 1, -1,1, 0, -1,1, 1, -1
DATA 0, 1, 1, 0
DIM W(NUM_HIDDEN,NUM_INPUT),V(NUM_HIDDEN),Y(4,NUM_HIDDEN),Z(4)
LET ETA = 0.1
LET EPOCH = 300000
FOR L=0 TO NUM_HIDDEN
FOR I=0 TO NUM_INPUT
LET W(L,I) = RND
NEXT I
NEXT L
FOR I=0 TO NUM_HIDDEN
LET V(I) = RND
NEXT I
FOR K=0 TO EPOCH
FOR J=0 TO 3
FOR L=0 TO NUM_HIDDEN-1
FOR I=0 TO NUM_INPUT
LET TMP = TMP+TRAIN_X(J,I) * W(L,I)
NEXT I
LET Y(J,L) = SIGMOID(TMP)
LET TMP = 0
NEXT L
LET Y(J,NUM_HIDDEN) = -1
FOR I=0 TO NUM_HIDDEN
LET TMP = TMP+Y(J,I) * V(I)
NEXT I
LET Z(J) = SIGMOID(TMP)
LET TMP = 0
FOR I=0 TO NUM_HIDDEN
LET V(I) = V(I) - ETA * Y(J,I) * DIFFSIGMOID(Z(J)) * (Z(J) - D(J))
NEXT I
FOR L=0 TO NUM_INPUT
FOR I=0 TO NUM_HIDDEN
LET W(I,L) = W(I,L) - ETA * TRAIN_X(J,L) * DIFFSIGMOID(Y(J,I)) * DIFFSIGMOID(Z(J)) * (Z(J) - D(J)) * V(I)
NEXT I
NEXT L
NEXT J
IF MOD(K , 10000) =0 THEN
PRINT "z=";
FOR I=0 TO 3
PRINT Z(I);
NEXT I
PRINT "epoch:";K
END IF
NEXT K
END
EXTERNAL FUNCTION SIGMOID(X)
LET SIGMOID=1/(1+EXP(-X))
END FUNCTION
EXTERNAL FUNCTION DIFFSIGMOID(X)
LET A = 0.1
LET DIFFSIGMOID=A*X*(1-X)
END FUNCTION
> http://mojaie.hatenablog.jp/entry/2011/12/04/001545
> https://ja.wikipedia.org/wiki/ミラー–ラビン素数判定法
>
> !'素数判定 Miller-Rabin法
> OPTION ARITHMETIC RATIONAL
> LET L=100000000000000 !'100兆
> FOR N=L+1 TO L+10001 STEP 2
> IF ISPRIME(N)=1 THEN
> !'PRINT N
> LET COUNT=COUNT+1
> END IF
> NEXT N
> PRINT COUNT;"個"
> END
>
> EXTERNAL FUNCTION ISPRIME(N)
> OPTION ARITHMETIC RATIONAL
> IF N = 2 THEN
> LET ISPRIME=1
> EXIT FUNCTION
> END IF
> IF N = 1 OR MOD(N , 2) = 0 THEN
> LET ISPRIME=0
> EXIT FUNCTION
> END IF
> LET D = (N - 1) / 2
> LET S = 0
> DO WHILE MOD(D , 2) = 0
> LET D = INT(D / 2)
> LET S=S+1
> LOOP
> FOR I=1 TO 10
> LET ISP=0
> READ A !' n < 341550071728321 なら a = 2, 3, 5, 7, 11, 13, 17
> DATA 2,3,5,7,11,13,17,23,29,31
> LET ISP = 0
> LET R = POWMOD(A, D, N)
> IF R = 1 OR R = N - 1 THEN
> LET ISP = 1
> END IF
> LET R = POWMOD(R, 2, N)
> FOR J = 0 TO S-1
> IF R = N - 1 THEN
> LET ISP = 1
> END IF
> LET R = POWMOD(R, 2, N)
> NEXT J
> IF ISP=0 THEN
> LET ISPRIME=0
> EXIT FUNCTION
> END IF
> NEXT I
> LET ISPRIME=1
> END FUNCTION
>
> EXTERNAL FUNCTION POWMOD(B,P,M)
> OPTION ARITHMETIC RATIONAL
> LET RESULT = 1
> DO WHILE P > 0
> IF MOD(P , 2)= 1 THEN
> LET RESULT = MOD(RESULT * B , M)
> END IF
> LET B = MOD(B * B, M)
> LET P = INT(P / 2)
> LOOP
> LET POWMOD=RESULT
> END FUNCTION
>
EXTERNAL FUNCTION ISPRIME(N)
!OPTION ARITHMETIC RATIONAL
IF N = 2 THEN
LET ISPRIME=1
EXIT FUNCTION
END IF
IF N = 1 OR MOD(N , 2) = 0 THEN
LET ISPRIME=0
EXIT FUNCTION
END IF
LET D = (N - 1) / 2
LET S = 0
DO WHILE MOD(D , 2) = 0
LET D = INT(D / 2)
LET S=S+1
LOOP
FOR I=1 TO 10
LET ISP=0
READ A !' n < 341550071728321 なら a = 2, 3, 5, 7, 11, 13, 17
DATA 2,3,5,7,11,13,17,23,29,31
LET ISP = 0
LET R = POWMOD(A, D, N)
IF R = 1 OR R = N - 1 THEN
LET ISP = 1
END IF
LET R = POWMOD(R, 2, N)
FOR J = 0 TO S-1
IF R = N - 1 THEN
LET ISP = 1
END IF
LET R = POWMOD(R, 2, N)
NEXT J
IF ISP=0 THEN
LET ISPRIME=0
EXIT FUNCTION
END IF
NEXT I
LET ISPRIME=1
END FUNCTION
EXTERNAL FUNCTION POWMOD(B,P,M)
!OPTION ARITHMETIC RATIONAL
LET RESULT = 1
DO WHILE P > 0
IF MOD(P , 2)= 1 THEN
LET RESULT = MOD(RESULT * B , M)
END IF
LET B = MOD(B * B, M)
LET P = INT(P / 2)
LOOP
LET POWMOD=RESULT
END FUNCTION
100 PRINT ISPRIME(94910639) !94910639 素数 (5484841st)
110 END
120 EXTERNAL FUNCTION ISPRIME(N)
140 IF N = 2 THEN
150 LET ISPRIME=1
160 EXIT FUNCTION
170 END IF
180 IF N = 1 OR MOD(N , 2) = 0 THEN
190 LET ISPRIME=0
200 EXIT FUNCTION
210 END IF
220 LET D = (N - 1) / 2
230 LET S = 0
240 DO WHILE MOD(D , 2) = 0
250 LET D = INT(D / 2)
260 LET S=S+1
270 LOOP
280 FOR I=1 TO 10
290 LET ISP=0
300 READ A !' n < 341550071728321 なら a = 2, 3, 5, 7, 11, 13, 17
310 DATA 2,3,5,7,11,13,17,23,29,31
320 LET ISP = 0
330 LET R = POWMOD(A, D, N)
340 IF R = 1 OR R = N - 1 THEN
350 LET ISP = 1
360 END IF
370 LET R = POWMOD(R, 2, N)
380 FOR J = 0 TO S-1
390 IF R = N - 1 THEN
400 LET ISP = 1
410 END IF
420 LET R = POWMOD(R, 2, N)
430 NEXT J
440 IF ISP=0 THEN
450 LET ISPRIME=0
460 EXIT FUNCTION
470 END IF
480 NEXT I
490 LET ISPRIME=1
500 END FUNCTION
510 EXTERNAL FUNCTION POWMOD(B,P,M)
520 !OPTION ARITHMETIC RATIONAL
530 LET RESULT = 1
540 DO WHILE P > 0
550 IF MOD(P , 2)= 1 THEN
560 LET RESULT = MOD(RESULT * B , M)
570 END IF
580 PRINT USING "######## ################": B , B * B
590 LET B = MOD(B * B, M)
600 LET P = INT(P / 2)
610 LOOP
620 LET POWMOD=RESULT
630 END FUNCTION
> BASIC Accelerator で ROUND関数を10進モードで実行すると誤った値を返すことがあります。
> バージョンは 1.2.0.5
>
> OPTION ARITHMETIC DECIMAL
> LET x=12345678.901234
> LET a=ROUND(x,3)
> PRINT x
> PRINT a
> PRINT
> LET y=34567890123.456
> LET b=ROUND(y)
> PRINT y
> PRINT b
> END
100 DATA 15237833654620
110 DATA 15240788209967
120 DATA 15243742783546
130 DATA 15246697309511
140 READ a,b,c,d
150 PRINT a
160 PRINT b
170 PRINT c
180 PRINT d
190 END
DECLARE EXTERNAL SUB sort
DECLARE NUMERIC MX,IDmin,IDmax,lenID,lenname,lentel,dmx,f,n,id,li,sa,sr,i,j,j2,wd
DECLARE STRING idrange$,u$,s$,name$,tel$,d$,c$,sa$,t$
OPTION CHARACTER KANJI
LET MX=200 ! data数の上限(変更可)
LET IDmin=1001 ! ID番号の下限(変更可) IDmin>=1
LET IDmax=9999 ! ID番号の上限(変更可)
LET lenID=CEIL(LOG10(IDmax))+1
LET lenNAME=8 ! 氏名の最大文字数(変更可)
LET lenTEL=14 ! 電話番号の最大文字数(変更可)
DIM DT$(MX,3),DTid(MX),DTtel$(MX),sortID(MX)
LET idrange$=STR$(IDmin)&"～"&STR$(IDmax)
LET u$=REPEAT$("#",lenID)&" <"&REPEAT$("#",2*lenNAME-1)&" <"&REPEAT$("#",lenTEL)
LET wd=0.1
SET ECHO "OFF"
LET dmx=0
!
DO
INPUT PROMPT "【ファイル】1.新規作成 2.読込み (終了は 0)":f
LOOP UNTIL f=INT(f) AND f>=0 AND f<=2
WAIT DELAY wd
IF f=1 THEN
CALL main(1)
ELSEIF f=2 THEN
FILE GETOPENNAME s$ ! 電話帳ファイルの読込み
OPEN #1: NAME s$
DO
LET dmx=dmx+1
INPUT #1, IF MISSING THEN EXIT DO: DT$(dmx,1),DT$(dmx,2),DT$(dmx,3)
LET DTid(dmx)=VAL(DT$(dmx,1))
CALL tel(DTtel$(dmx),DT$(dmx,3))
LOOP
LET dmx=dmx-1
ELSE
STOP
END IF
!
DO ! メインルーチン
DO
INPUT PROMPT " 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了" :n
LOOP UNTIL n=INT(n) AND n>=0 AND n<=6
WAIT DELAY wd
CALL main(n)
LOOP UNTIL n=0
!
SUB main(n)
SELECT CASE n
CASE 1 ! [入力]
DO
IF dmx>=MX THEN
WAIT DELAY "DATA数が上限 "&STR$(MX)&" に達していて、入力が出来ません"
WAIT DELAY wd
EXIT SUB
END IF
DO
INPUT PROMPT " ID番号入力 "&idrange$&" (入力終了は 0)" :id
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
WAIT DELAY wd
IF id=0 THEN EXIT DO
INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
WAIT DELAY wd
IF name$="0" THEN EXIT DO
INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
WAIT DELAY wd
IF tel$="0" THEN EXIT DO
LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
IF CONFIRM$(c$)="YES" THEN
LET dmx=dmx+1
LET DT$(dmx,1)=STR$(id)
LET DT$(dmx,2)=name$
LET DT$(dmx,3)=tel$
LET DTid(dmx)=id
CALL tel(DTtel$(dmx),DT$(dmx,3))
END IF
WAIT DELAY wd
LOOP
CASE 2 ! [削除]
DO
INPUT PROMPT " 削除するDATAのID番号を入力 (キャンセルは 0)" :id
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
WAIT DELAY wd
IF id=0 THEN EXIT SUB
FOR i=1 TO dmx
IF DTid(i)=id THEN
LET d$="下記のDATAを削除しますか？"&CHR$(10)&"ID："&DT$(i,1)
LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
IF CONFIRM$(d$)="YES" THEN
PRINT "削除したDATA"
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
FOR j=i+1 TO dmx
LET DT$(j-1,1)=DT$(j,1)
LET DT$(j-1,2)=DT$(j,2)
LET DT$(j-1,3)=DT$(j,3)
LET DTid(j-1)=VAL(DT$(j,1))
LET DTtel$(j-1)=DTtel$(j)
NEXT j
LET DT$(dmx,1),DT$(dmx,2),DT$(dmx,3),DTtel$(dmx)=""
LET DTid(dmx)=0
LET dmx=dmx-1
END IF
WAIT DELAY wd
EXIT SUB
END IF
NEXT i
WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
CASE 3 ! [更新]
DO
INPUT PROMPT " 更新するDATAのID番号を入力 (キャンセルは 0)" :id
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
WAIT DELAY wd
IF id=0 THEN EXIT SUB
FOR i=1 TO dmx
IF DTid(i)=id THEN
LET d$="下記のDATAを書き換えますか？"&CHR$(10)&"ID："&DT$(i,1)
LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
IF CONFIRM$(d$)="NO" THEN EXIT SUB
PRINT "更新前のDATA"
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
DO
INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
WAIT DELAY wd
IF name$="0" THEN EXIT SUB
INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
WAIT DELAY wd
IF tel$="0" THEN EXIT SUB
LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
IF CONFIRM$(c$)="YES" THEN
LET DT$(i,2)=name$
LET DT$(i,3)=tel$
CALL tel(DTtel$(i),DT$(i,3))
EXIT DO
END IF
LOOP
WAIT DELAY wd
EXIT SUB
END IF
NEXT i
WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
CASE 4 ! [検索]
DO
INPUT PROMPT " 検索項目 1.氏名 2.電話番号 (キャンセルは 0)": sa
LOOP UNTIL sa=INT(sa) AND sa>=0 AND sa<=2
WAIT DELAY wd
IF sa=0 THEN EXIT SUB
INPUT PROMPT " 検索文字列 (一部分でも可, キャンセルは 0)": sa$
WAIT DELAY wd
IF sa$="0" THEN EXIT SUB
IF sa=1 THEN LET t$="氏名" ELSE LET t$="電話番号"
PRINT "検索結果 [";t$;",""";sa$;"""]"
LET sr=0
IF sa=1 THEN
FOR i=1 TO dmx
IF POS(DT$(i,2),sa$)>0 THEN
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
LET sr=sr+1
END IF
NEXT i
ELSE ! sa=2
FOR j=LEN(sa$) TO 1 STEP -1
IF sa$(j:j)<"0" OR sa$(j:j)>"9" THEN LET sa$(j:j)=""
NEXT j
FOR i=1 TO dmx
IF POS(DTtel$(i),sa$)>0 THEN
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
LET sr=sr+1
END IF
NEXT i
END IF
IF sr=0 THEN PRINT "該当するDATAはありませんでした"
CASE 5 ! [一覧]
DO
INPUT PROMPT " 1.DATA順 2.ID番号順 (キャンセルは 0)" : li
LOOP UNTIL li=INT(li) AND li>=0 AND li<=2
IF li=1 THEN
PRINT "DATA一覧"
FOR i=1 TO dmx
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
NEXT i
ELSEIF li=2 THEN
MAT sortID=ZER
CALL sort(DTid,sortID,dmx)
PRINT "DATA一覧 (ID番号順)"
FOR i=1 TO dmx
PRINT USING u$: DT$(sortID(i),1),DT$(sortID(i),2),DT$(sortID(i),3)
NEXT i
END IF
CASE 6 ! [保存]
CALL save
CASE 0 ! [終了]
IF CONFIRM$("プログラムを終了しますか？")="NO" THEN EXIT SUB
IF CONFIRM$("DATAをファイルに保存しますか？")="YES" THEN CALL save
CLOSE #1
END SELECT
WAIT DELAY wd
END SUB
!
SUB save
IF f=1 THEN
FILE GETSAVENAME s$
OPEN #1: NAME s$
LET f=f+10
END IF
ERASE #1
FOR i=1 TO dmx
IF DTid(i)<>0 THEN PRINT#1: DT$(i,1)&","&DT$(i,2)&","&DT$(i,3)
NEXT i
END SUB
!
SUB tel(t$,d$)
LET t$=""
FOR j2=1 TO LEN(d$)
IF d$(j2:j2)>="0" AND d$(j2:j2)<="9" THEN LET t$=t$&d$(j2:j2)
NEXT j2
END SUB
!
END
! 十進BASICライブラリ"\Decimal BASIC\BASICw32\Library\SORT2.LIB"
! ixにはmと下限，上限を一致させた空の配列を指定する。
! mは参照されるのみ。
! ixにmの添字を大きさの順に並べて返す。
! つまり，m(ix(1))≦m(ix(2))≦m(ix(3))≦･･･となる。
EXTERNAL SUB sort(m(),ix(),n) ! ソート
DECLARE EXTERNAL SUB q_sort
DECLARE NUMERIC i
FOR i=1 TO n
LET ix(i)=i
NEXT i
CALL q_sort(m,ix,1,n)
END SUB
!
EXTERNAL SUB q_sort(m(),a(),l,r)
DECLARE NUMERIC i,j,pv,t
IF r<=l THEN
EXIT SUB
ELSE
LET i=l-1
LET j=r
LET pv=m(a(r))
DO
DO
LET i=i+1
LOOP UNTIL pv<=m(a(i))
DO
LET j=j-1
LOOP UNTIL j<=i OR m(a(j))<=pv
IF j<=i THEN EXIT DO
LET t=a(i)
LET a(i)=a(j)
LET a(j)=t
LOOP
LET t=a(i)
LET a(i)=a(r)
LET a(r)=t
CALL q_sort(m,a,l,i-1)
CALL q_sort(m,a,i+1,r)
END IF
END SUB
> RCカーさんへのお返事です。
>
> > フォームによる、データ入力、削除、更新、検索
> > データは、ID番号、氏名、電話番号。
> > 個人用なので可能だと思う。一覧表示機能。
> > ファイルへの、データ保存。
> > 氏名からの電話番号検索
> > 電話番号からの氏名検索
> >
>
> 作ってみました。
> まず実行前に、データの上限を指定する変数MXの値を決定してください。
> その他、変更可の変数の値も必要であれば変更してください。
> 実行するとまず、データファイルを新規作成するか、既存のファイルを読み込むかの選択をします。
> データの入力は、ID番号・氏名・電話番号の順です（追加で入力できます）。
> 電話番号は"09012345678","090-1234-5678","090(1234)5678"いずれの形式でもかまいません。
> 苗字と名前の間など、入力データに空白があってもかまいませんが、半角カンマ","は使えません。
> 入力または読み込みが終わるとメインメニューになります。
> 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了
> から選択です。
> [入力][削除][更新]があった場合は、プログラム終了までに必ず[保存]してください。
> 保存しないデータはプログラム終了で失われます。
> 保存したファイルはカンマ区切りのCSV形式なのでExcelなどで読み込むことが出来ます。
> 検索は、苗字だけとか電話番号の一部だけといった部分一致検索に対応してます。
>
> 質問や不具合があれば、この掲示板にお願いします。
>
> DECLARE EXTERNAL SUB sort
> DECLARE NUMERIC MX,IDmin,IDmax,lenID,lenname,lentel,dmx,f,n,id,li,sa,sr,i,j,j2,wd
> DECLARE STRING idrange$,u$,s$,name$,tel$,d$,c$,sa$,t$
> OPTION CHARACTER KANJI
> LET MX=200 ! data数の上限(変更可)
> LET IDmin=1001 ! ID番号の下限(変更可) IDmin>=1
> LET IDmax=9999 ! ID番号の上限(変更可)
> LET lenID=CEIL(LOG10(IDmax))+1
> LET lenNAME=8 ! 氏名の最大文字数(変更可)
> LET lenTEL=14 ! 電話番号の最大文字数(変更可)
> DIM DT$(MX,3),DTid(MX),DTtel$(MX),sortID(MX)
> LET idrange$=STR$(IDmin)&"～"&STR$(IDmax)
> LET u$=REPEAT$("#",lenID)&" <"&REPEAT$("#",2*lenNAME-1)&" <"&REPEAT$("#",lenTEL)
> LET wd=0.1
> SET ECHO "OFF"
> LET dmx=0
> !
> DO
> INPUT PROMPT "【ファイル】1.新規作成 2.読込み (終了は 0)":f
> LOOP UNTIL f=INT(f) AND f>=0 AND f<=2
> WAIT DELAY wd
> IF f=1 THEN
> CALL main(1)
> ELSEIF f=2 THEN
> FILE GETOPENNAME s$ ! 電話帳ファイルの読込み
> OPEN #1: NAME s$
> DO
> LET dmx=dmx+1
> INPUT #1, IF MISSING THEN EXIT DO: DT$(dmx,1),DT$(dmx,2),DT$(dmx,3)
> LET DTid(dmx)=VAL(DT$(dmx,1))
> CALL tel(DTtel$(dmx),DT$(dmx,3))
> LOOP
> LET dmx=dmx-1
> ELSE
> STOP
> END IF
> !
> DO ! メインルーチン
> DO
> INPUT PROMPT " 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了" :n
> LOOP UNTIL n=INT(n) AND n>=0 AND n<=6
> WAIT DELAY wd
> CALL main(n)
> LOOP UNTIL n=0
> !
> SUB main(n)
> SELECT CASE n
> CASE 1 ! [入力]
> DO
> IF dmx>=MX THEN
> WAIT DELAY "DATA数が上限 "&STR$(MX)&" に達していて、入力が出来ません"
> WAIT DELAY wd
> EXIT SUB
> END IF
> DO
> INPUT PROMPT " ID番号入力 "&idrange$&" (入力終了は 0)" :id
> LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
> WAIT DELAY wd
> IF id=0 THEN EXIT DO
> INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
> WAIT DELAY wd
> IF name$="0" THEN EXIT DO
> INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
> WAIT DELAY wd
> IF tel$="0" THEN EXIT DO
> LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
> LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
> IF CONFIRM$(c$)="YES" THEN
> LET dmx=dmx+1
> LET DT$(dmx,1)=STR$(id)
> LET DT$(dmx,2)=name$
> LET DT$(dmx,3)=tel$
> LET DTid(dmx)=id
> CALL tel(DTtel$(dmx),DT$(dmx,3))
> END IF
> WAIT DELAY wd
> LOOP
> CASE 2 ! [削除]
> DO
> INPUT PROMPT " 削除するDATAのID番号を入力 (キャンセルは 0)" :id
> LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
> WAIT DELAY wd
> IF id=0 THEN EXIT SUB
> FOR i=1 TO dmx
> IF DTid(i)=id THEN
> LET d$="下記のDATAを削除しますか？"&CHR$(10)&"ID："&DT$(i,1)
> LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
> IF CONFIRM$(d$)="YES" THEN
> PRINT "削除したDATA"
> PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> FOR j=i+1 TO dmx
> LET DT$(j-1,1)=DT$(j,1)
> LET DT$(j-1,2)=DT$(j,2)
> LET DT$(j-1,3)=DT$(j,3)
> LET DTid(j-1)=VAL(DT$(j,1))
> LET DTtel$(j-1)=DTtel$(j)
> NEXT j
> LET DT$(dmx,1),DT$(dmx,2),DT$(dmx,3),DTtel$(dmx)=""
> LET DTid(dmx)=0
> LET dmx=dmx-1
> END IF
> WAIT DELAY wd
> EXIT SUB
> END IF
> NEXT i
> WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
> CASE 3 ! [更新]
> DO
> INPUT PROMPT " 更新するDATAのID番号を入力 (キャンセルは 0)" :id
> LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
> WAIT DELAY wd
> IF id=0 THEN EXIT SUB
> FOR i=1 TO dmx
> IF DTid(i)=id THEN
> LET d$="下記のDATAを書き換えますか？"&CHR$(10)&"ID："&DT$(i,1)
> LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
> IF CONFIRM$(d$)="NO" THEN EXIT SUB
> PRINT "更新前のDATA"
> PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> DO
> INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
> WAIT DELAY wd
> IF name$="0" THEN EXIT SUB
> INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
> WAIT DELAY wd
> IF tel$="0" THEN EXIT SUB
> LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
> LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
> IF CONFIRM$(c$)="YES" THEN
> LET DT$(i,2)=name$
> LET DT$(i,3)=tel$
> CALL tel(DTtel$(i),DT$(i,3))
> EXIT DO
> END IF
> LOOP
> WAIT DELAY wd
> EXIT SUB
> END IF
> NEXT i
> WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
> CASE 4 ! [検索]
> DO
> INPUT PROMPT " 検索項目 1.氏名 2.電話番号 (キャンセルは 0)": sa
> LOOP UNTIL sa=INT(sa) AND sa>=0 AND sa<=2
> WAIT DELAY wd
> IF sa=0 THEN EXIT SUB
> INPUT PROMPT " 検索文字列 (一部分でも可, キャンセルは 0)": sa$
> WAIT DELAY wd
> IF sa$="0" THEN EXIT SUB
> IF sa=1 THEN LET t$="氏名" ELSE LET t$="電話番号"
> PRINT "検索結果 [";t$;",""";sa$;"""]"
> LET sr=0
> IF sa=1 THEN
> FOR i=1 TO dmx
> IF POS(DT$(i,2),sa$)>0 THEN
> PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> LET sr=sr+1
> END IF
> NEXT i
> ELSE ! sa=2
> FOR j=LEN(sa$) TO 1 STEP -1
> IF sa$(j:j)<"0" OR sa$(j:j)>"9" THEN LET sa$(j:j)=""
> NEXT j
> FOR i=1 TO dmx
> IF POS(DTtel$(i),sa$)>0 THEN
> PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> LET sr=sr+1
> END IF
> NEXT i
> END IF
> IF sr=0 THEN PRINT "該当するDATAはありませんでした"
> CASE 5 ! [一覧]
> DO
> INPUT PROMPT " 1.DATA順 2.ID番号順 (キャンセルは 0)" : li
> LOOP UNTIL li=INT(li) AND li>=0 AND li<=2
> IF li=1 THEN
> PRINT "DATA一覧"
> FOR i=1 TO dmx
> PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> NEXT i
> ELSEIF li=2 THEN
> MAT sortID=ZER
> CALL sort(DTid,sortID,dmx)
> PRINT "DATA一覧 (ID番号順)"
> FOR i=1 TO dmx
> PRINT USING u$: DT$(sortID(i),1),DT$(sortID(i),2),DT$(sortID(i),3)
> NEXT i
> END IF
> CASE 6 ! [保存]
> CALL save
> CASE 0 ! [終了]
> IF CONFIRM$("プログラムを終了しますか？")="NO" THEN EXIT SUB
> IF CONFIRM$("DATAをファイルに保存しますか？")="YES" THEN CALL save
> CLOSE #1
> END SELECT
> WAIT DELAY wd
> END SUB
> !
> SUB save
> IF f=1 THEN
> FILE GETSAVENAME s$
> OPEN #1: NAME s$
> LET f=f+10
> END IF
> ERASE #1
> FOR i=1 TO dmx
> IF DTid(i)<>0 THEN PRINT#1: DT$(i,1)&","&DT$(i,2)&","&DT$(i,3)
> NEXT i
> END SUB
> !
> SUB tel(t$,d$)
> LET t$=""
> FOR j2=1 TO LEN(d$)
> IF d$(j2:j2)>="0" AND d$(j2:j2)<="9" THEN LET t$=t$&d$(j2:j2)
> NEXT j2
> END SUB
> !
> END
> ! 十進BASICライブラリ"\Decimal BASIC\BASICw32\Library\SORT2.LIB"
> ! ixにはmと下限，上限を一致させた空の配列を指定する。
> ! mは参照されるのみ。
> ! ixにmの添字を大きさの順に並べて返す。
> ! つまり，m(ix(1))≦m(ix(2))≦m(ix(3))≦･･･となる。
> EXTERNAL SUB sort(m(),ix(),n) ! ソート
> DECLARE EXTERNAL SUB q_sort
> DECLARE NUMERIC i
> FOR i=1 TO n
> LET ix(i)=i
> NEXT i
> CALL q_sort(m,ix,1,n)
> END SUB
> !
> EXTERNAL SUB q_sort(m(),a(),l,r)
> DECLARE NUMERIC i,j,pv,t
> IF r<=l THEN
> EXIT SUB
> ELSE
> LET i=l-1
> LET j=r
> LET pv=m(a(r))
> DO
> DO
> LET i=i+1
> LOOP UNTIL pv<=m(a(i))
> DO
> LET j=j-1
> LOOP UNTIL j<=i OR m(a(j))<=pv
> IF j<=i THEN EXIT DO
> LET t=a(i)
> LET a(i)=a(j)
> LET a(j)=t
> LOOP
> LET t=a(i)
> LET a(i)=a(r)
> LET a(r)=t
> CALL q_sort(m,a,l,i-1)
> CALL q_sort(m,a,i+1,r)
> END IF
> END SUB
> RCカーさんへのお返事です。
>
> > フォームによる、データ入力、削除、更新、検索
> > データは、ID番号、氏名、電話番号。
> > 個人用なので可能だと思う。一覧表示機能。
> > ファイルへの、データ保存。
> > 氏名からの電話番号検索
> > 電話番号からの氏名検索
> >
>
> 作ってみました。
> まず実行前に、データの上限を指定する変数MXの値を決定してください。
> その他、変更可の変数の値も必要であれば変更してください。
> 実行するとまず、データファイルを新規作成するか、既存のファイルを読み込むかの選択をします。
> データの入力は、ID番号・氏名・電話番号の順です（追加で入力できます）。
> 電話番号は"09012345678","090-1234-5678","090(1234)5678"いずれの形式でもかまいません。
> 苗字と名前の間など、入力データに空白があってもかまいませんが、半角カンマ","は使えません。
> 入力または読み込みが終わるとメインメニューになります。
> 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了
> から選択です。
> [入力][削除][更新]があった場合は、プログラム終了までに必ず[保存]してください。
> 保存しないデータはプログラム終了で失われます。
> 保存したファイルはカンマ区切りのCSV形式なのでExcelなどで読み込むことが出来ます。
> 検索は、苗字だけとか電話番号の一部だけといった部分一致検索に対応してます。
>
> 質問や不具合があれば、この掲示板にお願いします。
>
> DECLARE EXTERNAL SUB sort
> DECLARE NUMERIC MX,IDmin,IDmax,lenID,lenname,lentel,dmx,f,n,id,li,sa,sr,i,j,j2,wd
> DECLARE STRING idrange$,u$,s$,name$,tel$,d$,c$,sa$,t$
> OPTION CHARACTER KANJI
> LET MX=200 ! data数の上限(変更可)
> LET IDmin=1001 ! ID番号の下限(変更可) IDmin>=1
> LET IDmax=9999 ! ID番号の上限(変更可)
> LET lenID=CEIL(LOG10(IDmax))+1
> LET lenNAME=8 ! 氏名の最大文字数(変更可)
> LET lenTEL=14 ! 電話番号の最大文字数(変更可)
> DIM DT$(MX,3),DTid(MX),DTtel$(MX),sortID(MX)
> LET idrange$=STR$(IDmin)&"～"&STR$(IDmax)
> LET u$=REPEAT$("#",lenID)&" <"&REPEAT$("#",2*lenNAME-1)&" <"&REPEAT$("#",lenTEL)
> LET wd=0.1
> SET ECHO "OFF"
> LET dmx=0
> !
> DO
> INPUT PROMPT "【ファイル】1.新規作成 2.読込み (終了は 0)":f
> LOOP UNTIL f=INT(f) AND f>=0 AND f<=2
> WAIT DELAY wd
> IF f=1 THEN
> CALL main(1)
> ELSEIF f=2 THEN
> FILE GETOPENNAME s$ ! 電話帳ファイルの読込み
> OPEN #1: NAME s$
> DO
> LET dmx=dmx+1
> INPUT #1, IF MISSING THEN EXIT DO: DT$(dmx,1),DT$(dmx,2),DT$(dmx,3)
> LET DTid(dmx)=VAL(DT$(dmx,1))
> CALL tel(DTtel$(dmx),DT$(dmx,3))
> LOOP
> LET dmx=dmx-1
> ELSE
> STOP
> END IF
> !
> DO ! メインルーチン
> DO
> INPUT PROMPT " 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了" :n
> LOOP UNTIL n=INT(n) AND n>=0 AND n<=6
> WAIT DELAY wd
> CALL main(n)
> LOOP UNTIL n=0
> !
> SUB main(n)
> SELECT CASE n
> CASE 1 ! [入力]
> DO
> IF dmx>=MX THEN
> WAIT DELAY "DATA数が上限 "&STR$(MX)&" に達していて、入力が出来ません"
> WAIT DELAY wd
> EXIT SUB
> END IF
> DO
> INPUT PROMPT " ID番号入力 "&idrange$&" (入力終了は 0)" :id
> LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
> WAIT DELAY wd
> IF id=0 THEN EXIT DO
> INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
> WAIT DELAY wd
> IF name$="0" THEN EXIT DO
> INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
> WAIT DELAY wd
> IF tel$="0" THEN EXIT DO
> LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
> LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
> IF CONFIRM$(c$)="YES" THEN
> LET dmx=dmx+1
> LET DT$(dmx,1)=STR$(id)
> LET DT$(dmx,2)=name$
> LET DT$(dmx,3)=tel$
> LET DTid(dmx)=id
> CALL tel(DTtel$(dmx),DT$(dmx,3))
> END IF
> WAIT DELAY wd
> LOOP
> CASE 2 ! [削除]
> DO
> INPUT PROMPT " 削除するDATAのID番号を入力 (キャンセルは 0)" :id
> LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
> WAIT DELAY wd
> IF id=0 THEN EXIT SUB
> FOR i=1 TO dmx
> IF DTid(i)=id THEN
> LET d$="下記のDATAを削除しますか？"&CHR$(10)&"ID："&DT$(i,1)
> LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
> IF CONFIRM$(d$)="YES" THEN
> PRINT "削除したDATA"
> PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> FOR j=i+1 TO dmx
> LET DT$(j-1,1)=DT$(j,1)
> LET DT$(j-1,2)=DT$(j,2)
> LET DT$(j-1,3)=DT$(j,3)
> LET DTid(j-1)=VAL(DT$(j,1))
> LET DTtel$(j-1)=DTtel$(j)
> NEXT j
> LET DT$(dmx,1),DT$(dmx,2),DT$(dmx,3),DTtel$(dmx)=""
> LET DTid(dmx)=0
> LET dmx=dmx-1
> END IF
> WAIT DELAY wd
> EXIT SUB
> END IF
> NEXT i
> WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
> CASE 3 ! [更新]
> DO
> INPUT PROMPT " 更新するDATAのID番号を入力 (キャンセルは 0)" :id
> LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
> WAIT DELAY wd
> IF id=0 THEN EXIT SUB
> FOR i=1 TO dmx
> IF DTid(i)=id THEN
> LET d$="下記のDATAを書き換えますか？"&CHR$(10)&"ID："&DT$(i,1)
> LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
> IF CONFIRM$(d$)="NO" THEN EXIT SUB
> PRINT "更新前のDATA"
> PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> DO
> INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
> WAIT DELAY wd
> IF name$="0" THEN EXIT SUB
> INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
> WAIT DELAY wd
> IF tel$="0" THEN EXIT SUB
> LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
> LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
> IF CONFIRM$(c$)="YES" THEN
> LET DT$(i,2)=name$
> LET DT$(i,3)=tel$
> CALL tel(DTtel$(i),DT$(i,3))
> EXIT DO
> END IF
> LOOP
> WAIT DELAY wd
> EXIT SUB
> END IF
> NEXT i
> WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
> CASE 4 ! [検索]
> DO
> INPUT PROMPT " 検索項目 1.氏名 2.電話番号 (キャンセルは 0)": sa
> LOOP UNTIL sa=INT(sa) AND sa>=0 AND sa<=2
> WAIT DELAY wd
> IF sa=0 THEN EXIT SUB
> INPUT PROMPT " 検索文字列 (一部分でも可, キャンセルは 0)": sa$
> WAIT DELAY wd
> IF sa$="0" THEN EXIT SUB
> IF sa=1 THEN LET t$="氏名" ELSE LET t$="電話番号"
> PRINT "検索結果 [";t$;",""";sa$;"""]"
> LET sr=0
> IF sa=1 THEN
> FOR i=1 TO dmx
> IF POS(DT$(i,2),sa$)>0 THEN
> PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> LET sr=sr+1
> END IF
> NEXT i
> ELSE ! sa=2
> FOR j=LEN(sa$) TO 1 STEP -1
> IF sa$(j:j)<"0" OR sa$(j:j)>"9" THEN LET sa$(j:j)=""
> NEXT j
> FOR i=1 TO dmx
> IF POS(DTtel$(i),sa$)>0 THEN
> PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> LET sr=sr+1
> END IF
> NEXT i
> END IF
> IF sr=0 THEN PRINT "該当するDATAはありませんでした"
> CASE 5 ! [一覧]
> DO
> INPUT PROMPT " 1.DATA順 2.ID番号順 (キャンセルは 0)" : li
> LOOP UNTIL li=INT(li) AND li>=0 AND li<=2
> IF li=1 THEN
> PRINT "DATA一覧"
> FOR i=1 TO dmx
> PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> NEXT i
> ELSEIF li=2 THEN
> MAT sortID=ZER
> CALL sort(DTid,sortID,dmx)
> PRINT "DATA一覧 (ID番号順)"
> FOR i=1 TO dmx
> PRINT USING u$: DT$(sortID(i),1),DT$(sortID(i),2),DT$(sortID(i),3)
> NEXT i
> END IF
> CASE 6 ! [保存]
> CALL save
> CASE 0 ! [終了]
> IF CONFIRM$("プログラムを終了しますか？")="NO" THEN EXIT SUB
> IF CONFIRM$("DATAをファイルに保存しますか？")="YES" THEN CALL save
> CLOSE #1
> END SELECT
> WAIT DELAY wd
> END SUB
> !
> SUB save
> IF f=1 THEN
> FILE GETSAVENAME s$
> OPEN #1: NAME s$
> LET f=f+10
> END IF
> ERASE #1
> FOR i=1 TO dmx
> IF DTid(i)<>0 THEN PRINT#1: DT$(i,1)&","&DT$(i,2)&","&DT$(i,3)
> NEXT i
> END SUB
> !
> SUB tel(t$,d$)
> LET t$=""
> FOR j2=1 TO LEN(d$)
> IF d$(j2:j2)>="0" AND d$(j2:j2)<="9" THEN LET t$=t$&d$(j2:j2)
> NEXT j2
> END SUB
> !
> END
> ! 十進BASICライブラリ"\Decimal BASIC\BASICw32\Library\SORT2.LIB"
> ! ixにはmと下限，上限を一致させた空の配列を指定する。
> ! mは参照されるのみ。
> ! ixにmの添字を大きさの順に並べて返す。
> ! つまり，m(ix(1))≦m(ix(2))≦m(ix(3))≦･･･となる。
> EXTERNAL SUB sort(m(),ix(),n) ! ソート
> DECLARE EXTERNAL SUB q_sort
> DECLARE NUMERIC i
> FOR i=1 TO n
> LET ix(i)=i
> NEXT i
> CALL q_sort(m,ix,1,n)
> END SUB
> !
> EXTERNAL SUB q_sort(m(),a(),l,r)
> DECLARE NUMERIC i,j,pv,t
> IF r<=l THEN
> EXIT SUB
> ELSE
> LET i=l-1
> LET j=r
> LET pv=m(a(r))
> DO
> DO
> LET i=i+1
> LOOP UNTIL pv<=m(a(i))
> DO
> LET j=j-1
> LOOP UNTIL j<=i OR m(a(j))<=pv
> IF j<=i THEN EXIT DO
> LET t=a(i)
> LET a(i)=a(j)
> LET a(j)=t
> LOOP
> LET t=a(i)
> LET a(i)=a(r)
> LET a(r)=t
> CALL q_sort(m,a,l,i-1)
> CALL q_sort(m,a,i+1,r)
> END IF
> END SUB
> nagramさんへのお返事です。
>
> nagramさんへ
> 早速実行してみました。
> 一人分のデータを入力して、入力、検索、一覧表示、保存、試しました。
> エラーなしで実行できました。
> ID番号を、1からではなく、1001からにしたのは、何か理由がありますか？？
> 有難う御座いました。
>
> > RCカーさんへのお返事です。
> >
> > > フォームによる、データ入力、削除、更新、検索
> > > データは、ID番号、氏名、電話番号。
> > > 個人用なので可能だと思う。一覧表示機能。
> > > ファイルへの、データ保存。
> > > 氏名からの電話番号検索
> > > 電話番号からの氏名検索
> > >
> >
> > 作ってみました。
> > まず実行前に、データの上限を指定する変数MXの値を決定してください。
> > その他、変更可の変数の値も必要であれば変更してください。
> > 実行するとまず、データファイルを新規作成するか、既存のファイルを読み込むかの選択をします。
> > データの入力は、ID番号・氏名・電話番号の順です（追加で入力できます）。
> > 電話番号は"09012345678","090-1234-5678","090(1234)5678"いずれの形式でもかまいません。
> > 苗字と名前の間など、入力データに空白があってもかまいませんが、半角カンマ","は使えません。
> > 入力または読み込みが終わるとメインメニューになります。
> > 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了
> > から選択です。
> > [入力][削除][更新]があった場合は、プログラム終了までに必ず[保存]してください。
> > 保存しないデータはプログラム終了で失われます。
> > 保存したファイルはカンマ区切りのCSV形式なのでExcelなどで読み込むことが出来ます。
> > 検索は、苗字だけとか電話番号の一部だけといった部分一致検索に対応してます。
> >
> > 質問や不具合があれば、この掲示板にお願いします。
> >
> > DECLARE EXTERNAL SUB sort
> > DECLARE NUMERIC MX,IDmin,IDmax,lenID,lenname,lentel,dmx,f,n,id,li,sa,sr,i,j,j2,wd
> > DECLARE STRING idrange$,u$,s$,name$,tel$,d$,c$,sa$,t$
> > OPTION CHARACTER KANJI
> > LET MX=200 ! data数の上限(変更可)
> > LET IDmin=1001 ! ID番号の下限(変更可) IDmin>=1
> > LET IDmax=9999 ! ID番号の上限(変更可)
> > LET lenID=CEIL(LOG10(IDmax))+1
> > LET lenNAME=8 ! 氏名の最大文字数(変更可)
> > LET lenTEL=14 ! 電話番号の最大文字数(変更可)
> > DIM DT$(MX,3),DTid(MX),DTtel$(MX),sortID(MX)
> > LET idrange$=STR$(IDmin)&"～"&STR$(IDmax)
> > LET u$=REPEAT$("#",lenID)&" <"&REPEAT$("#",2*lenNAME-1)&" <"&REPEAT$("#",lenTEL)
> > LET wd=0.1
> > SET ECHO "OFF"
> > LET dmx=0
> > !
> > DO
> > INPUT PROMPT "【ファイル】1.新規作成 2.読込み (終了は 0)":f
> > LOOP UNTIL f=INT(f) AND f>=0 AND f<=2
> > WAIT DELAY wd
> > IF f=1 THEN
> > CALL main(1)
> > ELSEIF f=2 THEN
> > FILE GETOPENNAME s$ ! 電話帳ファイルの読込み
> > OPEN #1: NAME s$
> > DO
> > LET dmx=dmx+1
> > INPUT #1, IF MISSING THEN EXIT DO: DT$(dmx,1),DT$(dmx,2),DT$(dmx,3)
> > LET DTid(dmx)=VAL(DT$(dmx,1))
> > CALL tel(DTtel$(dmx),DT$(dmx,3))
> > LOOP
> > LET dmx=dmx-1
> > ELSE
> > STOP
> > END IF
> > !
> > DO ! メインルーチン
> > DO
> > INPUT PROMPT " 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了" :n
> > LOOP UNTIL n=INT(n) AND n>=0 AND n<=6
> > WAIT DELAY wd
> > CALL main(n)
> > LOOP UNTIL n=0
> > !
> > SUB main(n)
> > SELECT CASE n
> > CASE 1 ! [入力]
> > DO
> > IF dmx>=MX THEN
> > WAIT DELAY "DATA数が上限 "&STR$(MX)&" に達していて、入力が出来ません"
> > WAIT DELAY wd
> > EXIT SUB
> > END IF
> > DO
> > INPUT PROMPT " ID番号入力 "&idrange$&" (入力終了は 0)" :id
> > LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
> > WAIT DELAY wd
> > IF id=0 THEN EXIT DO
> > INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
> > WAIT DELAY wd
> > IF name$="0" THEN EXIT DO
> > INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
> > WAIT DELAY wd
> > IF tel$="0" THEN EXIT DO
> > LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
> > LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
> > IF CONFIRM$(c$)="YES" THEN
> > LET dmx=dmx+1
> > LET DT$(dmx,1)=STR$(id)
> > LET DT$(dmx,2)=name$
> > LET DT$(dmx,3)=tel$
> > LET DTid(dmx)=id
> > CALL tel(DTtel$(dmx),DT$(dmx,3))
> > END IF
> > WAIT DELAY wd
> > LOOP
> > CASE 2 ! [削除]
> > DO
> > INPUT PROMPT " 削除するDATAのID番号を入力 (キャンセルは 0)" :id
> > LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
> > WAIT DELAY wd
> > IF id=0 THEN EXIT SUB
> > FOR i=1 TO dmx
> > IF DTid(i)=id THEN
> > LET d$="下記のDATAを削除しますか？"&CHR$(10)&"ID："&DT$(i,1)
> > LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
> > IF CONFIRM$(d$)="YES" THEN
> > PRINT "削除したDATA"
> > PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> > FOR j=i+1 TO dmx
> > LET DT$(j-1,1)=DT$(j,1)
> > LET DT$(j-1,2)=DT$(j,2)
> > LET DT$(j-1,3)=DT$(j,3)
> > LET DTid(j-1)=VAL(DT$(j,1))
> > LET DTtel$(j-1)=DTtel$(j)
> > NEXT j
> > LET DT$(dmx,1),DT$(dmx,2),DT$(dmx,3),DTtel$(dmx)=""
> > LET DTid(dmx)=0
> > LET dmx=dmx-1
> > END IF
> > WAIT DELAY wd
> > EXIT SUB
> > END IF
> > NEXT i
> > WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
> > CASE 3 ! [更新]
> > DO
> > INPUT PROMPT " 更新するDATAのID番号を入力 (キャンセルは 0)" :id
> > LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
> > WAIT DELAY wd
> > IF id=0 THEN EXIT SUB
> > FOR i=1 TO dmx
> > IF DTid(i)=id THEN
> > LET d$="下記のDATAを書き換えますか？"&CHR$(10)&"ID："&DT$(i,1)
> > LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
> > IF CONFIRM$(d$)="NO" THEN EXIT SUB
> > PRINT "更新前のDATA"
> > PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> > DO
> > INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
> > WAIT DELAY wd
> > IF name$="0" THEN EXIT SUB
> > INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
> > WAIT DELAY wd
> > IF tel$="0" THEN EXIT SUB
> > LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
> > LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
> > IF CONFIRM$(c$)="YES" THEN
> > LET DT$(i,2)=name$
> > LET DT$(i,3)=tel$
> > CALL tel(DTtel$(i),DT$(i,3))
> > EXIT DO
> > END IF
> > LOOP
> > WAIT DELAY wd
> > EXIT SUB
> > END IF
> > NEXT i
> > WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
> > CASE 4 ! [検索]
> > DO
> > INPUT PROMPT " 検索項目 1.氏名 2.電話番号 (キャンセルは 0)": sa
> > LOOP UNTIL sa=INT(sa) AND sa>=0 AND sa<=2
> > WAIT DELAY wd
> > IF sa=0 THEN EXIT SUB
> > INPUT PROMPT " 検索文字列 (一部分でも可, キャンセルは 0)": sa$
> > WAIT DELAY wd
> > IF sa$="0" THEN EXIT SUB
> > IF sa=1 THEN LET t$="氏名" ELSE LET t$="電話番号"
> > PRINT "検索結果 [";t$;",""";sa$;"""]"
> > LET sr=0
> > IF sa=1 THEN
> > FOR i=1 TO dmx
> > IF POS(DT$(i,2),sa$)>0 THEN
> > PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> > LET sr=sr+1
> > END IF
> > NEXT i
> > ELSE ! sa=2
> > FOR j=LEN(sa$) TO 1 STEP -1
> > IF sa$(j:j)<"0" OR sa$(j:j)>"9" THEN LET sa$(j:j)=""
> > NEXT j
> > FOR i=1 TO dmx
> > IF POS(DTtel$(i),sa$)>0 THEN
> > PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> > LET sr=sr+1
> > END IF
> > NEXT i
> > END IF
> > IF sr=0 THEN PRINT "該当するDATAはありませんでした"
> > CASE 5 ! [一覧]
> > DO
> > INPUT PROMPT " 1.DATA順 2.ID番号順 (キャンセルは 0)" : li
> > LOOP UNTIL li=INT(li) AND li>=0 AND li<=2
> > IF li=1 THEN
> > PRINT "DATA一覧"
> > FOR i=1 TO dmx
> > PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
> > NEXT i
> > ELSEIF li=2 THEN
> > MAT sortID=ZER
> > CALL sort(DTid,sortID,dmx)
> > PRINT "DATA一覧 (ID番号順)"
> > FOR i=1 TO dmx
> > PRINT USING u$: DT$(sortID(i),1),DT$(sortID(i),2),DT$(sortID(i),3)
> > NEXT i
> > END IF
> > CASE 6 ! [保存]
> > CALL save
> > CASE 0 ! [終了]
> > IF CONFIRM$("プログラムを終了しますか？")="NO" THEN EXIT SUB
> > IF CONFIRM$("DATAをファイルに保存しますか？")="YES" THEN CALL save
> > CLOSE #1
> > END SELECT
> > WAIT DELAY wd
> > END SUB
> > !
> > SUB save
> > IF f=1 THEN
> > FILE GETSAVENAME s$
> > OPEN #1: NAME s$
> > LET f=f+10
> > END IF
> > ERASE #1
> > FOR i=1 TO dmx
> > IF DTid(i)<>0 THEN PRINT#1: DT$(i,1)&","&DT$(i,2)&","&DT$(i,3)
> > NEXT i
> > END SUB
> > !
> > SUB tel(t$,d$)
> > LET t$=""
> > FOR j2=1 TO LEN(d$)
> > IF d$(j2:j2)>="0" AND d$(j2:j2)<="9" THEN LET t$=t$&d$(j2:j2)
> > NEXT j2
> > END SUB
> > !
> > END
> > ! 十進BASICライブラリ"\Decimal BASIC\BASICw32\Library\SORT2.LIB"
> > ! ixにはmと下限，上限を一致させた空の配列を指定する。
> > ! mは参照されるのみ。
> > ! ixにmの添字を大きさの順に並べて返す。
> > ! つまり，m(ix(1))≦m(ix(2))≦m(ix(3))≦･･･となる。
> > EXTERNAL SUB sort(m(),ix(),n) ! ソート
> > DECLARE EXTERNAL SUB q_sort
> > DECLARE NUMERIC i
> > FOR i=1 TO n
> > LET ix(i)=i
> > NEXT i
> > CALL q_sort(m,ix,1,n)
> > END SUB
> > !
> > EXTERNAL SUB q_sort(m(),a(),l,r)
> > DECLARE NUMERIC i,j,pv,t
> > IF r<=l THEN
> > EXIT SUB
> > ELSE
> > LET i=l-1
> > LET j=r
> > LET pv=m(a(r))
> > DO
> > DO
> > LET i=i+1
> > LOOP UNTIL pv<=m(a(i))
> > DO
> > LET j=j-1
> > LOOP UNTIL j<=i OR m(a(j))<=pv
> > IF j<=i THEN EXIT DO
> > LET t=a(i)
> > LET a(i)=a(j)
> > LET a(j)=t
> > LOOP
> > LET t=a(i)
> > LET a(i)=a(r)
> > LET a(r)=t
> > CALL q_sort(m,a,l,i-1)
> > CALL q_sort(m,a,i+1,r)
> > END IF
> > END SUB
-----------------------------------------------------------------------------
DO ! メインルーチン
DO
INPUT PROMPT " 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了" :n
LOOP UNTIL n=INT(n) AND n>=0 AND n<=6
WAIT DELAY wd
CALL main(n)
LOOP UNTIL n=0
-----------------------------------------------------------------------------
上記の部分を、次のようにすれば[OK]クリックや[Enter]キーで[0]と同じ扱い。
-----------------------------------------------------------------------------
WHEN EXCEPTION IN
DO ! メインルーチン
DO
INPUT PROMPT " 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了" :n$ !文字列変数入力
LET n=VAL(n$) ! 文字列変数を数値に変換。空文字列や"abc"などは例外発生。
LOOP UNTIL n=INT(n) AND n>=0 AND n<=6
WAIT DELAY wd
CALL main(n)
LOOP UNTIL n=0
USE ! 例外発生時の処理
LET n=0
CONTINUE
END WHEN
-----------------------------------------------------------------------------
◎ 重要なバグを発見しました。
"プログラムを終了しますか？" というメッセージボックスで[いいえ]を選択しても終了してしまいます。
副プログラム SUB main(n) 内のselect区で、CASE 0 を次のように修正してください。
--------------------------------------------------------------------------
【誤】
CASE 0 ! [終了]
IF CONFIRM$("プログラムを終了しますか？")="NO" THEN EXIT SUB
IF CONFIRM$("DATAをファイルに保存しますか？")="YES" THEN CALL save
CLOSE #1
END SELECT
--------------------------------------------------------------------------
【正】
CASE 0 ! [終了]
IF CONFIRM$("プログラムを終了しますか？")="NO" THEN ! 訂正
LET n=7 ! 訂正
EXIT SUB ! 訂正
END IF ! 訂正
IF CONFIRM$("DATAをファイルに保存しますか？")="YES" THEN CALL save
CLOSE #1
END SELECT
--------------------------------------------------------------------------
以下、変更点を、編集したプログラムです。間違っていたら教えて下さい。
DECLARE EXTERNAL SUB sort
DECLARE NUMERIC MX,IDmin,IDmax,lenID,lenname,lentel,dmx,f,n,id,li,sa,sr,i,j,j2,wd
DECLARE STRING idrange$,u$,s$,name$,tel$,d$,c$,sa$,t$
OPTION CHARACTER KANJI
LET MX=200 ! data数の上限(変更可)
LET IDmin=1001 ! ID番号の下限(変更可) IDmin>=1
LET IDmax=9999 ! ID番号の上限(変更可)
LET lenID=CEIL(LOG10(IDmax))+1
LET lenNAME=8 ! 氏名の最大文字数(変更可)
LET lenTEL=14 ! 電話番号の最大文字数(変更可)
DIM DT$(MX,3),DTid(MX),DTtel$(MX),sortID(MX)
LET idrange$=STR$(IDmin)&"～"&STR$(IDmax)
LET u$=REPEAT$("#",lenID)&" <"&REPEAT$("#",2*lenNAME-1)&" <"&REPEAT$("#",lenTEL)
LET wd=0.1
SET ECHO "OFF"
LET dmx=0
!
DO
INPUT PROMPT "【ファイル】1.新規作成 2.読込み (終了は 0)":f
LOOP UNTIL f=INT(f) AND f>=0 AND f<=2
WAIT DELAY wd
IF f=1 THEN
CALL main(1)
ELSEIF f=2 THEN
FILE GETOPENNAME s$ ! 電話帳ファイルの読込み
OPEN #1: NAME s$
DO
LET dmx=dmx+1
INPUT #1, IF MISSING THEN EXIT DO: DT$(dmx,1),DT$(dmx,2),DT$(dmx,3)
LET DTid(dmx)=VAL(DT$(dmx,1))
CALL tel(DTtel$(dmx),DT$(dmx,3))
LOOP
LET dmx=dmx-1
ELSE
STOP
END IF
!
WHEN EXCEPTION IN
DO ! メインルーチン
DO
INPUT PROMPT " 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了" :n$ !文字列変数入力
LET n=VAL(n$) ! 文字列変数を数値に変換。空文字列や"abc"などは例外発生。
LOOP UNTIL n=INT(n) AND n>=0 AND n<=6
WAIT DELAY wd
CALL main(n)
LOOP UNTIL n=0
USE ! 例外発生時の処理
LET n=0
CONTINUE
END WHEN!
SUB main(n)
SELECT CASE n
CASE 1 ! [入力]
DO
IF dmx>=MX THEN
WAIT DELAY "DATA数が上限 "&STR$(MX)&" に達していて、入力が出来ません"
WAIT DELAY wd
EXIT SUB
END IF
DO
INPUT PROMPT " ID番号入力 "&idrange$&" (入力終了は 0)" :id
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
WAIT DELAY wd
IF id=0 THEN EXIT DO
INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
WAIT DELAY wd
IF name$="0" THEN EXIT DO
INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
WAIT DELAY wd
IF tel$="0" THEN EXIT DO
LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
IF CONFIRM$(c$)="YES" THEN
LET dmx=dmx+1
LET DT$(dmx,1)=STR$(id)
LET DT$(dmx,2)=name$
LET DT$(dmx,3)=tel$
LET DTid(dmx)=id
CALL tel(DTtel$(dmx),DT$(dmx,3))
END IF
WAIT DELAY wd
LOOP
CASE 2 ! [削除]
DO
INPUT PROMPT " 削除するDATAのID番号を入力 (キャンセルは 0)" :id
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
WAIT DELAY wd
IF id=0 THEN EXIT SUB
FOR i=1 TO dmx
IF DTid(i)=id THEN
LET d$="下記のDATAを削除しますか？"&CHR$(10)&"ID："&DT$(i,1)
LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
IF CONFIRM$(d$)="YES" THEN
PRINT "削除したDATA"
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
FOR j=i+1 TO dmx
LET DT$(j-1,1)=DT$(j,1)
LET DT$(j-1,2)=DT$(j,2)
LET DT$(j-1,3)=DT$(j,3)
LET DTid(j-1)=VAL(DT$(j,1))
LET DTtel$(j-1)=DTtel$(j)
NEXT j
LET DT$(dmx,1),DT$(dmx,2),DT$(dmx,3),DTtel$(dmx)=""
LET DTid(dmx)=0
LET dmx=dmx-1
END IF
WAIT DELAY wd
EXIT SUB
END IF
NEXT i
WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
CASE 3 ! [更新]
DO
INPUT PROMPT " 更新するDATAのID番号を入力 (キャンセルは 0)" :id
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
WAIT DELAY wd
IF id=0 THEN EXIT SUB
FOR i=1 TO dmx
IF DTid(i)=id THEN
LET d$="下記のDATAを書き換えますか？"&CHR$(10)&"ID："&DT$(i,1)
LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
IF CONFIRM$(d$)="NO" THEN EXIT SUB
PRINT "更新前のDATA"
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
DO
INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
WAIT DELAY wd
IF name$="0" THEN EXIT SUB
INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
WAIT DELAY wd
IF tel$="0" THEN EXIT SUB
LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
IF CONFIRM$(c$)="YES" THEN
LET DT$(i,2)=name$
LET DT$(i,3)=tel$
CALL tel(DTtel$(i),DT$(i,3))
EXIT DO
END IF
LOOP
WAIT DELAY wd
EXIT SUB
END IF
NEXT i
WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
CASE 4 ! [検索]
DO
INPUT PROMPT " 検索項目 1.氏名 2.電話番号 (キャンセルは 0)": sa
LOOP UNTIL sa=INT(sa) AND sa>=0 AND sa<=2
WAIT DELAY wd
IF sa=0 THEN EXIT SUB
INPUT PROMPT " 検索文字列 (一部分でも可, キャンセルは 0)": sa$
WAIT DELAY wd
IF sa$="0" THEN EXIT SUB
IF sa=1 THEN LET t$="氏名" ELSE LET t$="電話番号"
PRINT "検索結果 [";t$;",""";sa$;"""]"
LET sr=0
IF sa=1 THEN
FOR i=1 TO dmx
IF POS(DT$(i,2),sa$)>0 THEN
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
LET sr=sr+1
END IF
NEXT i
ELSE ! sa=2
FOR j=LEN(sa$) TO 1 STEP -1
IF sa$(j:j)<"0" OR sa$(j:j)>"9" THEN LET sa$(j:j)=""
NEXT j
FOR i=1 TO dmx
IF POS(DTtel$(i),sa$)>0 THEN
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
LET sr=sr+1
END IF
NEXT i
END IF
IF sr=0 THEN PRINT "該当するDATAはありませんでした"
CASE 5 ! [一覧]
DO
INPUT PROMPT " 1.DATA順 2.ID番号順 (キャンセルは 0)" : li
LOOP UNTIL li=INT(li) AND li>=0 AND li<=2
IF li=1 THEN
PRINT "DATA一覧"
FOR i=1 TO dmx
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
NEXT i
ELSEIF li=2 THEN
MAT sortID=ZER
CALL sort(DTid,sortID,dmx)
PRINT "DATA一覧 (ID番号順)"
FOR i=1 TO dmx
PRINT USING u$: DT$(sortID(i),1),DT$(sortID(i),2),DT$(sortID(i),3)
NEXT i
END IF
CASE 6 ! [保存]
CALL save
CASE 0 ! [終了]
IF CONFIRM$("プログラムを終了しますか？")="NO" THEN ! 訂正
LET n=7 ! 訂正
EXIT SUB ! 訂正
END IF ! 訂正
IF CONFIRM$("DATAをファイルに保存しますか？")="YES" THEN CALL save
CLOSE #1
END SELECT
WAIT DELAY wd
END SUB
!
SUB save
IF f=1 THEN
FILE GETSAVENAME s$
OPEN #1: NAME s$
LET f=f+10
END IF
ERASE #1
FOR i=1 TO dmx
IF DTid(i)<>0 THEN PRINT#1: DT$(i,1)&","&DT$(i,2)&","&DT$(i,3)
NEXT i
END SUB
!
SUB tel(t$,d$)
LET t$=""
FOR j2=1 TO LEN(d$)
IF d$(j2:j2)>="0" AND d$(j2:j2)<="9" THEN LET t$=t$&d$(j2:j2)
NEXT j2
END SUB
!
END
! 十進BASICライブラリ"\Decimal BASIC\BASICw32\Library\SORT2.LIB"
! ixにはmと下限，上限を一致させた空の配列を指定する。
! mは参照されるのみ。
! ixにmの添字を大きさの順に並べて返す。
! つまり，m(ix(1))≦m(ix(2))≦m(ix(3))≦･･･となる。
EXTERNAL SUB sort(m(),ix(),n) ! ソート
DECLARE EXTERNAL SUB q_sort
DECLARE NUMERIC i
FOR i=1 TO n
LET ix(i)=i
NEXT i
CALL q_sort(m,ix,1,n)
END SUB
!
EXTERNAL SUB q_sort(m(),a(),l,r)
DECLARE NUMERIC i,j,pv,t
IF r<=l THEN
EXIT SUB
ELSE
LET i=l-1
LET j=r
LET pv=m(a(r))
DO
DO
LET i=i+1
LOOP UNTIL pv<=m(a(i))
DO
LET j=j-1
LOOP UNTIL j<=i OR m(a(j))<=pv
IF j<=i THEN EXIT DO
LET t=a(i)
LET a(i)=a(j)
LET a(j)=t
LOOP
LET t=a(i)
LET a(i)=a(r)
LET a(r)=t
CALL q_sort(m,a,l,i-1)
CALL q_sort(m,a,i+1,r)
END IF
END SUB
END
> RCカーさんへのお返事です。
>
> >ID番号を、1からではなく、1001からにしたのは、何か理由がありますか？？
>
> → 4桁に揃えただけで特に意味はありません。
> ID番号の下限、上限は IDmin,IDmaxで設定できるので、目的に合った値に変更してください。
> また、入力データのID番号は連番でなくともかまいません。
> 例えば IDmin=1,IDmax=100 に設定し、入力を 20,15,4,16,27,…といった順番で入力してもかまいません。
> データ一覧の出力は、入力した順とID番号順の並びを選択できます。
>
>
> >データ入力ダイアログで、数字を、入れずに、OKを、クリックしたとき、シンタックスエラーが出ます。input文に、イレギュラーな、場合にどうするかを、しょりほうほうを、プログラムで、決めないと、駄目なのかな？、教えて下さい。
>
> → input文で数値変数に入力するときに数値以外(空文字列も含む)を入力すると再入力を促すのは十進BASICの仕様なので、利用者はどうすることもできません。
> ただし、文字列変数に入力するようにすれば空文字列の入力も認められるので、[OK]クリックで[0]を入力したのと同じ扱いにすることはできます。
>
> -----------------------------------------------------------------------------
> DO ! メインルーチン
> DO
> INPUT PROMPT " 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了" :n
> LOOP UNTIL n=INT(n) AND n>=0 AND n<=6
> WAIT DELAY wd
> CALL main(n)
> LOOP UNTIL n=0
> -----------------------------------------------------------------------------
> 上記の部分を、次のようにすれば[OK]クリックや[Enter]キーで[0]と同じ扱い。
> -----------------------------------------------------------------------------
> WHEN EXCEPTION IN
> DO ! メインルーチン
> DO
> INPUT PROMPT " 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了" :n$ !文字列変数入力
> LET n=VAL(n$) ! 文字列変数を数値に変換。空文字列や"abc"などは例外発生。
> LOOP UNTIL n=INT(n) AND n>=0 AND n<=6
> WAIT DELAY wd
> CALL main(n)
> LOOP UNTIL n=0
> USE ! 例外発生時の処理
> LET n=0
> CONTINUE
> END WHEN
> -----------------------------------------------------------------------------
>
>
> ◎ 重要なバグを発見しました。
> "プログラムを終了しますか？" というメッセージボックスで[いいえ]を選択しても終了してしまいます。
> 副プログラム SUB main(n) 内のselect区で、CASE 0 を次のように修正してください。
> --------------------------------------------------------------------------
> 【誤】
> CASE 0 ! [終了]
> IF CONFIRM$("プログラムを終了しますか？")="NO" THEN EXIT SUB
> IF CONFIRM$("DATAをファイルに保存しますか？")="YES" THEN CALL save
> CLOSE #1
> END SELECT
> --------------------------------------------------------------------------
> 【正】
> CASE 0 ! [終了]
> IF CONFIRM$("プログラムを終了しますか？")="NO" THEN ! 訂正
> LET n=7 ! 訂正
> EXIT SUB ! 訂正
> END IF ! 訂正
> IF CONFIRM$("DATAをファイルに保存しますか？")="YES" THEN CALL save
> CLOSE #1
> END SELECT
> --------------------------------------------------------------------------
→ マウスの左ボタンやEnterキーを長く押すと次の入力ボックスに制御が移り、そこで空文字列を入力したと認識されてしまうのが原因です。
それを回避するために WAIT DELAY wd (wdは0.1秒に設定) で一時休止しているのですが、0.1秒を超えて押すと次の制御に移ります。
対策の一つは、変数wdを0.5ぐらいに設定することです。ただし素早く操作したい利用者には不評でしょう。
もう一つは、GetKeyState関数を使いマウスボタンやEnterキーが解放されるのを待つということです。
ヘルプにはありませんが、GetKeyState(1)でマウスの左ボタン、GetKeyState(2)で右ボタンの状態を得ることが出来ます。
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
上記の2行をマウスやEnterキーの操作ごとに記述しました。
マウスの左ボタンとEnterキーの指を離すまで、次の行に移りません。
DECLARE EXTERNAL SUB sort
DECLARE NUMERIC MX,IDmin,IDmax,lenID,lenname,lentel,dmx,f,n,id,li,sa,sr,i,j,j2
DECLARE STRING idrange$,u$,s$,name$,tel$,d$,c$,sa$,t$,f$,n$,id$,sa2$,li$
OPTION CHARACTER KANJI
LET MX=200 ! data数の上限(変更可)
LET IDmin=1001 ! ID番号の下限(変更可) IDmin>=1
LET IDmax=9999 ! ID番号の上限(変更可)
LET lenID=CEIL(LOG10(IDmax))+1
LET lenNAME=8 ! 氏名の最大文字数(変更可)
LET lenTEL=14 ! 電話番号の最大文字数(変更可)
DIM DT$(MX,3),DTid(MX),DTtel$(MX),sortID(MX)
LET idrange$=STR$(IDmin)&"～"&STR$(IDmax)
LET u$=REPEAT$("#",lenID)&" <"&REPEAT$("#",2*lenNAME-1)&" <"&REPEAT$("#",lenTEL)
SET ECHO "OFF"
LET dmx=0
!
WHEN EXCEPTION IN
DO
INPUT PROMPT "【ファイル】1.新規作成 2.読込み (終了は 0)":f$
LET f=VAL(f$)
LOOP UNTIL f=INT(f) AND f>=0 AND f<=2
USE
LET f=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF f=1 THEN
CALL main(1)
ELSEIF f=2 THEN
FILE GETOPENNAME s$ ! 電話帳ファイルの読込み
OPEN #1: NAME s$
DO
LET dmx=dmx+1
INPUT #1, IF MISSING THEN EXIT DO: DT$(dmx,1),DT$(dmx,2),DT$(dmx,3)
LET DTid(dmx)=VAL(DT$(dmx,1))
CALL tel(DTtel$(dmx),DT$(dmx,3))
LOOP
LET dmx=dmx-1
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
ELSE
STOP
END IF
!
WHEN EXCEPTION IN
DO ! メインルーチン
DO
INPUT PROMPT " 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了" :n$
LET n=VAL(n$)
LOOP UNTIL n=INT(n) AND n>=0 AND n<=6
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
CALL main(n)
LOOP UNTIL n=0
USE
LET n=0
CONTINUE
END WHEN
!
SUB main(n)
SELECT CASE n
CASE 1 ! [入力]
DO
IF dmx>=MX THEN
WAIT DELAY "DATA数が上限 "&STR$(MX)&" に達していて、入力が出来ません"
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
EXIT SUB
END IF
WHEN EXCEPTION IN
DO
INPUT PROMPT " ID番号入力 "&idrange$&" (入力終了は 0)" :id$
LET id=VAL(id$)
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
USE
LET id=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF id=0 THEN EXIT DO
INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF name$="0" OR name$="" THEN EXIT DO
INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF tel$="0" OR tel$="" THEN EXIT DO
LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
IF CONFIRM$(c$)="YES" THEN
LET dmx=dmx+1
LET DT$(dmx,1)=STR$(id)
LET DT$(dmx,2)=name$
LET DT$(dmx,3)=tel$
LET DTid(dmx)=id
CALL tel(DTtel$(dmx),DT$(dmx,3))
END IF
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
LOOP
CASE 2 ! [削除]
WHEN EXCEPTION IN
DO
INPUT PROMPT " 削除するDATAのID番号を入力 (キャンセルは 0)" :id$
LET id=VAL(id$)
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
USE
LET id=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF id=0 THEN EXIT SUB
FOR i=1 TO dmx
IF DTid(i)=id THEN
LET d$="下記のDATAを削除しますか？"&CHR$(10)&"ID："&DT$(i,1)
LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
IF CONFIRM$(d$)="YES" THEN
PRINT "削除したDATA"
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
FOR j=i+1 TO dmx
LET DT$(j-1,1)=DT$(j,1)
LET DT$(j-1,2)=DT$(j,2)
LET DT$(j-1,3)=DT$(j,3)
LET DTid(j-1)=VAL(DT$(j,1))
LET DTtel$(j-1)=DTtel$(j)
NEXT j
LET DT$(dmx,1),DT$(dmx,2),DT$(dmx,3),DTtel$(dmx)=""
LET DTid(dmx)=0
LET dmx=dmx-1
END IF
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
EXIT SUB
END IF
NEXT i
WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
CASE 3 ! [更新]
WHEN EXCEPTION IN
DO
INPUT PROMPT " 更新するDATAのID番号を入力 (キャンセルは 0)" :id$
LET id=VAL(id$)
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
USE
LET id=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF id=0 THEN EXIT SUB
FOR i=1 TO dmx
IF DTid(i)=id THEN
LET d$="下記のDATAを書き換えますか？"&CHR$(10)&"ID："&DT$(i,1)
LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
IF CONFIRM$(d$)="NO" THEN EXIT SUB
PRINT "更新前のDATA"
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
DO
INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF name$="0" OR name$="" THEN EXIT SUB
INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF tel$="0" OR tel$="" THEN EXIT SUB
LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
IF CONFIRM$(c$)="YES" THEN
LET DT$(i,2)=name$
LET DT$(i,3)=tel$
CALL tel(DTtel$(i),DT$(i,3))
EXIT DO
END IF
LOOP
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
EXIT SUB
END IF
NEXT i
WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
CASE 4 ! [検索]
WHEN EXCEPTION IN
DO
INPUT PROMPT " 検索項目 1.氏名 2.電話番号 (キャンセルは 0)": sa2$
LET sa=VAL(sa2$)
LOOP UNTIL sa=INT(sa) AND sa>=0 AND sa<=2
USE
LET sa=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF sa=0 THEN EXIT SUB
INPUT PROMPT " 検索文字列 (一部分でも可, キャンセルは 0)": sa$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF sa$="0" OR sa$="" THEN EXIT SUB
IF sa=1 THEN LET t$="氏名" ELSE LET t$="電話番号"
PRINT "検索結果 [";t$;",""";sa$;"""]"
LET sr=0
IF sa=1 THEN
FOR i=1 TO dmx
IF POS(DT$(i,2),sa$)>0 THEN
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
LET sr=sr+1
END IF
NEXT i
ELSE ! sa=2
FOR j=LEN(sa$) TO 1 STEP -1
IF sa$(j:j)<"0" OR sa$(j:j)>"9" THEN LET sa$(j:j)=""
NEXT j
FOR i=1 TO dmx
IF POS(DTtel$(i),sa$)>0 THEN
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
LET sr=sr+1
END IF
NEXT i
END IF
IF sr=0 THEN PRINT "該当するDATAはありませんでした"
CASE 5 ! [一覧]
WHEN EXCEPTION IN
DO
INPUT PROMPT " 1.DATA順 2.ID番号順 (キャンセルは 0)" : li$
LET li=VAL(li$)
LOOP UNTIL li=INT(li) AND li>=0 AND li<=2
USE
LET li=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF li=1 THEN
PRINT "DATA一覧"
FOR i=1 TO dmx
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
NEXT i
ELSEIF li=2 THEN
MAT sortID=ZER
CALL sort(DTid,sortID,dmx)
PRINT "DATA一覧 (ID番号順)"
FOR i=1 TO dmx
PRINT USING u$: DT$(sortID(i),1),DT$(sortID(i),2),DT$(sortID(i),3)
NEXT i
END IF
CASE 6 ! [保存]
CALL save
CASE 0 ! [終了]
IF CONFIRM$("プログラムを終了しますか？")="NO" THEN
LET n=7
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
EXIT SUB
END IF
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF CONFIRM$("DATAをファイルに保存しますか？")="YES" THEN CALL save
CLOSE #1
END SELECT
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
END SUB
!
SUB save
IF f=1 THEN
FILE GETSAVENAME s$
OPEN #1: NAME s$
LET f=f+10
END IF
ERASE #1
FOR i=1 TO dmx
IF DTid(i)<>0 THEN PRINT#1: DT$(i,1)&","&DT$(i,2)&","&DT$(i,3)
NEXT i
END SUB
!
SUB tel(t$,d$)
LET t$=""
FOR j2=1 TO LEN(d$)
IF d$(j2:j2)>="0" AND d$(j2:j2)<="9" THEN LET t$=t$&d$(j2:j2)
NEXT j2
END SUB
!
END
! 十進BASICライブラリ"\Decimal BASIC\BASICw32\Library\SORT2.LIB"
! ixにはmと下限，上限を一致させた空の配列を指定する。
! mは参照されるのみ。
! ixにmの添字を大きさの順に並べて返す。
! つまり，m(ix(1))≦m(ix(2))≦m(ix(3))≦･･･となる。
EXTERNAL SUB sort(m(),ix(),n) ! ソート
DECLARE EXTERNAL SUB q_sort
DECLARE NUMERIC i
FOR i=1 TO n
LET ix(i)=i
NEXT i
CALL q_sort(m,ix,1,n)
END SUB
!
EXTERNAL SUB q_sort(m(),a(),l,r)
DECLARE NUMERIC i,j,pv,t
IF r<=l THEN
EXIT SUB
ELSE
LET i=l-1
LET j=r
LET pv=m(a(r))
DO
DO
LET i=i+1
LOOP UNTIL pv<=m(a(i))
DO
LET j=j-1
LOOP UNTIL j<=i OR m(a(j))<=pv
IF j<=i THEN EXIT DO
LET t=a(i)
LET a(i)=a(j)
LET a(j)=t
LOOP
LET t=a(i)
LET a(i)=a(r)
LET a(r)=t
CALL q_sort(m,a,l,i-1)
CALL q_sort(m,a,i+1,r)
END IF
END SUB
不具合を発見したので修正をお願いします。
ID番号の重複チェックをしていませんでした。同じID番号での登録ができてしまいます。
副プログラム SUB main(n) の select区 CASE 1 の WHEN EXCEPTION IN ～ END WHEN の部分を下記のように修正してください。
---------------------------------------------------------------------------------
【誤】
WHEN EXCEPTION IN
DO
INPUT PROMPT " ID番号入力 "&idrange$&" (入力終了は 0)" :id$
LET id=VAL(id$)
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
USE
LET id=0
CONTINUE
END WHEN
---------------------------------------------------------------------------------
【正】
WHEN EXCEPTION IN
DO
LET check=0
DO
INPUT PROMPT " ID番号入力 "&idrange$&" (入力終了は 0)" :id$
LET id=VAL(id$)
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
FOR i=1 TO dmx
IF DTid(i)=id THEN
LET c$="ID番号 "&id$&" は既に使われています。"&CHR$(10)
LET c$=c$&"他の番号にするか、[削除]または[更新]を利用してください。"
WAIT DELAY c$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
LET check=1
EXIT FOR
END IF
NEXT i
LOOP UNTIL check=0
USE
LET id=0
CONTINUE
END WHEN
---------------------------------------------------------------------------------
DECLARE EXTERNAL SUB sort
DECLARE NUMERIC MX,IDmin,IDmax,lenID,lenname,lentel,dmx,f,n,id,li,sa,sr,i,j,j2
DECLARE STRING idrange$,u$,s$,name$,tel$,d$,c$,sa$,t$,f$,n$,id$,sa2$,li$
OPTION CHARACTER KANJI
LET MX=200 ! data数の上限(変更可)
LET IDmin=1001 ! ID番号の下限(変更可) IDmin>=1
LET IDmax=9999 ! ID番号の上限(変更可)
LET lenID=CEIL(LOG10(IDmax))+1
LET lenNAME=8 ! 氏名の最大文字数(変更可)
LET lenTEL=14 ! 電話番号の最大文字数(変更可)
DIM DT$(MX,3),DTid(MX),DTtel$(MX),sortID(MX)
LET idrange$=STR$(IDmin)&"～"&STR$(IDmax)
LET u$=REPEAT$("#",lenID)&" <"&REPEAT$("#",2*lenNAME-1)&" <"&REPEAT$("#",lenTEL)
SET ECHO "OFF"
LET dmx=0
!
WHEN EXCEPTION IN
DO
INPUT PROMPT "【ファイル】1.新規作成 2.読込み (終了は 0)":f$
LET f=VAL(f$)
LOOP UNTIL f=INT(f) AND f>=0 AND f<=2
USE
LET f=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF f=1 THEN
CALL main(1)
ELSEIF f=2 THEN
FILE GETOPENNAME s$ ! 電話帳ファイルの読込み
OPEN #1: NAME s$
DO
LET dmx=dmx+1
INPUT #1, IF MISSING THEN EXIT DO: DT$(dmx,1),DT$(dmx,2),DT$(dmx,3)
LET DTid(dmx)=VAL(DT$(dmx,1))
CALL tel(DTtel$(dmx),DT$(dmx,3))
LOOP
LET dmx=dmx-1
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
ELSE
STOP
END IF
!
WHEN EXCEPTION IN
DO ! メインルーチン
DO
INPUT PROMPT " 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了" :n$
LET n=VAL(n$)
LOOP UNTIL n=INT(n) AND n>=0 AND n<=6
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
CALL main(n)
LOOP UNTIL n=0
USE
LET n=0
CONTINUE
END WHEN
!
SUB main(n)
SELECT CASE n
CASE 1 ! [入力]
DO
IF dmx>=MX THEN
WAIT DELAY "DATA数が上限 "&STR$(MX)&" に達していて、入力が出来ません"
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
EXIT SUB
END IF
WHEN EXCEPTION IN
DO
LET check=0
DO
INPUT PROMPT " ID番号入力 "&idrange$&" (入力終了は 0)" :id$
LET id=VAL(id$)
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
FOR i=1 TO dmx
IF DTid(i)=id THEN
LET c$="ID番号 "&id$&" は既に使われています。"&CHR$(10)
LET c$=c$&"他の番号にするか、[削除]または[更新]を利用してください。"
WAIT DELAY c$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
LET check=1
EXIT FOR
END IF
NEXT i
LOOP UNTIL check=0
USE
LET id=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF id=0 THEN EXIT DO
INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF name$="0" OR name$="" THEN EXIT DO
INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF tel$="0" OR tel$="" THEN EXIT DO
LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
IF CONFIRM$(c$)="YES" THEN
LET dmx=dmx+1
LET DT$(dmx,1)=STR$(id)
LET DT$(dmx,2)=name$
LET DT$(dmx,3)=tel$
LET DTid(dmx)=id
CALL tel(DTtel$(dmx),DT$(dmx,3))
END IF
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
LOOP
CASE 2 ! [削除]
WHEN EXCEPTION IN
DO
INPUT PROMPT " 削除するDATAのID番号を入力 (キャンセルは 0)" :id$
LET id=VAL(id$)
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
USE
LET id=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF id=0 THEN EXIT SUB
FOR i=1 TO dmx
IF DTid(i)=id THEN
LET d$="下記のDATAを削除しますか？"&CHR$(10)&"ID："&DT$(i,1)
LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
IF CONFIRM$(d$)="YES" THEN
PRINT "削除したDATA"
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
FOR j=i+1 TO dmx
LET DT$(j-1,1)=DT$(j,1)
LET DT$(j-1,2)=DT$(j,2)
LET DT$(j-1,3)=DT$(j,3)
LET DTid(j-1)=VAL(DT$(j,1))
LET DTtel$(j-1)=DTtel$(j)
NEXT j
LET DT$(dmx,1),DT$(dmx,2),DT$(dmx,3),DTtel$(dmx)=""
LET DTid(dmx)=0
LET dmx=dmx-1
END IF
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
EXIT SUB
END IF
NEXT i
WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
CASE 3 ! [更新]
WHEN EXCEPTION IN
DO
INPUT PROMPT " 更新するDATAのID番号を入力 (キャンセルは 0)" :id$
LET id=VAL(id$)
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
USE
LET id=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF id=0 THEN EXIT SUB
FOR i=1 TO dmx
IF DTid(i)=id THEN
LET d$="下記のDATAを書き換えますか？"&CHR$(10)&"ID："&DT$(i,1)
LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
IF CONFIRM$(d$)="NO" THEN EXIT SUB
PRINT "更新前のDATA"
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
DO
INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF name$="0" OR name$="" THEN EXIT SUB
INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF tel$="0" OR tel$="" THEN EXIT SUB
LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
IF CONFIRM$(c$)="YES" THEN
LET DT$(i,2)=name$
LET DT$(i,3)=tel$
CALL tel(DTtel$(i),DT$(i,3))
EXIT DO
END IF
LOOP
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
EXIT SUB
END IF
NEXT i
WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
CASE 4 ! [検索]
WHEN EXCEPTION IN
DO
INPUT PROMPT " 検索項目 1.氏名 2.電話番号 (キャンセルは 0)": sa2$
LET sa=VAL(sa2$)
LOOP UNTIL sa=INT(sa) AND sa>=0 AND sa<=2
USE
LET sa=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF sa=0 THEN EXIT SUB
INPUT PROMPT " 検索文字列 (一部分でも可, キャンセルは 0)": sa$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF sa$="0" OR sa$="" THEN EXIT SUB
IF sa=1 THEN LET t$="氏名" ELSE LET t$="電話番号"
PRINT "検索結果 [";t$;",""";sa$;"""]"
LET sr=0
IF sa=1 THEN
FOR i=1 TO dmx
IF POS(DT$(i,2),sa$)>0 THEN
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
LET sr=sr+1
END IF
NEXT i
ELSE ! sa=2
FOR j=LEN(sa$) TO 1 STEP -1
IF sa$(j:j)<"0" OR sa$(j:j)>"9" THEN LET sa$(j:j)=""
NEXT j
FOR i=1 TO dmx
IF POS(DTtel$(i),sa$)>0 THEN
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
LET sr=sr+1
END IF
NEXT i
END IF
IF sr=0 THEN PRINT "該当するDATAはありませんでした"
CASE 5 ! [一覧]
WHEN EXCEPTION IN
DO
INPUT PROMPT " 1.DATA順 2.ID番号順 (キャンセルは 0)" : li$
LET li=VAL(li$)
LOOP UNTIL li=INT(li) AND li>=0 AND li<=2
USE
LET li=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF li=1 THEN
PRINT "DATA一覧"
FOR i=1 TO dmx
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
NEXT i
ELSEIF li=2 THEN
MAT sortID=ZER
CALL sort(DTid,sortID,dmx)
PRINT "DATA一覧 (ID番号順)"
FOR i=1 TO dmx
PRINT USING u$: DT$(sortID(i),1),DT$(sortID(i),2),DT$(sortID(i),3)
NEXT i
END IF
CASE 6 ! [保存]
CALL save
CASE 0 ! [終了]
IF CONFIRM$("プログラムを終了しますか？")="NO" THEN
LET n=7
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
EXIT SUB
END IF
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF CONFIRM$("DATAをファイルに保存しますか？")="YES" THEN CALL save
CLOSE #1
END SELECT
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
END SUB
!
SUB save
IF f=1 THEN
FILE GETSAVENAME s$
OPEN #1: NAME s$
LET f=f+10
END IF
ERASE #1
FOR i=1 TO dmx
IF DTid(i)<>0 THEN PRINT#1: DT$(i,1)&","&DT$(i,2)&","&DT$(i,3)
NEXT i
END SUB
!
SUB tel(t$,d$)
LET t$=""
FOR j2=1 TO LEN(d$)
IF d$(j2:j2)>="0" AND d$(j2:j2)<="9" THEN LET t$=t$&d$(j2:j2)
NEXT j2
END SUB
!
END
! 十進BASICライブラリ"\Decimal BASIC\BASICw32\Library\SORT2.LIB"
! ixにはmと下限，上限を一致させた空の配列を指定する。
! mは参照されるのみ。
! ixにmの添字を大きさの順に並べて返す。
! つまり，m(ix(1))≦m(ix(2))≦m(ix(3))≦･･･となる。
EXTERNAL SUB sort(m(),ix(),n) ! ソート
DECLARE EXTERNAL SUB q_sort
DECLARE NUMERIC i
FOR i=1 TO n
LET ix(i)=i
NEXT i
CALL q_sort(m,ix,1,n)
END SUB
!
EXTERNAL SUB q_sort(m(),a(),l,r)
DECLARE NUMERIC i,j,pv,t
IF r<=l THEN
EXIT SUB
ELSE
LET i=l-1
LET j=r
LET pv=m(a(r))
DO
DO
LET i=i+1
LOOP UNTIL pv<=m(a(i))
DO
LET j=j-1
LOOP UNTIL j<=i OR m(a(j))<=pv
IF j<=i THEN EXIT DO
LET t=a(i)
LET a(i)=a(j)
LET a(j)=t
LOOP
LET t=a(i)
LET a(i)=a(r)
LET a(r)=t
CALL q_sort(m,a,l,i-1)
CALL q_sort(m,a,i+1,r)
END IF
END SUB
END
!最新6n+k篩 8スレッド 2021/08/12
!
!#4360
!
!Paract BASIC 6n+k篩 Ver.12 MAX500兆 5/9 (1E8) step
!
DECLARE STRUCTURE struct1: 1 OF NUMERIC
DECLARE STRUCTURE struct2: 1 OF NUMERIC(1536277)
DECLARE STRUCTURE struct4: 3 OF NUMERIC
DECLARE SHARED sha OF struct2
DECLARE MESSAGE mes2 OF struct4
DECLARE MESSAGE mes3 OF struct4
DECLARE MESSAGE mes4 OF struct4
DECLARE MESSAGE mes5 OF struct4
DECLARE MESSAGE mes6 OF struct4
DECLARE MESSAGE mes7 OF struct4
DECLARE MESSAGE mes8 OF struct4
DECLARE MESSAGE met2 OF struct1
DECLARE MESSAGE met3 OF struct1
DECLARE MESSAGE met4 OF struct1
DECLARE MESSAGE met5 OF struct1
DECLARE MESSAGE met6 OF struct1
DECLARE MESSAGE met7 OF struct1
DECLARE MESSAGE met8 OF struct1
PARACT PART1
OPTION ARITHMETIC NATIVE
LET t1=TIME
PRINT DATE$;" ";TIME$
LET k=24494963
LET k3=1536277
DECLARE EXTERNAL SUB prime
CALL prime(k)
WAIT EVENT Ok5
LET S=464E12 !2140E11 !pi(1E12),37607912018
LET E=466E12 !2160E11 !pi(1E11),4118054813 (1E10)455052511
LET ST=1E8
START PART2
START PART3
START PART4
START PART5
START PART6
START PART7
START PART8
SEND TO mes2 FROM S,E,ST
SEND TO mes3 FROM S,E,ST
SEND TO mes4 FROM S,E,ST
SEND TO mes5 FROM S,E,ST
SEND TO mes6 FROM S,E,ST
SEND TO mes7 FROM S,E,ST
SEND TO mes8 FROM S,E,ST
LET TOTAL=14173019702434 !5761455
DECLARE EXTERNAL FUNCTION cprime
!DECLARE NUMERIC X,Y,Z
FOR I=S TO E-ST STEP ST
LET t0=TIME
LET L=cprime(I,I+ST/8)
RECEIVE FROM met2 TO X
RECEIVE FROM met3 TO Y
RECEIVE FROM met4 TO Z
RECEIVE FROM met5 TO X1
RECEIVE FROM met6 TO Y1
RECEIVE FROM met7 TO Z1
RECEIVE FROM met8 TO X2
LET L=L+X+Y+Z+X1+Y1+Z1+X2
LET TOTAL=TOTAL+L
PRINT (I+ST)/1E8;TOTAL;L;
LET TM=TIME-t0
PRINT USING"###.###":TM;
PRINT "秒"
NEXT I
LET TM=TIME-t1
PRINT USING"#####.##":TM;
PRINT "秒"
PRINT DATE$;" ";TIME$
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes2 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+ST/8,I+ST/4)
SEND TO met2 FROM L
NEXT I
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes3 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+ST/4,I+3*ST/8)
SEND TO met3 FROM L
NEXT I
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes4 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+3*ST/8,I+ST/2)
SEND TO met4 FROM L
NEXT I
END PARACT
PARACT PART5
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes5 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+ST/2,I+5*ST/8)
SEND TO met5 FROM L
NEXT I
END PARACT
PARACT PART6
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes6 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+5*ST/8,I+3*ST/4)
SEND TO met6 FROM L
NEXT I
END PARACT
PARACT PART7
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes7 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+3*ST/4,I+7*ST/8)
SEND TO met7 FROM L
NEXT I
END PARACT
PARACT PART8
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes8 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+7*ST/8,I+ST)
SEND TO met8 FROM L
NEXT I
END PARACT
EXTERNAL FUNCTION cprime(k4,k6)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(1536277) !素数
GET FROM sha TO G
DIM B(2) !素数の最小値7から
DATA 1,5
MAT READ B
LET Q=6
LET U=IP(k6/Q)
LET U1=IP(SQR(k6))
LET W=IP(k4/Q)
LET kD=IP(k6/29)
LET M7=W
DIM D(0 TO U-M7)
LET COUNT=0
FOR r=1 TO 2
LET rr=B(r)
MAT D = ZER
FOR t=3 TO U1
LET x=G(t)
IF x^2>k6 THEN EXIT FOR
LET G1=INT(W/x)
IF MOD(x+rr,Q)=0 THEN
LET y=-(x+rr)/Q
GOTO 70
END IF
IF MOD(x-rr,Q)=0 THEN
LET y=(x-rr)/Q
GOTO 70
END IF
70 FOR f=G1 TO kD
IF x*f+y<W THEN GOTO 80
IF x*f+y>U THEN GOTO 90
LET D(x*f+y-M7)=1
80 NEXT f
90 NEXT t
FOR n=0 TO U-M7
LET ST=n+M7
IF D(n)=0 THEN
IF Q*ST+rr>k4 AND Q*ST+rr<k6 THEN LET COUNT=COUNT+1
END IF
NEXT n
NEXT r
LET cprime=COUNT
END FUNCTION
EXTERNAL SUB prime(k)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(1536277) !素数
!エラトステネスの篩
LET Fu=5633
LET Fm=739
DIM P(Fu)
DIM A(Fm)
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO Fm
LET Pu=A(n)
IF Pu^2>=k THEN EXIT FOR
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET G(1)=2
LET G(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n+1
END IF
NEXT n
PUT TO sha FROM G
SIGNAL Ok5
END SUB
! 6n±1篩 Ver.2
OPTION ARITHMETIC NATIVE !2進モード
LET t0=TIME
LET k=1E8 !1E7 9999991 素数 (664579th)
LET k1=IP(k/6) !1E8 99999989 素数 (5761455th)
LET k2=IP(SQR(k1))!5E8 499999993 素数 (26355867th)
DIM A5(k1),A7(k1)
MAT A5=ZER
MAT A7=ZER
LET P1=5
LET C1=1
DO
FOR n=1 TO k1
LET P6=P1*n+C1
IF P6 > k1 THEN EXIT FOR
LET A5(P6)=1
NEXT n
FOR n=1 TO k1
LET P6=P1*n-C1
IF P6 > k1 THEN EXIT FOR
LET A7(P6)=1
NEXT n
LET P1=P1+6
LET C1=C1+1
IF P1 >k1 THEN EXIT DO
LOOP
LET P1=7
LET C1=1
DO
FOR n=1 TO k1
LET P6=P1*n+C1
IF P6 > k1 THEN EXIT FOR
LET A7(P6)=1
NEXT n
FOR n=1 TO k1
LET P6=P1*n-C1
IF P6 > k1 THEN EXIT FOR
LET A5(P6)=1
NEXT n
LET P1=P1+6
LET C1=C1+1
IF P1 >k1 THEN EXIT DO
LOOP
PRINT "2"
PRINT "3"
LET c=2
FOR n=1 TO k1
LET P5=6*n-1
LET P7=6*n+1
IF A5(n)=0 THEN
LET c=c+1
IF k-1000<P5 THEN PRINT P5
END IF
IF A7(n)=0 THEN
LET c=c+1
IF k-1000<P7 THEN PRINT P7
END IF
NEXT n
EXTERNAL FUNCTION π(N)
FOR J=2 TO INT(N)
LET SS=0
FOR I=1 TO J
LET SS=SS+INT(J/I)-INT((J-1)/I)
NEXT I
LET S=S+(1+INT((2-SS)/J))
NEXT J
LET π=S
END FUNCTION
-------------------------------------------------------
PRINT π(1000)
END
EXTERNAL FUNCTION π(N)
FOR I=2 TO N
LET S=S+ISPRIME(I)
NEXT I
LET π=S
END FUNCTION
EXTERNAL FUNCTION ISPRIME(N)
LET S=1
FOR I=2 TO N-1
LET S=MOD(S*I,N)
NEXT I
IF MOD(S*S,N)=1 THEN
LET ISPRIME=1
ELSE
LET ISPRIME=0
END IF
END FUNCTION
LET N=105000
DIM PRIME(N),LDF(N)
FOR D=2 TO N
IF LDF(D)=0 THEN
LET LDF(D)=D
LET K=K+1
LET PRIME(K)=D
IF MOD(K,1000)=0 THEN PRINT K;"th prime ";D
END IF
FOR I=1 TO K
LET P=PRIME(I)
IF P*D>N OR P>LDF(D) THEN EXIT FOR
LET LDF(P*D)=P
NEXT I
NEXT D
END
LET N=105000
LET COUNT=1
FOR I=3 TO N STEP 2
LET FL=0
FOR J=3 TO INT(SQR(I))
IF MOD(I,J)=0 THEN
LET FL=1
EXIT FOR
END IF
NEXT J
IF FL=0 THEN
LET COUNT=COUNT+1
IF MOD(COUNT,100)=0 THEN PRINT COUNT;"th prime ";I
END IF
NEXT I
END
-------------------------------------------------------------------------------
LET S=1
DO WHILE S<100
LET S=NEXTPRIME(S)
PRINT S
LOOP
END
EXTERNAL FUNCTION NEXTPRIME(X)
IF X<2 THEN
LET NEXTPRIME=2
EXIT FUNCTION
END IF
IF MOD(X,2)=0 THEN LET X=X+1 ELSE LET X=X+2
DO
LET FL=0
FOR N=3 TO INT(SQR(X))
IF MOD(X,N)=0 THEN
LET FL=1
EXIT FOR
END IF
NEXT N
IF FL=0 THEN
LET NEXTPRIME=X
EXIT FUNCTION
END IF
LET X=X+2
LOOP
END FUNCTION
FOR I=1 TO 6
LET N=10^I
PRINT N;"th prime";NTHPRIME(N)
NEXT I
END
EXTERNAL FUNCTION NTHPRIME(M)
LET N=M*(LOG(M)+LOG(LOG(M)))
LET K=INT((N-2)/2)
DIM A(K)
FOR I=1 TO INT(K/3)
LET J=I
DO WHILE I+J+2*I*J<=K
LET S=I+J+2*I*J
LET A(S)=1
LET J=J+1
LOOP
NEXT I
LET COUNT=1
FOR I=1 TO K
IF A(I)=0 THEN
LET COUNT=COUNT+1
IF COUNT=M THEN
LET NTHPRIME=I*2+1
EXIT FUNCTION
END IF
END IF
NEXT I
END FUNCTION
FOR I=1 TO 10
LET N=I*10^5
PRINT N;"th prime";NTHPRIME(N)
NEXT I
END
EXTERNAL FUNCTION NTHPRIME(M)
LET N=M*(LOG(M)+LOG(LOG(M)))
DIM ISPRIME(N)
FOR Z=1 TO 5 STEP 4
FOR Y=Z TO SQR(N) STEP 6
FOR X=1 TO SQR(N)
LET NN=4*X*X+Y*Y
IF NN>N THEN EXIT FOR
LET ISPRIME(NN)=BITNOT(ISPRIME(NN))
NEXT X
FOR X=Y+1 TO SQR(N) STEP 2
LET NN=3*X*X-Y*Y
IF NN>N THEN EXIT FOR
LET ISPRIME(NN)=BITNOT(ISPRIME(NN))
NEXT X
NEXT Y
NEXT Z
FOR Z=2 TO 4 STEP 2
FOR Y=Z TO SQR(N) STEP 6
FOR X=1 TO SQR(N) STEP 2
LET NN=3*X*X+Y*Y
IF NN>N THEN EXIT FOR
LET ISPRIME(NN)=BITNOT(ISPRIME(NN))
NEXT X
FOR X=Y+1 TO SQR(N) STEP 2
LET NN=3*X*X-Y*Y
IF NN>N THEN EXIT FOR
LET ISPRIME(NN)=BITNOT(ISPRIME(NN))
NEXT X
NEXT Y
NEXT Z
FOR Z=1 TO 2
FOR Y=3 TO SQR(N) STEP 6
FOR X=Z TO SQR(N) STEP 3
LET NN=4*X*X+Y*Y
IF NN>N THEN EXIT FOR
LET ISPRIME(NN)=BITNOT(ISPRIME(NN))
NEXT X
NEXT Y
NEXT Z
FOR P=5 TO SQR(N)
IF ISPRIME(P)=-1 THEN
FOR K=P*P TO N STEP P*P
LET ISPRIME(K)=0
NEXT K
END IF
NEXT P
LET ISPRIME(2)=-1
LET ISPRIME(3)=-1
LET COUNT=1
FOR I=3 TO N STEP 2
IF ISPRIME(I)=-1 THEN
LET COUNT=COUNT+1
IF COUNT=M THEN
LET NTHPRIME=I
EXIT FUNCTION
END IF
END IF
NEXT I
END FUNCTION
-------------------------------------------------------------------------------
LET LIMIT=1000000
DIM SIEVE(LIMIT)
LET FACTOR=INT(SQR(LIMIT))+1
FOR I=1 TO FACTOR
FOR J=1 TO FACTOR
LET N=4*I*I+J*J
IF N<=LIMIT AND (MOD(N,12)=1 OR MOD(N,12)=5) THEN LET SIEVE(N)=BITNOT(SIEVE(N))
LET N=3*I*I+J*J
IF N<=LIMIT AND MOD(N,12)=7 THEN LET SIEVE(N)=BITNOT(SIEVE(N))
IF I>J THEN
LET N=3*I*I-J*J
IF N<=LIMIT AND MOD(N,12)=11 THEN LET SIEVE(N)=BITNOT(SIEVE(N))
END IF
NEXT J
NEXT I
FOR I=5 TO FACTOR
IF SIEVE(I)=-1 THEN
FOR J=I*I TO LIMIT STEP I*I
LET SIEVE(J)=0
NEXT J
END IF
NEXT I
LET COUNT=3 ! [2 3 5]
FOR I=7 TO LIMIT STEP 2
IF SIEVE(I)=-1 THEN LET COUNT=COUNT+1
NEXT I
PRINT COUNT
END
-------------------------------------------------------------------------------
LET M=1000000
DIM P(M)
LET SM=INT(SQR(M))
FOR X=1 TO INT(SM/2)
LET V=4*X*X+1
LET Y=8
DO WHILE V<=M
IF MOD(V,12)<>9 THEN LET P(V)=BITXOR(P(V),1)
LET V=V+Y
LET Y=Y+8
LOOP
NEXT X
FOR X=1 TO INT(SM/3^.5) STEP 2
LET V=3*X*X+4
LET Y=12
DO WHILE V<=M
IF MOD(V,12)=7 THEN LET P(V)=BITXOR(P(V),1)
LET V=V+Y
LET Y=Y+8
LOOP
NEXT X
FOR X=2 TO INT(SM/2^.5)
LET V=2*X*(X+1)-1
LET Y=4*X-8
DO WHILE Y>=0 AND V<=M
IF MOD(V,12)=11 THEN LET P(V)=BITXOR(P(V),1)
LET V=V+Y
LET Y=Y-8
LOOP
NEXT X
FOR N=5 TO SM
IF P(N)>0 THEN
FOR Z=N*N TO M-1 STEP N*N
LET P(Z)=0
NEXT Z
END IF
NEXT N
LET P(2)=1
LET P(3)=1
FOR I=2 TO M-1
IF P(I)>0 THEN LET COUNT=COUNT+1
NEXT I
PRINT COUNT
END
LET N=5
FOR I=1 TO 10
LET E=I*10^N
LET PE=PRIMECOUNT(E)
PRINT S+1;"～";E;":";PE-PS;PE
LET S=E
LET PS=PE
NEXT I
END
EXTERNAL FUNCTION PRIMECOUNT(N)
DIM P(N)
! ２を特別扱い
FOR I=1 TO INT(SQR(N)/2) ! ループ SQR(N)/2
LET K=2*I+1
IF N<K THEN EXIT FOR
IF P(K)=0 THEN
FOR L=K*K TO N STEP K*2
LET P(L)=1
NEXT L
END IF
NEXT I
LET COUNT=1 ! 2
FOR I=1 TO INT(N/2)
LET K=2*I+1
IF N<K THEN EXIT FOR
IF P(K)=0 THEN LET COUNT=COUNT+1
NEXT I
LET PRIMECOUNT=COUNT
END FUNCTION
LET N=5
FOR I=1 TO 10
LET E=I*10^N
LET PE=PRIMECOUNT(E)
PRINT S+1;"～";E;":";PE-PS;PE
LET S=E
LET PS=PE
NEXT I
END
EXTERNAL FUNCTION PRIMECOUNT(N)
DIM A(2),P(N)
MAT READ A
! ２・３を特別扱い
DATA 1,5
FOR I=0 TO INT(SQR(N)/6) ! ループ SQR(N)*2/6=SQR(N)/3
FOR J=1 TO 2
IF I=0 AND J=1 THEN LET J=2
LET K=6*I+A(J)
IF N<K THEN EXIT FOR
IF P(K)=0 THEN
FOR L=K*K TO N STEP K*2
LET P(L)=1
NEXT L
END IF
NEXT J
NEXT I
LET COUNT=2 ! 2 3
FOR I=0 TO INT(N/6)
FOR J=1 TO 2
IF I=0 AND J=1 THEN LET J=2
LET K=6*I+A(J)
IF N<K THEN EXIT FOR
IF P(K)=0 THEN LET COUNT=COUNT+1
NEXT J
NEXT I
LET PRIMECOUNT=COUNT
END FUNCTION
LET N=3
FOR I=0 TO 9
LET S=ERATOS(I*10^N,(I+1)*10^N)
LET SUM=SUM+S
PRINT I*10^N+1;"～";(I+1)*10^N;":";S;SUM
NEXT I
END
EXTERNAL FUNCTION ERATOS(S,E) ! S>=0 , S<E , E>5
DIM P(0 TO E-S+1),A(8)
MAT READ A
DATA 1,7,11,13,17,19,23,29
FOR I=0 TO INT(SQR(E)/30)
FOR J=1 TO 8
IF I=0 AND J=1 THEN LET J=2
LET K=30*I+A(J)
LET KK=INT(S/K)*K
IF KK=0 THEN LET KK=K*K
IF KK < S THEN LET KK=KK+K
IF MOD(KK,K)<>0 THEN LET KK=KK+K
IF MOD(INT(KK/K),2)=0 THEN LET KK=KK+K
FOR L=KK TO E STEP K*2
LET P(L-S)=1
NEXT L
NEXT J
NEXT I
IF S<=5 THEN LET COUNT=1
IF S<=3 THEN LET COUNT=2
IF S<=2 THEN LET COUNT=3
FOR I=INT(S/30) TO INT(E/30)
FOR J=1 TO 8
IF I=0 AND J=1 THEN LET J=2
LET K=30*I+A(J)
IF K>E THEN EXIT FOR
IF K>=S AND P(K-S)=0 THEN LET COUNT=COUNT+1
NEXT J
NEXT I
LET ERATOS=COUNT
END FUNCTION
FOR I=1 TO 10
LET N=I*10^5
PRINT N;"th prime ";NTHPRIME(N)
NEXT I
END
EXTERNAL FUNCTION NTHPRIME(M) ! M>4
LET N=M*(LOG(M)+LOG(LOG(M)))
DIM P(N),A(48)
MAT READ A
DATA 1,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,101,103,107,109,113,121,127,131,137,139,143,149,151,157,163,167,169,173,179,181,187,191,193,197,199,209
FOR I=0 TO INT(SQR(N)/210)
FOR J=1 TO 48
IF I=0 AND J=1 THEN LET J=2
LET K=210*I+A(J)
FOR L=K*K TO N STEP K*2
LET P(L)=1
NEXT L
NEXT J
NEXT I
LET COUNT=4 ! M>4
FOR I=0 TO INT(N/210)
FOR J=1 TO 48
IF I=0 AND J=1 THEN LET J=2
LET K=210*I+A(J)
IF P(K)=0 THEN
LET COUNT=COUNT+1
IF COUNT=M THEN
LET NTHPRIME=K
EXIT FUNCTION
END IF
END IF
NEXT J
NEXT I
END FUNCTION
FOR I=1 TO 6
LET N=10^I
PRINT N;"th prime";NTHPRIME(N)
NEXT I
END
EXTERNAL FUNCTION NTHPRIME(N)
LET SIZE=10000000
DIM P(SIZE),A(480)
MAT READ A
DATA 1, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, 127, 131, 137, 139, 149, 151, 157, 163, 167, 169, 173, 179, 181, 191, 193, 197, 199, 211, 221, 223, 227, 229, 233, 239, 241, 247, 251, 257, 263, 269, 271, 277, 281, 283, 289, 293, 299, 307, 311, 313, 317, 323, 331, 337, 347, 349, 353, 359, 361, 367, 373, 377, 379, 383
DATA 389, 391, 397, 401, 403, 409, 419, 421, 431, 433, 437, 439, 443, 449, 457, 461, 463, 467, 479, 481, 487, 491, 493, 499, 503, 509, 521, 523, 527, 529, 533, 541, 547, 551, 557, 559, 563, 569, 571, 577, 587, 589, 593, 599, 601, 607, 611, 613, 617, 619, 629, 631, 641, 643, 647, 653, 659, 661, 667, 673, 677, 683, 689, 691, 697, 701, 703, 709, 713, 719, 727, 731, 733, 739, 743, 751, 757, 761, 767, 769
DATA 773, 779, 787, 793, 797, 799, 809, 811, 817, 821, 823, 827, 829, 839, 841, 851, 853, 857, 859, 863, 871, 877, 881, 883, 887, 893, 899, 901, 907, 911, 919, 923, 929, 937, 941, 943, 947, 949, 953, 961, 967, 971, 977, 983, 989, 991, 997,1003,1007,1009,1013,1019,1021,1027,1031,1033,1037,1039,1049,1051,1061,1063,1069,1073,1079,1081,1087,1091,1093,1097,1103,1109,1117,1121,1123,1129,1139,1147,1151,1153
DATA 1157,1159,1163,1171,1181,1187,1189,1193,1201,1207,1213,1217,1219,1223,1229,1231,1237,1241,1247,1249,1259,1261,1271,1273,1277,1279,1283,1289,1291,1297,1301,1303,1307,1313,1319,1321,1327,1333,1339,1343,1349,1357,1361,1363,1367,1369,1373,1381,1387,1391,1399,1403,1409,1411,1417,1423,1427,1429,1433,1439,1447,1451,1453,1457,1459,1469,1471,1481,1483,1487,1489,1493,1499,1501,1511,1513,1517,1523,1531,1537
DATA 1541,1543,1549,1553,1559,1567,1571,1577,1579,1583,1591,1597,1601,1607,1609,1613,1619,1621,1627,1633,1637,1643,1649,1651,1657,1663,1667,1669,1679,1681,1691,1693,1697,1699,1703,1709,1711,1717,1721,1723,1733,1739,1741,1747,1751,1753,1759,1763,1769,1777,1781,1783,1787,1789,1801,1807,1811,1817,1819,1823,1829,1831,1843,1847,1849,1853,1861,1867,1871,1873,1877,1879,1889,1891,1901,1907,1909,1913,1919,1921
DATA 1927,1931,1933,1937,1943,1949,1951,1957,1961,1963,1973,1979,1987,1993,1997,1999,2003,2011,2017,2021,2027,2029,2033,2039,2041,2047,2053,2059,2063,2069,2071,2077,2081,2083,2087,2089,2099,2111,2113,2117,2119,2129,2131,2137,2141,2143,2147,2153,2159,2161,2171,2173,2179,2183,2197,2201,2203,2207,2209,2213,2221,2227,2231,2237,2239,2243,2249,2251,2257,2263,2267,2269,2273,2279,2281,2287,2291,2293,2297,2309
LET T=0
DO
LET S=T*SIZE
LET E=(T+1)*SIZE
MAT P=ZER
FOR I=0 TO INT(SQR(E)/2310)
FOR J=1 TO 480
IF I=0 AND J=1 THEN LET J=2
LET K=2310*I+A(J)
LET KK=INT(S/K)*K
IF KK=0 THEN LET KK=K*K
IF KK < S THEN LET KK=KK+K
IF MOD(KK,K)<>0 THEN LET KK=KK+K
IF MOD(INT(KK/K),2)=0 THEN LET KK=KK+K
FOR L=KK TO E STEP K*2
LET P(L-S)=1
NEXT L
NEXT J
NEXT I
LET COUNT=0
IF S<=11 THEN LET COUNT=1
IF S<=7 THEN LET COUNT=2
IF S<=5 THEN LET COUNT=3
IF S<=3 THEN LET COUNT=4
IF S<=2 THEN LET COUNT=5
FOR I=INT(S/2310) TO INT(E/2310)
FOR J=1 TO 480
IF I=0 AND J=1 THEN LET J=2
LET K=2310*I+A(J)
IF K>E THEN EXIT FOR
IF K>=S AND P(K-S)=0 THEN
LET COUNT=COUNT+1
IF TOTAL+COUNT>=N THEN
LET NTHPRIME=K
EXIT FUNCTION
END IF
END IF
NEXT J
NEXT I
LET TOTAL=TOTAL+COUNT
LET T=T+1
LOOP
END FUNCTION
LET k=316241 !MAX 100,008,370,081
LET k2=27294
DIM P(k)
DIM A(k2) !素数
SUB prime(v) !エラトステネスの奇数列篩
LET k9=v
LET h1=1
LET A(h1)=2
LET h1=2
FOR n1=3 TO k9 STEP 2
IF P(n1)=0 THEN
LET A(h1)=n1
LET h1=h1+1
IF h1>k9+1 THEN GOTO 20
END IF
FOR k1=n1 TO k9 STEP 2
LET m1=n1*k1
IF m1>k9 THEN GOTO 10
LET P(m1)=1
NEXT k1
10 NEXT n1
20
END SUB
CALL prime(k)
DIM B(48)
DATA 1,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,101,103,107,109
DATA 113,121,127,131,137,139,143,149,151,157,163,167,169,173,179,181,187,191,193,197,199,209
MAT READ B
LET Q=210 !1E8=5761455(0.28秒)
LET k1=1E8 !1E9=50847534(3.96秒) 1E6=78498
LET ka=IP(k1/Q ) !1E10=455052511(54.25秒)
LET kb=k1 !1E11=4118054813(686.84秒)11分26秒84 (686.93秒)
LET kc=IP(SQR(k1)) !1E+8=1229, 1E+7=447
LET kd=IP(ka/11+11)
DIM D(ka)
LET k3=0
FOR n=1 TO k2
LET PP=A(n)
IF PP > kc THEN EXIT FOR
LET k3=k3+1
NEXT n
!PRINT "k3=";k3;kc
LET cj =46
FOR r=1 TO 48
LET rr=B(r)
MAT D = ZER
FOR t=5 TO k3
LET x=A(t) !素数篩
IF x^2 > k1 THEN EXIT FOR
IF MOD(x-rr,Q)=0 THEN
LET y=(x-rr)/Q
FOR f=1 TO kd
LET ii=x*f+y
IF ii>ka THEN EXIT FOR
LET D(ii)=1
NEXT f
ELSE
FOR i=1 TO 48
LET rv=B(i)
IF MOD(x*rv+rr,Q)=0 THEN
LET y=-(x*rv+rr)/Q
EXIT FOR
END IF
NEXT i
FOR f=1 TO kd
LET ii=x*f+y
IF ii > ka THEN EXIT FOR
IF ii <= 0 THEN GOTO 100
LET D(ii)=1
100 NEXT f
END IF
!PRINT x;kd;f;ii;ka
NEXT t
FOR n=1 TO ka
IF n*Q+rr>k1 THEN EXIT FOR
IF D(n)=0 THEN LET cj=cj+1
NEXT n
NEXT r
PRINT cj
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
動作報告です。
Paract BASIC プログラム 210n+k篩 素数の個数を数えるプログラム
動作環境
Intel Core i7 -8565U mouse m-Book MB-R500 ノート PC
Windows Version
Microsoft Windows 10 (10.0) Professional 64-bit
LET k=316241 !MAX 100,008,370,081
LET k2=27294
DIM P(k)
DIM A(k2) !素数
SUB prime(v) !エラトステネスの奇数列篩
LET k9=v
LET h1=1
LET A(h1)=2
LET h1=2
FOR n1=3 TO k9 STEP 2
IF P(n1)=0 THEN
LET A(h1)=n1
LET h1=h1+1
IF h1>k9+1 THEN GOTO 20
END IF
FOR k1=n1 TO k9 STEP 2
LET m1=n1*k1
IF m1>k9 THEN GOTO 10
LET P(m1)=1
NEXT k1
10 NEXT n1
20
END SUB
CALL prime(k)
LET QP=24
DIM B(QP)
DATA 1,7,11,13,17,19,23,29,31,37,41,43,47,49,53,59,61,67,71,73,77,79,83,89
MAT READ B
LET Q=90 !1E8=5761455(0.33秒)
LET k1=1E8 !1E9=50847534(4.87秒) 1E6=78498
LET ka=IP(k1/Q) !1E10=455052511(70.92秒)
LET kb=k1
LET kc=IP(SQR(k1))
LET kd=IP(ka/7+7)
DIM D(ka)
LET k3=0
FOR n=1 TO k2
LET PP=A(n)
IF PP > kc THEN EXIT FOR
LET k3=k3+1
NEXT n
! PRINT "k3=";k3;PP;kc
LET cj =QP
FOR r=1 TO QP
LET rr=B(r)
MAT D = ZER
FOR t=4 TO k3
LET x=A(t) !素数篩
IF x^2 > k1 THEN EXIT FOR
IF MOD(x-rr,Q)=0 THEN
LET y=(x-rr)/Q
FOR f=1 TO kd
LET ii=x*f+y
IF ii>ka THEN EXIT FOR
LET D(ii)=1
NEXT f
ELSE
FOR i=1 TO QP
LET rv=B(i)
IF MOD(x*rv+rr,Q)=0 THEN
LET y=-(x*rv+rr)/Q
EXIT FOR
END IF
NEXT i
FOR f=1 TO kd
LET ii=x*f+y
IF ii > ka THEN EXIT FOR
IF ii <= 0 THEN GOTO 100
LET D(ii)=1
100 NEXT f
END IF
!PRINT x;kd;f;ii;ka
NEXT t
FOR n=1 TO ka
IF n*Q+rr>k1 THEN EXIT FOR
IF D(n)=0 THEN LET cj=cj+1
NEXT n
NEXT r
PRINT cj
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
100 ! 素数積n +kの値と個数を求めるprogram
110 LET W=90 !素数積を入力(素数階乗 6,30,210,2310,30030,510510,,,)
120 LET p=w
130 LET z=w
140 OPTION BASE 0 ! DIM文より手前の行にOPTION BASE 0を追加する。
150 DIM A(p)
160 DIM B(z)
170 LET t0=TIME
180 LET p=0 ! p の初期値を0とすると、初回 1になる。140の!を削除
190 LET z=1
191 PRINT"DATA ";
192 LET cc=0
193 LET ct=20
200 FOR k=1 TO w STEP 2 !素数倍を代入
210 !
220 !
230 FOR n=1 TO 20 !素数倍周期 何周でも可能
240 LET m=w*n+k !素数倍を代入
250 FOR i=3 TO SQR(m) STEP 2 !篩
260 IF MOD(m,i)=0 THEN 300
270 NEXT i
280 !
290 LET B(z)=m
300 NEXT n
310 IF B(z)=0 THEN GOTO 370
320 LET A(p)=p
330 LET p=p+1
340 LET z=z+1
350 !
355 PRINT STR$(k);
356 LET cc=cc+1
357 IF cc=ct THEN
358 PRINT
359 ELSE
360 PRINT ",";
361 END IF
362 IF cc=ct THEN
363 !PRINT
364 PRINT"DATA ";
365 LET ct=ct+20
366 END IF
370 NEXT k
380 !
390 PRINT "k=1から数えて";p;"個"
400 PRINT TIME-t0;"秒で計算しました"
410 END
LET k=316241 !MAX 100,008,370,081
LET k2=27294
DIM P(k)
DIM A(k2) !素数
SUB prime(v) !エラトステネスの奇数列篩
LET k9=v
LET h1=1
LET A(h1)=2
LET h1=2
FOR n1=3 TO k9 STEP 2
IF P(n1)=0 THEN
LET A(h1)=n1
LET h1=h1+1
IF h1>k9+1 THEN GOTO 20
END IF
FOR k1=n1 TO k9 STEP 2
LET m1=n1*k1
IF m1>k9 THEN GOTO 10
LET P(m1)=1
NEXT k1
10 NEXT n1
20
END SUB
CALL prime(k)
LET QP=48
DIM B(QP)
DATA 1,7,11,13,17,19,23,29,31,37,41,43,47,49,53,59,61,67,71,73
DATA 77,79,83,89,91,97,101,103,107,109,113,119,121,127,131,133,137,139,143,149
DATA 151,157,161,163,167,169,173,179
MAT READ B
LET Q=180 !1E8=5761455(0.33秒)
LET k1=1E8 !1E9=50847534(4.72秒) 1E6=78498
LET ka=IP(k1/Q) !1E10=455052511(66.10秒)
LET kb=k1
LET kc=IP(SQR(k1))
LET kd=IP(ka/7+7)
DIM D(ka)
LET k3=0
FOR n=1 TO k2
LET PP=A(n)
IF PP > kc THEN EXIT FOR
LET k3=k3+1
NEXT n
! PRINT "k3=";k3;PP;kc
LET cj =QP-7
FOR r=1 TO QP
LET rr=B(r)
MAT D = ZER
FOR t=4 TO k3
LET x=A(t) !素数篩
IF x^2 > k1 THEN EXIT FOR
IF MOD(x-rr,Q)=0 THEN
LET y=(x-rr)/Q
FOR f=1 TO kd
LET ii=x*f+y
IF ii>ka THEN EXIT FOR
LET D(ii)=1
NEXT f
ELSE
FOR i=1 TO QP
LET rv=B(i)
IF MOD(x*rv+rr,Q)=0 THEN
LET y=-(x*rv+rr)/Q
EXIT FOR
END IF
NEXT i
FOR f=1 TO kd
LET ii=x*f+y
IF ii > ka THEN EXIT FOR
IF ii <= 0 THEN GOTO 100
LET D(ii)=1
100 NEXT f
END IF
!PRINT x;kd;f;ii;ka
NEXT t
FOR n=1 TO ka
IF n*Q+rr>k1 THEN EXIT FOR
IF D(n)=0 THEN LET cj=cj+1
NEXT n
NEXT r
PRINT cj
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
LET k=316241 !MAX 100,008,370,081
LET k2=27294
DIM P(k)
DIM A(k2) !素数
SUB prime(v) !エラトステネスの奇数列篩
LET k9=v
LET h1=1
LET A(h1)=2
LET h1=2
FOR n1=3 TO k9 STEP 2
IF P(n1)=0 THEN
LET A(h1)=n1
LET h1=h1+1
IF h1>k9+1 THEN GOTO 20
END IF
FOR k1=n1 TO k9 STEP 2
LET m1=n1*k1
IF m1>k9 THEN GOTO 10
LET P(m1)=1
NEXT k1
10 NEXT n1
20
END SUB
CALL prime(k)
LET QP=96
DIM B(QP)
DATA 1,7,11,13,17,19,23,29,31,37,41,43,47,49,53,59,61,67,71,73
DATA 77,79,83,89,91,97,101,103,107,109,113,119,121,127,131,133,137,139,143,149
DATA 151,157,161,163,167,169,173,179,181,187,191,193,197,199,203,209,211,217,221,223
DATA 227,229,233,239,241,247,251,253,257,259,263,269,271,277,281,283,287,289,293,299
DATA 301,307,311,313,317,319,323,329,331,337,341,343,347,349,353,359
MAT READ B
LET Q=360 !1E8=5761455(0.33秒)
LET k1=1E8 !1E9=50847534(4.38秒) 1E6=78498
LET ka=IP(k1/Q) !1E10=455052511(55.36秒)
LET kb=k1
LET kc=IP(SQR(k1))
LET kd=IP(ka/7+7)
DIM D(ka)
LET k3=0
FOR n=1 TO k2
LET PP=A(n)
IF PP > kc THEN EXIT FOR
LET k3=k3+1
NEXT n
! PRINT "k3=";k3;PP;kc
LET cj =QP-24
FOR r=1 TO QP
LET rr=B(r)
MAT D = ZER
FOR t=4 TO k3
LET x=A(t) !素数篩
IF x^2 > k1 THEN EXIT FOR
IF MOD(x-rr,Q)=0 THEN
LET y=(x-rr)/Q
FOR f=1 TO kd
LET ii=x*f+y
IF ii>ka THEN EXIT FOR
LET D(ii)=1
NEXT f
ELSE
FOR i=1 TO QP
LET rv=B(i)
IF MOD(x*rv+rr,Q)=0 THEN
LET y=-(x*rv+rr)/Q
EXIT FOR
END IF
NEXT i
FOR f=1 TO kd
LET ii=x*f+y
IF ii > ka THEN EXIT FOR
IF ii <= 0 THEN GOTO 100
LET D(ii)=1
100 NEXT f
END IF
!PRINT x;kd;f;ii;ka
NEXT t
FOR n=1 TO ka
IF n*Q+rr>k1 THEN EXIT FOR
IF D(n)=0 THEN LET cj=cj+1
NEXT n
NEXT r
PRINT cj
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
!210n+k篩 8スレッド 2021/07/10
!
!#4360
!
!Paract BASIC 210n+k篩 Ver.12 500兆 5/9 (1E8) step
!
DECLARE STRUCTURE struct1: 1 OF NUMERIC
DECLARE STRUCTURE struct2: 1 OF NUMERIC(1536277)
DECLARE STRUCTURE struct4: 3 OF NUMERIC
DECLARE SHARED sha OF struct2
DECLARE MESSAGE mes2 OF struct4
DECLARE MESSAGE mes3 OF struct4
DECLARE MESSAGE mes4 OF struct4
DECLARE MESSAGE mes5 OF struct4
DECLARE MESSAGE mes6 OF struct4
DECLARE MESSAGE mes7 OF struct4
DECLARE MESSAGE mes8 OF struct4
DECLARE MESSAGE met2 OF struct1
DECLARE MESSAGE met3 OF struct1
DECLARE MESSAGE met4 OF struct1
DECLARE MESSAGE met5 OF struct1
DECLARE MESSAGE met6 OF struct1
DECLARE MESSAGE met7 OF struct1
DECLARE MESSAGE met8 OF struct1
PARACT PART1
OPTION ARITHMETIC NATIVE
LET t1=TIME
LET k=24494963
LET k3=1536277
DECLARE EXTERNAL SUB prime
CALL prime(k)
WAIT EVENT Ok5
LET S=1E8 !pi(1E12),37607912018
LET E=1E10 !pi(1E11),4118054813 (1E10)455052511
LET ST=1E8
START Part2
START PART3
START PART4
START PART5
START PART6
START PART7
START PART8
SEND TO mes2 FROM S,E,ST
SEND TO mes3 FROM S,E,ST
SEND TO mes4 FROM S,E,ST
SEND TO mes5 FROM S,E,ST
SEND TO mes6 FROM S,E,ST
SEND TO mes7 FROM S,E,ST
SEND TO mes8 FROM S,E,ST
LET TOTAL=5761455
DECLARE EXTERNAL FUNCTION cprime
!DECLARE NUMERIC X,Y,Z
FOR I=S TO E-ST STEP ST
LET t0=TIME
LET L=cprime(I,I+ST/8)
RECEIVE FROM met2 TO X
RECEIVE FROM met3 TO Y
RECEIVE FROM met4 TO Z
RECEIVE FROM met5 TO X1
RECEIVE FROM met6 TO Y1
RECEIVE FROM met7 TO Z1
RECEIVE FROM met8 TO X2
LET L=L+X+Y+Z+X1+Y1+Z1+X2
LET TOTAL=TOTAL+L
!IF MOD(I+ST,1E9)=0 THEN PRINT (I+ST)/1E9;TOTAL
!PRINT TOTAL
PRINT (I+ST)/1E8;TOTAL;L;
LET TM=TIME-t0
PRINT USING"###.###":TM;
PRINT "秒"
NEXT I
LET TM=TIME-t1
PRINT USING"#####.##":TM;
PRINT "秒"
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes2 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+ST/8,I+ST/4)
SEND TO met2 FROM L
NEXT I
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes3 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+ST/4,I+3*ST/8)
SEND TO met3 FROM L
NEXT I
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes4 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+3*ST/8,I+ST/2)
SEND TO met4 FROM L
NEXT I
END PARACT
PARACT PART5
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes5 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+ST/2,I+5*ST/8)
SEND TO met5 FROM L
NEXT I
END PARACT
PARACT PART6
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes6 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+5*ST/8,I+3*ST/4)
SEND TO met6 FROM L
NEXT I
END PARACT
PARACT PART7
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes7 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+3*ST/4,I+7*ST/8)
SEND TO met7 FROM L
NEXT I
END PARACT
PARACT PART8
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes8 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+7*ST/8,I+ST)
SEND TO met8 FROM L
NEXT I
END PARACT
EXTERNAL FUNCTION cprime(k4,k6)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(1536277) !素数
GET FROM sha TO G
DIM B(48)
DATA 1,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,101,103,107,109
DATA 113,121,127,131,137,139,143,149,151,157,163,167,169,173,179,181,187,191,193,197,199,209
MAT READ B
LET Q=210
LET U=IP(k6/Q)
LET W=IP(k4/Q)
LET kd=IP(U/11+11)
LET kp=IP(SQR(k6))
DIM D(0 TO U-W)
LET COUNT=0
FOR r=1 TO 48
LET rr=B(r)
MAT D = ZER
LET MD=0
LET t=5
DO
LET cca=0
LET x=G(t)
IF x^2>k6 THEN EXIT DO
LET G1=INT(W/x)
IF MOD(x-rr,Q)=0 THEN
LET y=(x-rr)/Q
GOTO 800
ELSE
FOR i=1 TO 48
LET rv=B(i)
IF MOD(x*rv+rr,Q)=0 THEN
LET y=-(x*rv+rr)/Q
GOTO 800
EXIT FOR
END IF
NEXT i
END IF
IF x*G1+y < W THEN
DO
LET G1=G1+x
IF x*G1+y => W THEN EXIT DO
LOOP
END IF
800 FOR f=G1 TO kd
IF x*f+y < W THEN GOTO 900
IF x*f+y>U THEN GOTO 1000
LET D(x*f+y-W)=1
900 NEXT f
1000 LET t=t+1
LOOP
FOR n=0 TO U-W
LET ST=n+W
IF D(n)=0 THEN
IF Q*ST+rr>k4 AND Q*ST+rr<k6 THEN LET COUNT=COUNT+1
END IF
NEXT n
LET L=L+6
NEXT r
LET cprime=COUNT
END FUNCTION
EXTERNAL SUB prime(k)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(1536277) !素数
!エラトステネスの篩
LET Fu=5633
LET Fm=739
DIM P(Fu)
DIM A(Fm)
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO Fm
LET Pu=A(n)
IF Pu^2>=k THEN EXIT FOR
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET G(1)=2
LET G(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n+1
END IF
NEXT n
PUT TO sha FROM G
SIGNAL Ok5
END SUB
!30n+k篩 8スレッド 2021/07/10
!
!#4360
!
!Paract BASIC 30n+k篩 Ver.12 500兆 5/9 (1E8) step
!
DECLARE STRUCTURE struct1: 1 OF NUMERIC
DECLARE STRUCTURE struct2: 1 OF NUMERIC(1536277)
DECLARE STRUCTURE struct4: 3 OF NUMERIC
DECLARE SHARED sha OF struct2
DECLARE MESSAGE mes2 OF struct4
DECLARE MESSAGE mes3 OF struct4
DECLARE MESSAGE mes4 OF struct4
DECLARE MESSAGE mes5 OF struct4
DECLARE MESSAGE mes6 OF struct4
DECLARE MESSAGE mes7 OF struct4
DECLARE MESSAGE mes8 OF struct4
DECLARE MESSAGE met2 OF struct1
DECLARE MESSAGE met3 OF struct1
DECLARE MESSAGE met4 OF struct1
DECLARE MESSAGE met5 OF struct1
DECLARE MESSAGE met6 OF struct1
DECLARE MESSAGE met7 OF struct1
DECLARE MESSAGE met8 OF struct1
PARACT PART1
OPTION ARITHMETIC NATIVE
LET t1=TIME
LET k=24494963
LET k3=1536277
DECLARE EXTERNAL SUB prime
CALL prime(k)
WAIT EVENT Ok5
LET S=1E8 !110E11 !pi(1E12),37607912018
LET E=1E10 !111E11 !pi(1E11),4118054813 (1E10)455052511
LET ST=1E8
START Part2
START PART3
START PART4
START PART5
START PART6
START PART7
START PART8
SEND TO mes2 FROM S,E,ST
SEND TO mes3 FROM S,E,ST
SEND TO mes4 FROM S,E,ST
SEND TO mes5 FROM S,E,ST
SEND TO mes6 FROM S,E,ST
SEND TO mes7 FROM S,E,ST
SEND TO mes8 FROM S,E,ST
LET TOTAL=5761455
DECLARE EXTERNAL FUNCTION cprime
!DECLARE NUMERIC X,Y,Z
FOR I=S TO E-ST STEP ST
LET t0=TIME
LET L=cprime(I,I+ST/8)
RECEIVE FROM met2 TO X
RECEIVE FROM met3 TO Y
RECEIVE FROM met4 TO Z
RECEIVE FROM met5 TO X1
RECEIVE FROM met6 TO Y1
RECEIVE FROM met7 TO Z1
RECEIVE FROM met8 TO X2
LET L=L+X+Y+Z+X1+Y1+Z1+X2
LET TOTAL=TOTAL+L
!IF MOD(I+ST,1E9)=0 THEN PRINT (I+ST)/1E9;TOTAL
!PRINT TOTAL
PRINT (I+ST)/1E8;TOTAL;L;
LET TM=TIME-t0
PRINT USING"###.###":TM;
PRINT "秒"
NEXT I
LET TM=TIME-t1
PRINT USING"#####.##":TM;
PRINT "秒"
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes2 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+ST/8,I+ST/4)
SEND TO met2 FROM L
NEXT I
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes3 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+ST/4,I+3*ST/8)
SEND TO met3 FROM L
NEXT I
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes4 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+3*ST/8,I+ST/2)
SEND TO met4 FROM L
NEXT I
END PARACT
PARACT PART5
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes5 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+ST/2,I+5*ST/8)
SEND TO met5 FROM L
NEXT I
END PARACT
PARACT PART6
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes6 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+5*ST/8,I+3*ST/4)
SEND TO met6 FROM L
NEXT I
END PARACT
PARACT PART7
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes7 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+3*ST/4,I+7*ST/8)
SEND TO met7 FROM L
NEXT I
END PARACT
PARACT PART8
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes8 TO S,E,ST
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+7*ST/8,I+ST)
SEND TO met8 FROM L
NEXT I
END PARACT
EXTERNAL FUNCTION cprime(k4,k6)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(1536277) !素数
GET FROM sha TO G
DIM B(8)
DATA 1,7,11,13,17,19,23,29
MAT READ B
LET Q=30
LET U=IP(k6/Q)
LET W=IP(k4/Q)
LET kd=IP(U/7+7)
LET kp=IP(SQR(k6))
DIM D(0 TO U-W)
LET COUNT=0
FOR r=1 TO 8
LET rr=B(r)
MAT D = ZER
LET MD=0
LET t=4
DO
LET cca=0
LET x=G(t)
IF x^2>k6 THEN EXIT DO
LET G1=INT(W/x)
IF MOD(x-rr,Q)=0 THEN
LET y=(x-rr)/Q
GOTO 800
ELSE
FOR i=1 TO 7
LET rv=B(i)
IF MOD(x*rv+rr,Q)=0 THEN
LET y=-(x*rv+rr)/Q
GOTO 800
EXIT FOR
END IF
NEXT i
END IF
800 IF x*G1+y < W THEN
DO
LET G1=G1+1
IF x*G1+y => W THEN EXIT DO
LOOP
END IF
FOR f=G1 TO kd
IF x*f+y < W THEN GOTO 900
IF x*f+y>U THEN GOTO 1000
LET D(x*f+y-W)=1
900 NEXT f
1000 LET t=t+1
LOOP
FOR n=0 TO U-W
LET ST=n+W
IF D(n)=0 THEN
IF Q*ST+rr>k4 AND Q*ST+rr<k6 THEN LET COUNT=COUNT+1
END IF
NEXT n
LET L=L+6
NEXT r
LET cprime=COUNT
END FUNCTION
EXTERNAL SUB prime(k)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(1536277) !素数
!エラトステネスの篩
LET Fu=5633
LET Fm=739
DIM P(Fu)
DIM A(Fm)
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO Fm
LET Pu=A(n)
IF Pu^2>=k THEN EXIT FOR
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET G(1)=2
LET G(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n+1
END IF
NEXT n
PUT TO sha FROM G
SIGNAL Ok5
END SUB
REM ベルマンフォード法で最短経路を求めています。最短距離は何とか出てるみたいですが、途中経路の
REM 示し方がわかりません。ご多忙の折誠に恐縮ですが、よろしければ経路の示し方をご教授願えないでしょうか。
REM コードは下記の通りです。7つの頂点を含むグラフです。
DIM dist(7)
DIM c(7,7)
FOR y=1 TO 7
FOR z=1 TO 7
LET c(y,z)=1000
NEXT Z
NEXT Y
LET dist(1)=0
LET dist(2)=1000
LET dist(3)=1000
LET dist(4)=1000
LET dist(5)=1000
LET dist(6)=1000
LET dist(7)=1000
LET c(1,1)=0
LET c(2,2)=0
LET c(3,3)=0
LET c(4,4)=0
LET c(5,5)=0
LET c(6,6)=0
LET c(7,7)=0
LET c(1,2)=20
LET c(2,1)=20
LET c(1,3)=50
LET c(3,1)=50
LET c(2,3)=1
LET c(3,2)=1
LET c(2,4)=6
LET c(4,2)=6
LET c(3,4)=100
LET c(4,3)=100
LET c(3,5)=50
LET c(5,3)=50
LET c(4,5)=8
LET c(5,4)=8
LET c(4,7)=20
LET c(7,4)=20
LET c(5,7)=30
LET c(7,5)=30
LET c(5,6)=40
LET c(6,5)=40
LET c(6,7)=80
LET c(7,6)=80
REM-----------------------------------------------------------------
FOR t=1 TO 6
FOR i=1 TO 7
IF dist(i)>dist(t)+c(t,i) THEN LET dist(i)=dist(t)+c(t,i)
NEXT i
NEXT t
DIM dist(7), node$(7),path$(7)
MAT READ node$
DATA A,B,C,D,E,F,G
MAT path$=node$(1)&NUL$
DIM c(7,7)
MAT c=1000*CON
LET dist(1)=0
LET dist(2)=1000
LET dist(3)=1000
LET dist(4)=1000
LET dist(5)=1000
LET dist(6)=1000
LET dist(7)=1000
LET c(1,1)=0
LET c(2,2)=0
LET c(3,3)=0
LET c(4,4)=0
LET c(5,5)=0
LET c(6,6)=0
LET c(7,7)=0
LET c(1,2)=20
LET c(2,1)=20
LET c(1,3)=50
LET c(3,1)=50
LET c(2,3)=1
LET c(3,2)=1
LET c(2,4)=6
LET c(4,2)=6
LET c(3,4)=100
LET c(4,3)=100
LET c(3,5)=50
LET c(5,3)=50
LET c(4,5)=8
LET c(5,4)=8
LET c(4,7)=20
LET c(7,4)=20
LET c(5,7)=30
LET c(7,5)=30
LET c(5,6)=40
LET c(6,5)=40
LET c(6,7)=80
LET c(7,6)=80
REM-----------------------------------------------------------------
FOR t=1 TO 6
FOR i=1 TO 7
IF dist(i)>dist(t)+c(t,i) THEN
LET dist(i)=dist(t)+c(t,i)
LET path$(i)=path$(t)&node$(MAX(t,i))
END IF
NEXT i
NEXT t
REM ------------------------------
FOR x=1 TO 7
PRINT "最短距離="; dist(x); ", 経路=";path$(x)
NEXT x
LET n=7
DIM dist(n), node$(n),path$(n)
MAT READ node$
DATA A,B,C,D,E,F,G
MAT path$=node$(1)&NUL$
DIM c(n,n)
MAT c=1000*CON
MAT dist=1000*CON
LET dist(1)=0
LET c(1,2)=20
LET c(1,3)=50
LET c(2,3)=150 ! c(2,3)=1
LET c(2,4)=6
LET c(4,3)=3 ! c(3,4)=100
LET c(3,5)=4 ! c(3,5)=50
LET c(4,5)=8
LET c(4,7)=20
LET c(5,7)=30
LET c(5,6)=40
LET c(6,7)=80
REM-----------------------------------------------------------------
FOR t=1 TO n-1
FOR i=1 TO n
IF dist(i)>dist(t)+c(t,i) THEN
LET dist(i)=dist(t)+c(t,i)
LET path$(i)=path$(t)&node$(i)
END IF
NEXT i
NEXT t
FOR t=1 TO n-1
FOR i=n TO 1 STEP -1
IF dist(i)>dist(t)+c(t,i) THEN
LET dist(i)=dist(t)+c(t,i)
LET path$(i)=path$(t)&node$(i)
END IF
NEXT i
NEXT t
REM ------------------------------
FOR x=1 TO n
PRINT "最短距離="; dist(x); ", 経路=";path$(x)
NEXT x
nagram様よりご提示いただきましたプログラムをヒントにdo while loopを加えてみました。
隣接行列の値も変えています。これでちゃんとできているみたいですが。
DIM dist(7), node$(7),path$(7)
MAT READ node$
DATA A,B,C,D,E,F,G
MAT path$=node$(1)&NUL$
DIM c(7,7)
MAT c=1000*CON
LET inf=1000
LET dist(1)=0
LET dist(2)=inf
LET dist(3)=inf
LET dist(4)=inf
LET dist(5)=inf
LET dist(6)=inf
LET dist(7)=inf
LET c(1,1)=0
LET c(2,2)=0
LET c(3,3)=0
LET c(4,4)=0
LET c(5,5)=0
LET c(6,6)=0
LET c(7,7)=0
LET c(1,2)=30
LET c(2,1)=30
LET c(1,3)=20
LET c(3,1)=20
LET c(1,7)=1
LET c(7,1)=1
LET c(2,3)=2
LET c(3,2)=2
LET c(2,4)=6
LET c(4,2)=6
LET c(2,5)=1
LET c(5,2)=1
LET c(2,7)=6
LET c(7,2)=6
LET c(3,4)=2
LET c(4,3)=2
LET c(3,5)=3
LET c(5,3)=3
LET c(3,6)=1
LET c(6,3)=1
LET c(4,5)=20
LET c(5,4)=20
LET c(4,6)=30
LET c(6,4)=30
LET c(4,7)=100
LET c(7,4)=100
LET c(5,7)=2
LET c(7,5)=2
LET c(5,6)=5
LET c(6,5)=5
LET c(6,7)=10
LET c(7,6)=10
REM-----------------------------------------------------------------
LET w=0
DO WHILE w<=7
FOR t=1 TO 7
FOR i=1 TO 7
IF dist(i)>dist(t)+c(t,i) THEN
LET dist(i)=dist(t)+c(t,i)
LET path$(i)=path$(t)&node$(i)
END IF
NEXT i
NEXT t
LET w=w+1
LOOP
REM-----------------------------------
PRINT "-------------------------------------------------------"
FOR x=1 TO 7
PRINT "最短距離="; dist(x); ", 経路=";path$(x)
NEXT x
PUBLIC NUMERIC A(20,20),DISTANCE(20),VISITED(20),INDEX(100),SIZE,INF,TRUE,FALSE,START
PUBLIC NUMERIC MININDEX(100),MINDISTANCE,MAXINDEX(100),MAXDISTANCE
PUBLIC STRING NODE$(26)
MAT READ NODE$
DATA A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z
LET INF=100000000
LET MINDISTANCE=INF
LET MAXDISTANCE=-INF
LET TRUE=1
LET FALSE=0
RESTORE 10
READ SIZE
FOR I=1 TO SIZE ! 隣接行列読み込み
FOR J=1 TO SIZE
READ S$
IF S$="INF" THEN
LET A(I,J)=INF
ELSE
LET A(I,J)=VAL(S$)
END IF
NEXT J
NEXT I
LET START=8
LET GOAL=2
IF START<1 OR GOAL<1 OR START>SIZE OR GOAL>SIZE OR START=GOAL THEN
PRINT "ERROR !!"
STOP
END IF
CALL VISIT(START,GOAL)
PRINT REPEAT$("-",60)
LET K=START
DO
PRINT NODE$(K);" → ";
LET K=MININDEX(K)
LOOP UNTIL K=GOAL
PRINT NODE$(GOAL);" MIN DISTANCE";MINDISTANCE
!LET K=START
!DO
! PRINT NODE$(K);" → ";
! LET K=MAXINDEX(K)
!LOOP UNTIL K=GOAL
!PRINT NODE$(GOAL);" MAX DISTANCE";MAXDISTANCE
10 DATA 10 ! 有向グラフ
DATA INF, 1, 4,INF, 5,INF, 2,INF, 2,INF
DATA INF,INF, 3,INF,INF, 4,INF,INF,INF,INF
DATA 3,INF,INF, 2,INF,INF, 1,INF,INF, 1
DATA INF,INF, 2,INF,INF,INF,INF, 3,INF,INF
DATA INF, 2,INF,INF,INF, 2,INF,INF,INF, 1
DATA 1,INF, 4,INF, 1,INF, 5,INF,INF,INF
DATA INF, 3,INF,INF,INF, 6,INF, 5,INF,INF
DATA 1,INF,INF, 3,INF,INF,INF,INF, 5,INF
DATA INF, 2,INF, 5,INF, 2,INF, 3,INF, 2
DATA 1,INF, 4, 3,INF,INF, 5,INF,INF,INF
20 DATA 8 ! 無向グラフ(対角成分に対して対称。A(I,J)とA(J,I)が同値)
DATA INF, 1, 1,INF,INF,INF, 1, 1
DATA 1,INF, 1,INF, 1,INF,INF,INF
DATA 1, 1,INF, 1,INF, 1, 1,INF
DATA INF,INF, 1,INF, 1,INF, 1, 1
DATA INF, 1,INF, 1,INF, 1,INF,INF
DATA INF,INF, 1,INF, 1,INF, 1,INF
DATA 1,INF, 1, 1,INF, 1,INF, 1
DATA 1,INF,INF, 1,INF,INF, 1,INF
30 DATA 10 ! 有向グラフ
DATA INF, 2,INF, 1,INF, 4, 6,INF, 7,INF
DATA INF,INF,INF, -2, 1,INF,INF, 2,INF, 1
DATA -3,INF,INF,INF, 1,INF, -1,INF, 2,INF
DATA INF, 2,INF,INF,INF,INF, 1,INF,INF, 3
DATA INF,INF, -1,INF,INF, 2,INF, 3, 4,INF
DATA 4,INF,INF,INF, 2,INF,INF, 1,INF, 5
DATA INF, 1,INF, 2,INF, 1,INF, 5,INF,INF
DATA 2,INF,INF, 4,INF, 3,INF,INF, 2, 4
DATA INF,INF, 4,INF, 4,INF, -2,INF,INF,INF
DATA 1,INF, 3,INF, 6,INF, 1,INF,INF,INF
END
EXTERNAL SUB VISIT(I,GOAL)
IF I=GOAL THEN
LET K=START
DO
PRINT NODE$(K);" → ";
LET K=INDEX(K)
LOOP UNTIL K=GOAL
PRINT NODE$(GOAL);" DISTANCE";DISTANCE(GOAL)
IF MINDISTANCE>DISTANCE(GOAL) THEN
MAT MININDEX=INDEX
LET MINDISTANCE=DISTANCE(GOAL)
END IF
! IF MAXDISTANCE<DISTANCE(GOAL) THEN
! MAT MAXINDEX=INDEX
! LET MAXDISTANCE=DISTANCE(GOAL)
! END IF
ELSE
!IF MINDISTANCE>DISTANCE(I) THEN
FOR J=1 TO SIZE
IF I<>J AND A(I,J)<>INF AND VISITED(J)=FALSE THEN
LET VISITED(I)=TRUE
LET DISTANCE(J)=DISTANCE(I)+A(I,J)
LET INDEX(I)=J
CALL VISIT(J,GOAL)
LET VISITED(I)=FALSE
LET INDEX(I)=0
LET DISTANCE(J)=0
END IF
NEXT J
!END IF
END IF
END SUB
DIM NODE$(26)
MAT READ NODE$
DATA A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z
RESTORE 10
READ SIZE
DIM VISITED(SIZE),DISTANCE(SIZE),INDEX(SIZE),A(SIZE,SIZE)
LET TRUE=1
LET FALSE=0
LET INF=100000000
MAT DISTANCE=(INF)*CON
FOR I=1 TO SIZE
FOR J=1 TO SIZE
READ S$
IF S$<>"INF" THEN LET A(I,J)=VAL(S$) ELSE LET A(I,J)=INF
NEXT J
NEXT I
LET START=3
LET DISTANCE(START)=0
LET NEXTINDEX=START
DO
LET I=NEXTINDEX
LET VISITED(I)=TRUE
LET LMIN=INF
FOR J=1 TO SIZE
IF VISITED(J)=FALSE THEN
IF A(I,J)<>INF AND DISTANCE(J)>DISTANCE(I)+A(I,J) THEN
LET DISTANCE(J)=DISTANCE(I)+A(I,J)
LET INDEX(J)=I
END IF
IF DISTANCE(J)<LMIN THEN
LET LMIN=DISTANCE(J)
LET NEXTINDEX=J
END IF
END IF
NEXT J
LOOP WHILE LMIN<INF
FOR I=1 TO SIZE
IF I<>START AND VISITED(I)=TRUE THEN
LET K=I
PRINT NODE$(K);
DO
LET K=INDEX(K)
PRINT " ← ";NODE$(K);
LOOP UNTIL K=START
PRINT " DISTANCE";DISTANCE(I)
END IF
NEXT I
10 DATA 10 ! 有向グラフ
DATA INF, 1, 4,INF, 5,INF, 2,INF, 2,INF
DATA INF,INF, 3,INF,INF, 4,INF,INF,INF,INF
DATA 3,INF,INF, 2,INF,INF, 1,INF,INF, 1
DATA INF,INF, 2,INF,INF,INF,INF, 3,INF,INF
DATA INF, 2,INF,INF,INF, 2,INF,INF,INF, 1
DATA 1,INF, 4,INF, 1,INF, 5,INF,INF,INF
DATA INF, 3,INF,INF,INF, 6,INF, 5,INF,INF
DATA 1,INF,INF, 3,INF,INF,INF,INF, 5,INF
DATA INF, 2,INF, 5,INF, 2,INF, 3,INF, 2
DATA 1,INF, 4, 3,INF,INF, 5,INF,INF,INF
20 DATA 8 ! 無向グラフ(対角成分に対して対称。A(I,J)とA(J,I)が同値)
DATA INF, 1, 1,INF,INF,INF, 1, 1
DATA 1,INF, 1,INF, 1,INF,INF,INF
DATA 1, 1,INF, 1,INF, 1, 1,INF
DATA INF,INF, 1,INF, 1,INF, 1, 1
DATA INF, 1,INF, 1,INF, 1,INF,INF
DATA INF,INF, 1,INF, 1,INF, 1,INF
DATA 1,INF, 1, 1,INF, 1,INF, 1
DATA 1,INF,INF, 1,INF,INF, 1,INF
30 DATA 10 ! 有向グラフ
DATA INF, 2,INF, 1,INF, 4, 6,INF, 7,INF
DATA INF,INF,INF, -2, 1,INF,INF, 2,INF, 1
DATA -3,INF,INF,INF, 1,INF, -1,INF, 2,INF
DATA INF, 2,INF,INF,INF,INF, 1,INF,INF, 3
DATA INF,INF, -1,INF,INF, 2,INF, 3, 4,INF
DATA 4,INF,INF,INF, 2,INF,INF, 1,INF, 5
DATA INF, 1,INF, 2,INF, 1,INF, 5,INF,INF
DATA 2,INF,INF, 4,INF, 3,INF,INF, 2, 4
DATA INF,INF, 4,INF, 4,INF, -2,INF,INF,INF
DATA 1,INF, 3,INF, 6,INF, 1,INF,INF,INF
40 DATA 7
DATA INF, 1,INF, 3,INF, 5,INF
DATA 2,INF, 3,INF,INF,INF, 2
DATA INF, 2,INF, 2, 4,INF,INF
DATA INF,INF, 4,INF,INF,INF, 5
DATA 3,INF, 3, 3,INF, 2,INF
DATA INF, 1,INF, 4, 2,INF,INF
DATA 5,INF, 2,INF, 3, 6,INF
END
DIM NODE$(26)
MAT READ NODE$
DATA A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z
LET F$="D:\tool\Graphviz\bin\sample" !ドライブ、パスを指定してください。(ファイル名はsample.dotになります)
LET FORMAT$="png" ! jpg gif svg ps pdf...
OPEN #1:NAME F$&".dot"
ERASE #1
PRINT #1:"digraph sample {"
!!PRINT #1:" graph[rankdir=LR];" ! TB BT LR RL
!!PRINT #1:" node [shape=box];" ! box polygon ellipse circle point egg triangle diamond trapezium parallellogram house pentagon hexagon doublecircle...
RESTORE 10
READ SIZE
FOR J=1 TO SIZE
FOR I=1 TO SIZE
READ S$
IF S$<>"INF" THEN
PRINT #1:" ";NODE$(J);" -> ";NODE$(I);" [fontcolor=red label=";CHR$(34);S$;CHR$(34);"];"
END IF
NEXT I
NEXT J
PRINT #1:"}"
CLOSE #1
!!EXECUTE "D:\tool\Graphviz\bin\dot.exe" WITH(F$&".dot","-T"&FORMAT$,"-o",F$&"."&FORMAT$)
!!GLOAD F$&"."&FORMAT$
10 DATA 10 ! 有向グラフ
DATA INF, 1, 4,INF, 5,INF, 2,INF, 2,INF
DATA INF,INF, 3,INF,INF, 4,INF,INF,INF,INF
DATA 3,INF,INF, 2,INF,INF, 1,INF,INF, 1
DATA INF,INF, 2,INF,INF,INF,INF, 3,INF,INF
DATA INF, 2,INF,INF,INF, 2,INF,INF,INF, 1
DATA 1,INF, 4,INF, 1,INF, 5,INF,INF,INF
DATA INF, 3,INF,INF,INF, 6,INF, 5,INF,INF
DATA 1,INF,INF, 3,INF,INF,INF,INF, 5,INF
DATA INF, 2,INF, 5,INF, 2,INF, 3,INF, 2
DATA 1,INF, 4, 3,INF,INF, 5,INF,INF,INF
20 DATA 8 ! 無向グラフ(対角成分に対して対称。A(I,J)とA(J,I)が同値)
DATA INF, 1, 1,INF,INF,INF, 1, 1
DATA 1,INF, 1,INF, 1,INF,INF,INF
DATA 1, 1,INF, 1,INF, 1, 1,INF
DATA INF,INF, 1,INF, 1,INF, 1, 1
DATA INF, 1,INF, 1,INF, 1,INF,INF
DATA INF,INF, 1,INF, 1,INF, 1,INF
DATA 1,INF, 1, 1,INF, 1,INF, 1
DATA 1,INF,INF, 1,INF,INF, 1,INF
30 DATA 10 ! 有向グラフ
DATA INF, 2,INF, 1,INF, 4, 6,INF, 7,INF
DATA INF,INF,INF, -2, 1,INF,INF, 2,INF, 1
DATA -3,INF,INF,INF, 1,INF, -1,INF, 2,INF
DATA INF, 2,INF,INF,INF,INF, 1,INF,INF, 3
DATA INF,INF, -1,INF,INF, 2,INF, 3, 4,INF
DATA 4,INF,INF,INF, 2,INF,INF, 1,INF, 5
DATA INF, 1,INF, 2,INF, 1,INF, 5,INF,INF
DATA 2,INF,INF, 4,INF, 3,INF,INF, 2, 4
DATA INF,INF, 4,INF, 4,INF, -2,INF,INF,INF
DATA 1,INF, 3,INF, 6,INF, 1,INF,INF,INF
END
今年もあとわずかなので、日付時刻に関するプログラムです。
日付や時刻の表記法は様々な様式がありますが、ISO 8601 (日本では JIS X 0301) で規格化されています。
規格に沿った日付時刻を表示する関数を作りました。
皆さま、良いお年をお迎えください。
DECLARE EXTERNAL FUNCTION datetime1$, datetimesec1$, datetime2$, datetimesec2$
!
PRINT "基本形式"
PRINT datetime1$ ! "YYYYMMDDThhmmss+0900"
PRINT datetimesec1$ ! "YYYYMMDDThhmmss.ss+0900"
PRINT "拡張形式"
PRINT datetime2$ ! "YYYY-MM-DDThh:mm:ss+09:00"
PRINT datetimesec2$ ! "YYYY-MM-DDThh:mm:ss.ss+09:00"
END
!
EXTERNAL FUNCTION datetime1$ ! 日付時刻国際標準表記(基本形式)
LET d0$=DATE$
LET t$=TIME$
LET d$=DATE$
IF d$<>d0$ THEN LET t$="00:00:00" ! 日付更新考慮
LET datetime1$=d$&"T"&t$(1:2)&t$(4:5)&t$(7:8)&"+0900"
END FUNCTION
!
EXTERNAL FUNCTION datetimesec1$ ! 日付時刻国際標準表記(基本形式,小数秒)
LET t0=TIME
LET d$=DATE$
LET t=TIME
IF t<t0 THEN LET d$=DATE$ ! 日付更新考慮
LET h=INT(t/3600)
LET hm$=RIGHT$("0"&STR$(h),2)&RIGHT$("0"&STR$(INT((t-3600*h)/60)),2)
LET t$=USING$("%%.##",MOD(t,60))
! LET t1=MOD(t,60) ! 秒の小数部末尾の"0"を記述しない
! IF t1>=10 THEN LET t$=STR$(t1) ELSE LET t$="0"&STR$(t1)
! IF t1<1 THEN LET t$="0"&t$
LET datetimesec1$=d$&"T"&hm$&t$&"+0900"
END FUNCTION
!
EXTERNAL FUNCTION datetime2$ ! 日付時刻国際標準表記(拡張形式)
LET d0$=DATE$
LET t$=TIME$
LET d$=DATE$
IF d$<>d0$ THEN LET t$="00:00:00" ! 日付更新考慮
LET datetime2$=d$(1:4)&"-"&d$(5:6)&"-"&d$(7:8)&"T"&t$&"+09:00"
END FUNCTION
!
EXTERNAL FUNCTION datetimesec2$ ! 日付時刻国際標準表記(拡張形式,小数秒)
LET t0=TIME
LET d$=DATE$
LET t=TIME
IF t<t0 THEN LET d$=DATE$ ! 日付更新考慮
LET h=INT(t/3600)
LET hm$=RIGHT$("0"&STR$(h),2)&":"&RIGHT$("0"&STR$(INT((t-3600*h)/60)),2)
LET t$=USING$("%%.##",MOD(t,60))
! LET t1=MOD(t,60) ! 秒の小数部末尾の"0"を記述しない
! IF t1>=10 THEN LET t$=STR$(t1) ELSE LET t$="0"&STR$(t1)
! IF t1<1 THEN LET t$="0"&t$
LET datetimesec2$=d$(1:4)&"-"&d$(5:6)&"-"&d$(7:8)&"T"&hm$&":"&t$&"+09:00"
END FUNCTION
