teacup. [ 掲示板 ] [ 掲示板作成 ] [ 有料掲示板 ] [ ブログ ]

 <思いやりのあるコミュニティ宣言>
 teacup.掲示板は、皆様の権利を守りながら、思いやり、温かみのあるコミュニティづくりを応援します。
 いつもご協力いただきありがとうございます。

 投稿者
  題名
  内容 入力補助画像・ファイル<IMG>タグが利用可能です。(詳細)
    
 URL
[ ケータイで使う ] [ BBSティッカー ] [ 書込み通知 ] [ 検索 ]

スレッド一覧

  1. スレッドが使えます(2)
  2. Chromebook(2)
  3. 人の色覚の数理(14)
  4. Apple Silicon (M1プロセッサ)での動作(7)
  5. Full BASIC互換ライブラリ(7)
  6. Paract BASIC(22)
  7. Amusement_Program(10)
  8. 改修予定のJIS非互換(3)
  9. 複数ページ長編プログラム(新規投稿)(16)
  10. 「十進BASIC第2掲示板」投稿記事リスト(17)
  11. 「十進BASIC掲示板過去ログ」インデックス(トピック)(17)
  12. 「十進BASIC掲示板過去ログ」インデックス(ツリー)(91)
スレッド一覧(全12)  他のスレッドを探す  スレッド作成

*掲示板をお持ちでない方へ、まずは掲示板を作成しましょう。無料掲示板作成


mod(6n+3,3)=0, 6n-1,6n+1以外から素数は出ません。

 投稿者:たろさ  投稿日:2021年 9月15日(水)18時53分24秒
返信・引用
  ! 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

PRINT c
LET TM=TIME-t0
PRINT TM;"秒"

END

計算結果

2
3
99999043
99999073
99999077
99999079
99999089
99999103
99999113
99999131
99999157
99999167
99999187
99999217
途中省略
99999931
99999941
99999959
99999971
99999989
5761455
4.438000000009 秒
BASIC Accelerator Ver. 1.2.0.5 (2020.03.31)

mod(6n+3,3)=0 は正しいと思うので
6n-1,6n+1 以外から素数は出ません。
 
 

Re: Lazarus fpc-3.2.2-win64 計算時間が短縮

 投稿者:たろさ  投稿日:2021年 9月15日(水)18時36分16秒
返信・引用
  > No.4956[元記事へ]

SHIRAISHI Kazuoさんへのお返事です。

> 並行単位(paract~end paract)の個数は,CPUのスレッド数-2 程度を目安にしてみてください。
>
> >
> > 問題点
> >
> > 自作パソコンのCPUのスレッドが16あるので
> >
> > 16スレッド お願いいたします。
> >
> > 知識不足のため 16スレッド失敗してます。


了解しました。
 

Re: Lazarus fpc-3.2.2-win64 計算時間が短縮

 投稿者:SHIRAISHI Kazuo  投稿日:2021年 9月15日(水)08時25分5秒
返信・引用 編集済
  > No.4955[元記事へ]

並行単位(paract~end paract)の個数は,CPUのスレッド数-2 程度を目安にしてみてください。

>
> 問題点
>
> 自作パソコンのCPUのスレッドが16あるので
>
> 16スレッド お願いいたします。
>
> 知識不足のため 16スレッド失敗してます。

http://hp.vector.co.jp/authors/VA008683/

 

Lazarus fpc-3.2.2-win64 計算時間が短縮

 投稿者:たろさ  投稿日:2021年 9月13日(月)20時59分32秒
返信・引用
  動作報告です。

動作環境
Intel Core i7 -8565U    mouse m-Book MB-R500 ノート PC
Intel COre i7 -10700K   自作パソコン
Intel Core i9 -11900KF 自作パソコン

Windows Version
Microsoft Windows 10 (10.0) Professional 64-bit

Paract BASIC Ver. 2.1.2.4 Rev.2   (2021.06.19)

Lazarus fpc-3.2.2-win64
lazarus-2.2.0RC1-fpc-3.2.2-win64.exe               2021-07-08 199.7 MB
lazarus-2.2.0RC1-fpc-3.2.2-cross-i386-win32-win64.exe 2021-07-08  55.1 MB


Paract BASIC プログラム  6n+k篩  素数の個数を数えるプログラム

!最新6n+k篩  8スレッド     2021/08/12
!
!https://6317.teacup.com/basic/bbs/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


計算結果
4660000  14232238570791  2962547    平均計算時間0.342475秒
4680000  14291449873702  2960711

6849.50秒  1時間54分09.5秒 1兆間の計算時間 57分04.75秒
20210913  16:59:47
20210913  18:53:57


Lazarus fpc-3.2.2-win64 計算時間が短縮

難点

表示される数値が?
https://6317.teacup.com/basic/bbs/4926

対策 win32-win64を切り替えて使用している。

問題点

自作パソコンのCPUのスレッドが16あるので

16スレッド お願いいたします。

知識不足のため 16スレッド失敗してます。
 

Re: nagramさんへ

 投稿者:RCカー  投稿日:2021年 8月16日(月)17時35分13秒
返信・引用
  nagramさんへのお返事です。

> RCカーさんへのお返事です。
>
> > ありがとうございます。
> >
> > 訂正させていただきました。
> >
> > 確認お願いします。
>
> はい、これで大丈夫だと思います。

nagramさんへ、ありがとう。
嬉しいです。
 

Re: nagramさんへ

 投稿者:nagram  投稿日:2021年 8月16日(月)17時33分22秒
返信・引用
  > No.4951[元記事へ]

RCカーさんへのお返事です。

> ありがとうございます。
>
> 訂正させていただきました。
>
> 確認お願いします。

はい、これで大丈夫だと思います。
 

nagramさんへ

 投稿者:RCカー  投稿日:2021年 8月15日(日)20時26分50秒
返信・引用
  ありがとうございます。

訂正させていただきました。

確認お願いします。



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
 

Re: 電話帳プログラム作成プロセスと、プログラムの例

 投稿者:nagram  投稿日:2021年 8月15日(日)18時29分40秒
返信・引用
  > No.4949[元記事へ]

RCカーさんへのお返事です。

不具合を発見したので修正をお願いします。
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
---------------------------------------------------------------------------------
 

Re: 電話帳プログラム作成プロセスと、プログラムの例

 投稿者:RCカー  投稿日:2021年 8月13日(金)19時39分34秒
返信・引用
  > No.4948[元記事へ]

nagramさんへのお返事です。

早速の御返信ありがとうございます。
 

Re: 電話帳プログラム作成プロセスと、プログラムの例

 投稿者:nagram  投稿日:2021年 8月13日(金)19時31分45秒
返信・引用
  RCカーさんへのお返事です。

>   まだ、シンタックスエラーがでて、

→ 前回の投稿で改善したのはメインメニューの部分だけなので、他の部分での数値変数のinput文ではエラーになります。


>   また、終了しますか  いいえ  で、終了してしまいます。

→ マウスの左ボタンや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
 

Re: 電話帳プログラム作成プロセスと、プログラムの例

 投稿者:RCカー  投稿日:2021年 8月13日(金)11時49分56秒
返信・引用
  > No.4944[元記事へ]

nagramさんへのお返事です。

  まだ、シンタックスエラーがでて、
  また、終了しますか  いいえ  で、終了してしまいます。

> 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
> --------------------------------------------------------------------------
 

Re: 電話帳プログラム作成プロセスと、プログラムの例

 投稿者:RCカー  投稿日:2021年 8月13日(金)11時47分9秒
返信・引用
  > No.4944[元記事へ]

nagramさんへのお返事です。

以下、変更点を、編集したプログラムです。間違っていたら教えて下さい。
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
> --------------------------------------------------------------------------
 

Re: 電話帳プログラム作成プロセスと、プログラムの例

 投稿者:RCカー  投稿日:2021年 8月13日(金)09時21分51秒
返信・引用
  > No.4944[元記事へ]

nagramさんへのお返事です。

まだシンタックスエラーが出ます。
 

Re: 電話帳プログラム作成プロセスと、プログラムの例

 投稿者:nagram  投稿日:2021年 8月12日(木)19時47分38秒
返信・引用
  > No.4943[元記事へ]

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
--------------------------------------------------------------------------
 

Re: 電話帳プログラム作成プロセスと、プログラムの例

 投稿者:RCカー  投稿日:2021年 8月12日(木)11時52分19秒
返信・引用
  RCカーさんへのお返事です。
 データ入力ダイアログで、数字を、入れずに、OKを、クリックしたとき、シンタックスエラーが出ます。input文に、イレギュラーな、場合にどうするかを、しょりほうほうを、プログラムで、決めないと、駄目なのかな?、教えて下さい。
待ってます。

> 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
 

Re: 電話帳プログラム作成プロセスと、プログラムの例

 投稿者:RCカー  投稿日:2021年 8月12日(木)09時50分10秒
返信・引用
  > No.4940[元記事へ]

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
 

Re: 電話帳プログラム作成プロセスと、プログラムの例

 投稿者:RCカー  投稿日:2021年 8月11日(水)19時25分41秒
返信・引用
  > No.4940[元記事へ]

nagramさんへのお返事です。

RCカーより、ありがとうございました。

> 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
 

Re: 電話帳プログラム作成プロセスと、プログラムの例

 投稿者:nagram  投稿日:2021年 8月11日(水)18時28分29秒
返信・引用
  > No.4933[元記事へ]

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カー  投稿日:2021年 8月11日(水)14時45分17秒
返信・引用
  早速の返信ありがとうございました。
ためになるリンクだと思います。
ただ僕には、まだ早いようです。
 

Re: 御助言お願いします

 投稿者:SHIRAISHI Kazuo  投稿日:2021年 8月11日(水)14時14分34秒
返信・引用 編集済
  > No.4937[元記事へ]

RCカーさんへのお返事です。
十進BASIC FAQ
https://hp.vector.co.jp/authors/VA008683/SpreadSheet.htm
を参考にしてください。
また,十進BASIC独自拡張のRECTYPE CSVも有用です。
https://decimalbasic.ninja-web.net/BASICHelp/html/basi7cis.htm
CSVファイル全体を一回のMAT READ文,MAT RIGHT文で読み書きできます。

> SHIRAISHI Kazuoさんへのお返事です。
>
> > RCカーさんへのお返事です。
> >
> > 何を助言したらいいのかわからないのですが,
> > データを扱うのが目的であれば,
> > 入力や保管はEXCELにまかせて,
> > EXCELだと難しい処理が必要になったとき,
> > データをCSV形式で書き出して,
> > BASICに読み込んで処理するのが合理的です。
> >
> 早速の御返信ありがとう御座います。
>  ちなみに、エクセルだとどうなりますか?
>
 

レンタル掲示板
/177