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

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

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

スレッド一覧

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

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


Re: SET BITMAP SIZE文でエラー

 投稿者:島村1243  投稿日:2020年10月20日(火)18時17分4秒
返信・引用
  > No.4883[元記事へ]

> SHIRAISHI Kazuoさんへのご連絡です。
>
> > ご報告ありがとうございました。
> > 通常の例外状態処理が効かないようです。
> > 仕方ないので,1以下の値を指定されたときはWin32 APIが呼ばれないようにします。
> >
> 十進BASIC Linux32ビット版-version8.1.0.6を
> xubuntu-16.04で使っています。
> しばっちさんが「Windows版でエラー」の書き込みが有りましたので
> Linux版で同様の操作をしてみましたら
>
> SET BITMAP SIZE 0,0
> PRINT "abcd"
> END
> では問題ありませんが
> 以下省略

しばっちさんの問題提起に対してWindows版については白石先生から素早い回答が有った後直ぐに、「Windows版の新version」が出たので、対策を施した新versionと思ってしまいました。
しかし、Linux版の新versionは出なかったので、もしかしたら気が付いておられないのかも知れないと、浅はかな考えで投稿してしまいました。
的外れな投稿になった様で大変失礼致しました。
投稿No.4883は削除をお願い致します。
 
 

Re: SET BITMAP SIZE文でエラー

 投稿者:しばっち  投稿日:2020年10月18日(日)18時43分23秒
返信・引用 編集済
  > No.4883[元記事へ]

> 十進BASIC Linux32ビット版-version8.1.0.6を
> xubuntu-16.04で使っています。
> しばっちさんが「Windows版でエラー」の書き込みが有りましたので
> Linux版で同様の操作をしてみましたら
>
> SET BITMAP SIZE 0,0
> PRINT "abcd"
> END
> では問題ありませんが
>
> SET BITMAP SIZE 1,1
> PRINT "abcd"
> END
>
> これを実行するとエラーダイアログ
> Invalid floating point operation OK
> が出ました。
>
> 次に下記のように直して
> PRINT "abcd"
> END
>
> 再度実行するとエラーダイアログ
> Internal Error on Compiling Access violation
> Mail
> versin number and current program to kazuo.shiraishi@nifty.com
> が出ました。
>
> 以上報告です。
>

白石先生はもうお気づきかと思いますが SET BITMAP SIZE 1,1では
ウィンドゥ(SET WINDOW)が設定できないことが起因で至極当然の
エラーだと思われます。画像サイズを1ドットとすることに意味はない
と思われます。
 

Re: SET BITMAP SIZE文でエラー

 投稿者:島村1243  投稿日:2020年10月18日(日)12時59分17秒
返信・引用
  > No.4879[元記事へ]

SHIRAISHI Kazuoさんへのご連絡です。

> ご報告ありがとうございました。
> 通常の例外状態処理が効かないようです。
> 仕方ないので,1以下の値を指定されたときはWin32 APIが呼ばれないようにします。
>

十進BASIC Linux32ビット版-version8.1.0.6を
xubuntu-16.04で使っています。
しばっちさんが「Windows版でエラー」の書き込みが有りましたので
Linux版で同様の操作をしてみましたら

SET BITMAP SIZE 0,0
PRINT "abcd"
END
では問題ありませんが

SET BITMAP SIZE 1,1
PRINT "abcd"
END

これを実行するとエラーダイアログ
Invalid floating point operation OK
が出ました。

次に下記のように直して
PRINT "abcd"
END

再度実行するとエラーダイアログ
Internal Error on Compiling Access violation
Mail
versin number and current program to kazuo.shiraishi@nifty.com
が出ました。

以上報告です。

 

神経衰弱ゲーム

 投稿者:しばっち  投稿日:2020年10月18日(日)09時40分6秒
返信・引用
  これは1人用(1人プレイ)の神経衰弱です。脳トレに利用できます。(笑)

52枚のカードを同時に表示させるためグラフィック画面が1300*600と大きくなっています。
解像度がこれより低いモニタでは使いづらいかもしれません。


カードを選び左クリックするとカードをめくります。
2枚めくり数字が同じならそのままで、違うなら元に戻ります。
全部めくるとゲームクリアになります。
右クリックするとヒントとしてカードを表示します(2秒間 3回まで)
(サンプル画像 1段目)


1人用なので3分間で何枚取れるか等でも楽しめるかもしれません。
また、多人数でもプレイできるように等改造するのもいいかもしれません。
整然と並べているのでバラバラに配置するようにしてもいいかもしれません。


ちなみにスペースキー、リターンキーで実行終了(ギブアップ)します。(イラッときたら押下しましょう!)
または十進BASICアイコンの「中断」をクリックして「中止」を選ぶと終了できます。(笑)


なお、このプログラムの実行には画像サンプルにあるようなカード画像(74*110)が別途必要です。(サンプル画像 2段目)
下記からダウンロードしてください。(data.zip 4.86MB)


https://23.gigafile.nu/1217-c1787339e69ef44cb3f89a20ddef71091

ダウンロードパスワード:設定していません
ダウンロード期限:2020年12月17日(木)


画像は画像検索で適当に見つけてダウンロードしたのでもうURLは分かりません。
画像ファイルがない場合は適当に検索して入手したものを利用してください。
カードの画像サイズは 74*110 ですが、プログラムを修正するなり画像を拡大縮小すれば実行可能だと思います。

ビジュアル(見た目)にこだわらないならこの下にある画像データ生成プログラムで生成できます。
(サンプル画像 3段目)

また、トランプのイラストフォントというのもあるようです。(PLOT TEXT文に置き換えるか(改造するか)、画像データ(74*110)を作成してください)
https://www.dafont.com/playing-cards.font


RANDOMIZE
OPTION ANGLE DEGREES
LET WIDTH=74 !'カードサイズ設定
LET HEIGHT=110
DIM S(52,0 TO WIDTH-1,0 TO HEIGHT-1),M(0 TO WIDTH-1,0 TO HEIGHT-1),OMOTE(0 TO WIDTH-1,0 TO HEIGHT-1)
DIM XS(52),YS(52),P(52)
LET PATH$=".\data\" !'カード画像があるパス
SET DRAW MODE HIDDEN
FOR J=1 TO 4
   READ TYPE$
   DATA "heart","diamond","club","spade"
   FOR I=1 TO 13
      CALL PICTURELOAD(PATH$&TYPE$&STR$(I)&".png",XSIZE,YSIZE) !カード画像がない場合別途入手するか、画像生成プログラムで作成してください。
      MAT M=ZER
      ASK PIXEL ARRAY (0,0) M
      LET K=K+1
      FOR Y=0 TO YSIZE-1
         FOR X=0 TO XSIZE-1
            LET S(K,X,Y)=M(X,Y)
         NEXT X
      NEXT Y
   NEXT I
NEXT J
CALL PICTURELOAD(PATH$&"omote.png",XSIZE,YSIZE)
ASK PIXEL ARRAY (0,0) OMOTE
! CALL PICTURELOAD(PATH$&"congratulations.png",XSIZE1,YSIZE1)
! DIM IMAGE(XSIZE1-1,YSIZE1-1),IMAGE_MASK(XSIZE1-1,YSIZE1-1)
! ASK PIXEL ARRAY (0,0) IMAGE
! CALL PICTURELOAD(PATH$&"congratulations_mask.png",XSIZE1,YSIZE1)
! ASK PIXEL ARRAY (0,0) IMAGE_MASK
! CALL PICTURELOAD(PATH$&"game over.png",XSIZE2,YSIZE2)
! DIM IMAGE2(XSIZE2-1,YSIZE2-1),IMAGE2_MASK(XSIZE2-1,YSIZE2-1)
! ASK PIXEL ARRAY (0,0) IMAGE2
! CALL PICTURELOAD(PATH$&"game over_mask.png",XSIZE2,YSIZE2)
! ASK PIXEL ARRAY (0,0) IMAGE2_MASK
CALL GINIT(1300,600) !'グラフィックウィンドゥサイズ
SET DRAW MODE EXPLICIT
LET I=0
FOR Y=0 TO 400 STEP 120 !'カードを並べる
   FOR X=0 TO 1200 STEP 100
      LET I=I+1
      LET XS(I)=X+10
      LET YS(I)=Y+20
      DRAW DISP(WIDTH,HEIGHT,OMOTE) WITH SHIFT(XS(I),YS(I))
      LET P(I)=I
   NEXT X
NEXT Y
FOR I=1 TO 52 !'カードシャッフル
   SWAP P(I),P(INT(RND*52+1))
NEXT I
SET TEXT JUSTIFY "LEFT","TOP"
SET TEXT BACKGROUND "OPAQUE"
SET TEXT HEIGHT 40
LET TI=INT(TIME) !'タイマーセット
LET PP=52 !'カード残数
LET HINT=3 !'ヒント回数
DO
   IF GETKEYSTATE(32)<0 OR GETKEYSTATE(13)<0 THEN !'ギブアップ
      FOR I=1 TO 52
         LET K=P(I)
         IF K>=0 THEN
            FOR Y=0 TO HEIGHT-1
               FOR X=0 TO WIDTH-1
                  LET M(X,Y)=S(K,X,Y)
               NEXT X
            NEXT Y
            DRAW DISP(WIDTH,HEIGHT,M) WITH SHIFT(XS(I),YS(I))
         END IF
      NEXT I
      !! DRAW DISP2(XSIZE2,YSIZE2,IMAGE2,IMAGE2_MASK) WITH SHIFT(180,220)
      SET TEXT HEIGHT 150
      SET TEXT BACKGROUND "TRANSPARENT"
      LET THETA=120
      FOR I=0 TO 25
         SET TEXT COLOR COLORINDEX(I/25,0,1-I/25)
         PLOT TEXT ,AT 180+I*COS(THETA),220-I*SIN(THETA):"Game Over !! "
      NEXT I
      PLAYSOUND PATH$&"game over.wav" ! ファイルがない場合は注釈か削除してください
      STOP
   END IF
   LET T=INT(TIME)-TI
   IF T<0 THEN LET T=T+86400
   SET TEXT COLOR COLORINDEX(0,0,0)
   PLOT TEXT ,AT 1050,520:USING$("%%",MOD(INT(T/3600),24))&":"&USING$("%%",MOD(INT(T/60),60))&":"&USING$("%%",MOD(T,60))
   PLOT TEXT ,AT 10,520:"残 "&USING$("%%",PP)&"枚"
   PLOT TEXT ,AT 220,520:"ヒント "&STR$(HINT)&"回"
   PLOT TEXT ,AT 750,520:"手数 "&STR$(COUNT)&"回"
   MOUSE POLL X,Y,LEFT,RIGHT
   FOR II=1 TO 52
      IF P(II)>=0 THEN
         IF XS(II)<=X AND XS(II)+WIDTH-1>=X AND YS(II)<=Y AND YS(II)+HEIGHT-1>=Y THEN
            CALL BOX(XS(II),YS(II),XS(II)+WIDTH-1,YS(II)+HEIGHT-1,255,0,0)
         ELSE
            CALL BOX(XS(II),YS(II),XS(II)+WIDTH-1,YS(II)+HEIGHT-1,255,255,255)
         END IF
      END IF
   NEXT  II
   IF RIGHT<>0 AND HINT>0 THEN !'右クリックでヒント
      FOR I=1 TO 52
         IF XS(I)<=X AND XS(I)+WIDTH-1>=X AND YS(I)<=Y AND YS(I)+HEIGHT-1>=Y THEN EXIT FOR
      NEXT I
      IF I<=52 THEN
         LET K=P(I)
         IF K>=0 THEN
            FOR Y=0 TO HEIGHT-1
               FOR X=0 TO WIDTH-1
                  LET M(X,Y)=S(K,X,Y)
               NEXT X
            NEXT Y
            DRAW DISP(WIDTH,HEIGHT,M) WITH SHIFT(XS(I),YS(I))
            WAIT DELAY 2   !'2秒間表示したら裏返す
            DRAW DISP(WIDTH,HEIGHT,OMOTE) WITH SHIFT(XS(I),YS(I))
            LET HINT=HINT-1
         END IF
      END IF
   END IF
   IF LEFT<>0 THEN !'左クリック
      FOR I=1 TO 52
         IF XS(I)<=X AND XS(I)+WIDTH-1>=X AND YS(I)<=Y AND YS(I)+HEIGHT-1>=Y THEN EXIT FOR
      NEXT I
      IF I<=52 THEN
         IF F=0 THEN
            LET J=I
            PLAYSOUND PATH$&"turn1.wav" ! ファイルがない場合は注釈か削除してください
         END IF
         LET K=P(I)
         IF K>=0 THEN
            FOR Y=0 TO HEIGHT-1
               FOR X=0 TO WIDTH-1
                  LET M(X,Y)=S(K,X,Y)
               NEXT X
            NEXT Y
            DRAW DISP(WIDTH,HEIGHT,M) WITH SHIFT(XS(I),YS(I))
            IF F=1 THEN
               LET COUNT=COUNT+1 !'カードめくった回数
               IF MOD(P(I),13)=MOD(P(J),13) THEN !'当たりなら
                  PLAYSOUND PATH$&"当たり1.wav" ! ファイルがない場合は注釈か削除してください
                  LET PP=PP-2 !'カード残数
                  LET P(I)=-1
                  LET P(J)=-1
                  IF PP=0 THEN !'残数 0ならクリア
                  !! DRAW DISP2(XSIZE1,YSIZE1,IMAGE,IMAGE_MASK) WITH SHIFT(100,200)
                     SET TEXT BACKGROUND "TRANSPARENT"
                     SET TEXT HEIGHT 100
                     LET THETA=150
                     FOR I=0 TO 25
                        SET TEXT COLOR COLORINDEX(I/25,0,0)
                        PLOT TEXT ,AT 100+I*COS(THETA),240-I*SIN(THETA):"Congratulations !!"
                     NEXT I
                     PLAYSOUND PATH$&"fanfare1.wav" ! ファイルがない場合は注釈か削除してください
                     STOP
                  END IF
               ELSE !'外れならカードを戻す
                  PLAYSOUND PATH$&"外れ1.wav" ! ファイルがない場合はWAIT DELAY 1にしてください
                  DRAW DISP(WIDTH,HEIGHT,OMOTE) WITH SHIFT(XS(I),YS(I))
                  DRAW DISP(WIDTH,HEIGHT,OMOTE) WITH SHIFT(XS(J),YS(J))
               END IF
               !               IF COUNT>0 AND MOD(COUNT,15)=0  THEN !'強制シャッフル。これ以下の注釈を外すと15回カードをめくる毎にカードがシャッフルされます
               !                  SET TEXT COLOR COLORINDEX(1,0,0)
               !                  PLOT TEXT ,AT 500,520:"シャッフルします    "
               !                  FOR I=1 TO 52
               !                     LET L=INT(RND*52+1)
               !                     IF P(I)<>-1 AND P(L)<>-1 THEN SWAP P(I),P(L)
               !                  NEXT I
               !                  WAIT DELAY 1
               !                  PLOT TEXT ,AT 500,520:"        "
               !               END IF
            END IF
         END IF
         LET F=1-F !' クリック1回目ならF=0 クリック2回目ならF=1
         WAIT DELAY .5
      END IF
   END IF
LOOP
END

EXTERNAL  PICTURE DISP(XSIZE,YSIZE,M(,))
MAT PLOT CELLS,IN 0,0;XSIZE-1,YSIZE-1:M
END PICTURE

EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB

EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB

EXTERNAL SUB BOX(XS,YS,XE,YE,R,G,B)
SET COLOR COLORINDEX(R/255,G/255,B/255)
PLOT LINES:XS,YS;XE,YS
PLOT LINES:XE,YS;XE,YE
PLOT LINES:XE,YE;XS,YE
PLOT LINES:XS,YE;XS,YS
END SUB

EXTERNAL  PICTURE DISP2(XX,YY,C(,),M(,))
SET DRAW MODE MASK
MAT PLOT CELLS,IN 0,0;XX-1,YY-1:M
SET DRAW MODE MERGE
MAT PLOT CELLS,IN 0,0;XX-1,YY-1:C
END PICTURE
------------------------------------------------------------------------------------------------------
下記は画像データ生成プログラムです。環境依存文字(unicode)を使用しています。
これはハート、ダイア、スペード、クラブといったマークでこのプログラムはWindows用です。
Mac、Linux環境では適宜修正してください。(ORD関数、CHR$関数で確認してください)
サンプル画像 3段目にあるマークです。

また実行の際にはLazarus版十進BASICが必要です。(シフトJISにはない文字を使用するためです)
BASICAcc,ParactBASICでも実行できるはずです。

神経衰弱にマークは必要ないのでマークの頭文字でいいなら
Lazarus版を使う必要はありません。


LET XSIZE=74 !'カードサイズ設定
LET YSIZE=110
DIM R$(13),RR$(13),T(4),TT$(4)
MAT READ R$,RR$,T,TT$
DATA A,2,3,4,5,6,7,8,9,10,J,Q,K
DATA 1,2,3,4,5,6,7,8,9,10,11,12,13
DATA 9829,9830,9824,9827 !'環境依存文字(unicode)ハート、ダイア、スペード、クラブ
!!DATA 104,100,115,99 !'頭文字 h,d,s,c
DATA heart,diamond,spade,club
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET TEXT JUSTIFY "CENTER","TOP"
SET TEXT BACKGROUND "OPAQUE"
SET TEXT HEIGHT 40
FOR J=1 TO 4
   FOR I=1 TO 13
      CLEAR
      IF J<=2 THEN SET TEXT COLOR 4 ELSE SET TEXT COLOR 1
      PLOT TEXT ,AT XSIZE/2,0:CHR$(T(J))
      SET TEXT COLOR 1
      PLOT TEXT ,AT XSIZE/2,YSIZE/2:R$(I)
      GSAVE TT$(J)&RR$(I)&".png"
   NEXT I
NEXT J
CLEAR
LET C1=0
LET C2=2
LET DOT=8
SET POINT STYLE 1
FOR Y=0 TO YSIZE-1
   FOR X=0 TO XSIZE-1 !'市松模様
      IF MOD(X,2*DOT)<DOT THEN LET C=C1 ELSE LET C=C2
      IF MOD(Y,2*DOT)<DOT THEN LET C=(C1+C2)-C
      SET POINT COLOR C
      PLOT POINTS:X,Y
   NEXT X
NEXT Y
GSAVE "omote.png"
CLEAR
SET TEXT HEIGHT 18
SET TEXT BACKGROUND "TRANSPARENT"
SET TEXT COLOR 1
LET K$="Joker"
FOR I=1 TO LEN(K$)
   PLOT TEXT ,AT (I-1)*XSIZE/LEN(K$)+5,(I-1)*YSIZE/LEN(K$):K$(I:I)
NEXT I
GSAVE "joker1.png" !'ジョーカーは使用していません。
END
 

Re: Lazarus版で画像が乱れる

 投稿者:SHIRAISHI Kazuo  投稿日:2020年10月13日(火)08時13分40秒
返信・引用
  > No.4880[元記事へ]

原因は特定できたので,修正します。

> Lazarus版で下記を実行すると画像が乱れます。
>
>
> SET POINT STYLE 1
> FOR Y=0 TO PIXELY(1)
>    FOR X=0 TO PIXELX(1)
>       SET COLOR MOD(X+Y,3) !乱れる
>       ! SET POINT COLOR MOD(X+Y,3) !正常
>       PLOT POINTS:WORLDX(X),WORLDY(Y)
>    NEXT X
> NEXT Y
> END
>
 

Lazarus版で画像が乱れる

 投稿者:しばっち  投稿日:2020年10月12日(月)20時22分2秒
返信・引用
  Lazarus版で下記を実行すると画像が乱れます。


SET POINT STYLE 1
FOR Y=0 TO PIXELY(1)
   FOR X=0 TO PIXELX(1)
      SET COLOR MOD(X+Y,3) !乱れる
      ! SET POINT COLOR MOD(X+Y,3) !正常
      PLOT POINTS:WORLDX(X),WORLDY(Y)
   NEXT X
NEXT Y
END
 

Re: SET BITMAP SIZE文でエラー

 投稿者:SHIRAISHI Kazuo  投稿日:2020年10月 8日(木)08時06分55秒
返信・引用
  > No.4878[元記事へ]

ご報告ありがとうございました。
通常の例外状態処理が効かないようです。
仕方ないので,1以下の値を指定されたときはWin32 APIが呼ばれないようにします。
 

SET BITMAP SIZE文でエラー

 投稿者:しばっち  投稿日:2020年10月 7日(水)21時05分41秒
返信・引用
  SET BITMAP SIZE 0,0
PRINT "abcd"
END
では問題ありませんが

SET BITMAP SIZE 1,1
PRINT "abcd"
END

これを実行するとEXTYPE 9050とエラーが出ます。


次に下記のように直して

PRINT "abcd"
END

再度実行すると
「不正な浮動小数点演算命令」とダイアログが出ます。

更に再度実行しても同じてす。

十進BASICを終了すると
「動作は停止しました」と出ます。

問題の署名:
  問題イベント名: APPCRASH
  アプリケーション名: BASIC.EXE
  アプリケーションのバージョン: 7.8.5.5
  アプリケーションのタイムスタンプ: 2a425e19
  障害モジュールの名前: BASIC.EXE
  障害モジュールのバージョン: 7.8.5.5
  障害モジュールのタイムスタンプ: 2a425e19
  例外コード: c0000005
  例外オフセット: 00003eaa
  OS バージョン: 6.1.7601.2.1.0.768.3
  ロケール ID: 1041
  追加情報 1: faec
  追加情報 2: faec934158755a89a2cde0d6fc11f542
  追加情報 3: 3a09
  追加情報 4: 3a09d5260c485c5cbad9344579e44a1c

オンラインのプライバシーに関する声明をお読みください:
  http://go.microsoft.com/fwlink/?linkid=104288&clcid=0x0411

オンラインのプライバシーに関する声明が利用できない場合は、プライバシーに関する声明をオフラインでお読みください:
  C:\Windows\system32\ja-JP\erofflps.txt

「プログラムを終了」をクリックすると

Runtime error 216 at 00403EAAとダイアログが出ました。



「プログラムのデバッグ」をクリックすると
「BASIC.EXEでハンドルされていないWin32の例外が発生しました」
とダイアログが出ました。
 

BASファイル化

 投稿者:しばっち  投稿日:2020年10月 3日(土)19時44分1秒
返信・引用 編集済
  前作はBASE16によるものでしたが
今回はBASE64で任意ファイルをBASファイル化します。

https://6317.teacup.com/basic/bbs/1245
https://6317.teacup.com/basic/bbs/1246

増大(増加)率は4/3倍です。

このプログラムでバイナリー形式ファイルもこの掲示板に
投稿できるようになります。

あまり大きなファイルは無理ですが、作成したdllやexeファイル
zipファイル等の投稿に利用できます。

FILEREAD$はSECONDさん作成のルーチンを
利用させて頂きました。(CHARACTER INPUT #より高速です)

OPTION CHARACTER BYTE
FILE GETNAME F$,"ファイル|*.*"
IF F$="" THEN STOP
LET DAT$=ENCODEBASE64$(FILEREAD$(F$))
OPEN #2:NAME F$&".bas"
ERASE #2
PRINT #2:"OPTION CHARACTER BYTE"
PRINT #2:"OPEN #1:NAME ";CHR$(34);F$;CHR$(34)
PRINT #2:"DO"
PRINT #2:"  READ IF MISSING THEN EXIT DO: X$"
PRINT #2:"  LET DEC$=DECODEBASE64$(X$)"
PRINT #2:"  PRINT #1:DEC$;"
PRINT #2:"LOOP"
LET SIZE=LEN(DAT$)
FOR I=0 TO INT(SIZE/76)-1
   PRINT #2:"DATA ";CHR$(34);DAT$(76*I+1:76*I+76);CHR$(34)
NEXT I
IF MOD(SIZE,76)>0 THEN PRINT #2:"DATA ";CHR$(34);DAT$(76*I+1:SIZE);CHR$(34)
PRINT #2:"CLOSE #1"
PRINT #2:"END"
PRINT #2
PRINT #2:"EXTERNAL  FUNCTION DECODEBASE64$(X$)"
PRINT #2:"OPTION CHARACTER BYTE"
PRINT #2:"LET A$=";CHR$(34);"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";CHR$(34)
PRINT #2:"FOR I=0 TO INT(BLEN(X$)/4)-1"
PRINT #2:"   LET D$=X$(4*I+1:4*I+4)"
PRINT #2:"   LET N=0"
PRINT #2:"   FOR J=1 TO 4"
PRINT #2:"      LET L=POS(A$,D$(J:J))-1"
PRINT #2:"      IF L>=0 THEN LET N=N*64+L ELSE LET N=N/4"
PRINT #2:"   NEXT J"
PRINT #2:"   LET S$=";CHR$(34);CHR$(34)
PRINT #2:"   IF D$(3:4)=";CHR$(34);"==";CHR$(34);" THEN"
PRINT #2:"      LET KK=1"
PRINT #2:"   ELSEIF D$(4:4)=";CHR$(34);"=";CHR$(34);" THEN"
PRINT #2:"      LET KK=2"
PRINT #2:"   ELSE"
PRINT #2:"      LET KK=3"
PRINT #2:"   END IF"
PRINT #2:"   FOR K=1 TO KK"
PRINT #2:"      LET S$=CHR$(MOD(N,256))&S$"
PRINT #2:"      LET N=INT(N/256)"
PRINT #2:"   NEXT K"
PRINT #2:"   LET DEC$=DEC$&S$"
PRINT #2:"NEXT I"
PRINT #2:"LET DECODEBASE64$=DEC$"
PRINT #2:"END FUNCTION"
CLOSE #2
END

EXTERNAL  FUNCTION FILEREAD$(NAME$)
OPTION CHARACTER BYTE
OPEN #1:NAME NAME$,ACCESS INPUT
SET #1: ENDOFLINE CHR$(13)
ASK #1: FILESIZE S9
LET CX=S9 ! cx=bytes size
LET DB$=""
DO
   LET W9=LEN(W9$)-CX
   IF 0=<W9 THEN
      LET DB$=DB$ &LEFT$(W9$,CX)
      LET S99=S99+CX
      LET W9$=RIGHT$(W9$,W9)
      EXIT DO
   END IF
   LET DB$=DB$ &W9$
   LET S99=S99+LEN(W9$)
   LET W9$=""
   LET CX=-W9
   LINE INPUT #1,IF MISSING THEN EXIT DO :W9$
   IF S99+LEN(W9$)<S9 THEN LET W9$=W9$ &CHR$(13)
LOOP
CLOSE #1
LET FILEREAD$=DB$(1:S9)
END FUNCTION

EXTERNAL  FUNCTION ENCODEBASE64$(A$)
OPTION CHARACTER BYTE
LET S$="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
LET L=MOD(LEN(A$),3)
FOR I=0 TO INT(LEN(A$)/3)-1
   LET D$=A$(3*I+1:3*I+3)
   LET N=ORD(D$(1:1))*256^2+ORD(D$(2:2))*256+ORD(D$(3:3))
   LET N1=MOD(INT(N/64^3),64)+1
   LET N2=MOD(INT(N/64^2),64)+1
   LET N3=MOD(INT(N/64),64)+1
   LET N4=MOD(N,64)+1
   LET ENC$=ENC$&S$(N1:N1)&S$(N2:N2)&S$(N3:N3)&S$(N4:N4)
NEXT I
LET D$=A$(3*I+1:LEN(A$))
SELECT CASE L
CASE 0
CASE 2
!'2byte 16bit 123456  781234  567800  4倍して6bitずつ*3つ
   LET N=ORD(D$(1:1))*256+ORD(D$(2:2))
   LET N=N*4
   LET N1=MOD(INT(N/64^2),64)+1
   LET N2=MOD(INT(N/64),64)+1
   LET N3=MOD(N,64)+1
   LET ENC$=ENC$&S$(N1:N1)&S$(N2:N2)&S$(N3:N3)&"="
CASE 1
!'1byte 8bit 123456  780000  16倍して6bitずつ*2つ
   LET N=ORD(D$)
   LET N=N*16
   LET N1=MOD(INT(N/64),64)+1
   LET N2=MOD(N,64)+1
   LET ENC$=ENC$&S$(N1:N1)&S$(N2:N2)&"=="
END SELECT
LET ENCODEBASE64$=ENC$
END FUNCTION
 

BASE32

 投稿者:しばっち  投稿日:2020年10月 3日(土)19時41分54秒
返信・引用
  BASE32では5バイト40bitを5bitずつ8つに分け32進文字列に変換します。
文字数が5の倍数ではない時"="で埋めます。
5バイトを8文字に変換するので増大率は8/5倍になります。

https://en.wikipedia.org/wiki/Base32

OPTION CHARACTER BYTE
DO
   READ IF MISSING THEN EXIT DO:A$
   LET S$=ENCODEBASE32$(A$)
   PRINT "原文  :";A$
   PRINT "ENCODE:";S$
   PRINT "DECODE:";DECODEBASE32$(S$)
   PRINT
LOOP
DATA A
DATA AB
DATA ABC
DATA ABCD
DATA ABCDE
DATA ABCDEFGHIJKLMNOPQRSTUVWXYZ
DATA 0123456789
DATA 十進BASIC
END

EXTERNAL  FUNCTION ENCODEBASE32$(A$)
OPTION CHARACTER BYTE
LET S$="ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"
LET L=MOD(LEN(A$),5)
FOR I=0 TO INT(LEN(A$)/5)-1
   LET D$=A$(5*I+1:5*I+5)
   LET N=ORD(D$(1:1))*256^4+ORD(D$(2:2))*256^3+ORD(D$(3:3))*256^2+ORD(D$(4:4))*256+ORD(D$(5:5))
   LET N1=MOD(INT(N/32^7),32)+1
   LET N2=MOD(INT(N/32^6),32)+1
   LET N3=MOD(INT(N/32^5),32)+1
   LET N4=MOD(INT(N/32^4),32)+1
   LET N5=MOD(INT(N/32^3),32)+1
   LET N6=MOD(INT(N/32^2),32)+1
   LET N7=MOD(INT(N/32),32)+1
   LET N8=MOD(N,32)+1
   LET ENC$=ENC$&S$(N1:N1)&S$(N2:N2)&S$(N3:N3)&S$(N4:N4)&S$(N5:N5)&S$(N6:N6)&S$(N7:N7)&S$(N8:N8)
NEXT I
LET D$=A$(5*I+1:LEN(A$))
SELECT CASE L
CASE 0
CASE 4
!'4byte 32bit 12345  67812  34567  81234  56781  23456  78000  8倍して5bitずつ*7つ
   LET N=ORD(D$(1:1))*256^3+ORD(D$(2:2))*256^2+ORD(D$(3:3))*256+ORD(D$(4:4))
   LET N=N*8
   LET N1=MOD(INT(N/32^6),32)+1
   LET N2=MOD(INT(N/32^5),32)+1
   LET N3=MOD(INT(N/32^4),32)+1
   LET N4=MOD(INT(N/32^3),32)+1
   LET N5=MOD(INT(N/32^2),32)+1
   LET N6=MOD(INT(N/32),32)+1
   LET N7=MOD(N,32)+1
   LET ENC$=ENC$&S$(N1:N1)&S$(N2:N2)&S$(N3:N3)&S$(N4:N4)&S$(N5:N5)&S$(N6:N6)&S$(N7:N7)&"="
CASE 3
!'3byte 24bit 12345  67812  34567  81234  56780  2倍して5bitずつ*5つ
   LET N=ORD(D$(1:1))*256^2+ORD(D$(2:2))*256+ORD(D$(3:3))
   LET N=N*2
   LET N1=MOD(INT(N/32^4),32)+1
   LET N2=MOD(INT(N/32^3),32)+1
   LET N3=MOD(INT(N/32^2),32)+1
   LET N4=MOD(INT(N/32),32)+1
   LET N5=MOD(N,32)+1
   LET ENC$=ENC$&S$(N1:N1)&S$(N2:N2)&S$(N3:N3)&S$(N4:N4)&S$(N5:N5)&"==="
CASE 2
!'2byte 16bit 12345  67812  34567  80000  16倍して5bitずつ*4つ
   LET N=ORD(D$(1:1))*256+ORD(D$(2:2))
   LET N=N*16
   LET N1=MOD(INT(N/32^3),32)+1
   LET N2=MOD(INT(N/32^2),32)+1
   LET N3=MOD(INT(N/32),32)+1
   LET N4=MOD(N,32)+1
   LET ENC$=ENC$&S$(N1:N1)&S$(N2:N2)&S$(N3:N3)&S$(N4:N4)&"===="
CASE 1
!'1byte 8bit 12345  67800  4倍して5bitずつ*2つ
   LET N=ORD(D$)
   LET N=N*4
   LET N1=MOD(INT(N/32),32)+1
   LET N2=MOD(N,32)+1
   LET ENC$=ENC$&S$(N1:N1)&S$(N2:N2)&"======"
END SELECT
LET ENCODEBASE32$=ENC$
END FUNCTION

EXTERNAL  FUNCTION DECODEBASE32$(M$)
OPTION CHARACTER BYTE
LET A$="ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"
FOR I=0 TO LEN(M$)/8-1
   LET L$=M$(8*I+1:8*I+8)
   IF RIGHT$(L$,6)="======" THEN
      LET N1=POS(A$,L$(1:1))-1
      LET N2=POS(A$,L$(2:2))-1
      LET N=N1*32+N2
      LET N=N/4
      LET DEC$=DEC$&CHR$(MOD(N,256))
   ELSEIF RIGHT$(L$,4)="====" THEN
      LET N1=POS(A$,L$(1:1))-1
      LET N2=POS(A$,L$(2:2))-1
      LET N3=POS(A$,L$(3:3))-1
      LET N4=POS(A$,L$(4:4))-1
      LET N=N1*32^3+N2*32^2+N3*32+N4
      LET N=N/16
      LET DEC$=DEC$&CHR$(MOD(INT(N/256),256))&CHR$(MOD(N,256))
   ELSEIF RIGHT$(L$,3)="===" THEN
      LET N1=POS(A$,L$(1:1))-1
      LET N2=POS(A$,L$(2:2))-1
      LET N3=POS(A$,L$(3:3))-1
      LET N4=POS(A$,L$(4:4))-1
      LET N5=POS(A$,L$(5:5))-1
      LET N=N1*32^4+N2*32^3+N3*32^2+N4*32+N5
      LET N=N/2
      LET DEC$=DEC$&CHR$(MOD(INT(N/256^2),256))&CHR$(MOD(INT(N/256),256))&CHR$(MOD(N,256))
   ELSEIF RIGHT$(L$,1)="=" THEN
      LET N1=POS(A$,L$(1:1))-1
      LET N2=POS(A$,L$(2:2))-1
      LET N3=POS(A$,L$(3:3))-1
      LET N4=POS(A$,L$(4:4))-1
      LET N5=POS(A$,L$(5:5))-1
      LET N6=POS(A$,L$(6:6))-1
      LET N7=POS(A$,L$(7:7))-1
      LET N=N1*32^6+N2*32^5+N3*32^4+N4*32^3+N5*32^2+N6*32+N7
      LET N=N/8
      LET DEC$=DEC$&CHR$(MOD(INT(N/256^3),256))&CHR$(MOD(INT(N/256^2),256))&CHR$(MOD(INT(N/256),256))&CHR$(MOD(N,256))
   ELSE
      LET N1=POS(A$,L$(1:1))-1
      LET N2=POS(A$,L$(2:2))-1
      LET N3=POS(A$,L$(3:3))-1
      LET N4=POS(A$,L$(4:4))-1
      LET N5=POS(A$,L$(5:5))-1
      LET N6=POS(A$,L$(6:6))-1
      LET N7=POS(A$,L$(7:7))-1
      LET N8=POS(A$,L$(8:8))-1
      LET N=N1*32^7+N2*32^6+N3*32^5+N4*32^4+N5*32^3+N6*32^2+N7*32+N8
      LET DEC$=DEC$&CHR$(MOD(INT(N/256^4),256))&CHR$(MOD(INT(N/256^3),256))&CHR$(MOD(INT(N/256^2),256))&CHR$(MOD(INT(N/256),256))&CHR$(MOD(N,256))
   END IF
NEXT I
LET DECODEBASE32$=DEC$
END FUNCTION
 

BASE64

 投稿者:しばっち  投稿日:2020年10月 3日(土)19時40分49秒
返信・引用
  文字列をBASE64エンコード、デコードします。
BASE64では、3バイト24bitずつ取り出してそれを6bitずつ4つに分けます。
6bitつまり2^6で64進文字列に変換します。
文字数が3倍数でない時は"="で埋めます。
3バイトを4文字(バイト)に変換するので増大率は4/3倍になります。
デコードでは4文字ずつ取り出し3バイト24bitの文字列に変換します。

この変換を施すと文字コード(0~255)は全て表示可能文字(印刷可能文字)
となります。

エンコードに使用する文字種を変えた亜種があるようです。
https://ja.wikipedia.org/wiki/Base64


ちなみにBASE16では1バイト8bitを4bitずつ2つに分けます。
4bitつまり2^4で16進文字列に変換します。
これはBSTR$(n,16) BVAL(n$,16)で簡単に変換できます。
1バイトを2文字に変換するので増大率は2倍になります。


BASE64より更に増大率を抑えたBASE85というのもあるようです。
https://ja.wikipedia.org/wiki/Ascii85


OPTION CHARACTER BYTE
DO
   READ IF MISSING THEN EXIT DO:A$
   LET S$=ENCODEBASE64$(A$)
   PRINT "原文  :";A$
   PRINT "ENCODE:";S$
   PRINT "DECODE:";DECODEBASE64$(S$)
   PRINT
LOOP
DATA A
DATA AB
DATA ABC
DATA ABCD
DATA ABCDE
DATA ABCDEFGHIJKLMNOPQRSTUVWXYZ
DATA 0123456789
DATA 十進BASIC
END

EXTERNAL  FUNCTION ENCODEBASE64$(A$)
OPTION CHARACTER BYTE
LET S$="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
LET L=MOD(LEN(A$),3)
FOR I=0 TO INT(LEN(A$)/3)-1
   LET D$=A$(3*I+1:3*I+3)
   LET N=ORD(D$(1:1))*256^2+ORD(D$(2:2))*256+ORD(D$(3:3))
   LET N1=MOD(INT(N/64^3),64)+1
   LET N2=MOD(INT(N/64^2),64)+1
   LET N3=MOD(INT(N/64),64)+1
   LET N4=MOD(N,64)+1
   LET ENC$=ENC$&S$(N1:N1)&S$(N2:N2)&S$(N3:N3)&S$(N4:N4)
NEXT I
LET D$=A$(3*I+1:LEN(A$))
SELECT CASE L
CASE 0
CASE 2
!'2byte 16bit 123456  781234  567800  4倍して6bitずつ*3つ
   LET N=ORD(D$(1:1))*256+ORD(D$(2:2))
   LET N=N*4
   LET N1=MOD(INT(N/64^2),64)+1
   LET N2=MOD(INT(N/64),64)+1
   LET N3=MOD(N,64)+1
   LET ENC$=ENC$&S$(N1:N1)&S$(N2:N2)&S$(N3:N3)&"="
CASE 1
!'1byte 8bit 123456  780000  16倍して6bitずつ*2つ
   LET N=ORD(D$)
   LET N=N*16
   LET N1=MOD(INT(N/64),64)+1
   LET N2=MOD(N,64)+1
   LET ENC$=ENC$&S$(N1:N1)&S$(N2:N2)&"=="
END SELECT
LET ENCODEBASE64$=ENC$
END FUNCTION

EXTERNAL  FUNCTION DECODEBASE64$(M$)
OPTION CHARACTER BYTE
LET A$="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
FOR I=0 TO LEN(M$)/4-1
   LET L$=M$(4*I+1:4*I+4)
   IF RIGHT$(L$,2)="==" THEN
      LET N1=POS(A$,L$(1:1))-1
      LET N2=POS(A$,L$(2:2))-1
      LET N=N1*64+N2
      LET N=N/16
      LET DEC$=DEC$&CHR$(MOD(N,256))
   ELSEIF RIGHT$(L$,1)="=" THEN
      LET N1=POS(A$,L$(1:1))-1
      LET N2=POS(A$,L$(2:2))-1
      LET N3=POS(A$,L$(3:3))-1
      LET N=N1*64^2+N2*64+N3
      LET N=N/4
      LET DEC$=DEC$&CHR$(MOD(INT(N/256),256))&CHR$(MOD(N,256))
   ELSE
      LET N1=POS(A$,L$(1:1))-1
      LET N2=POS(A$,L$(2:2))-1
      LET N3=POS(A$,L$(3:3))-1
      LET N4=POS(A$,L$(4:4))-1
      LET N=N1*64^3+N2*64^2+N3*64+N4
      LET DEC$=DEC$&CHR$(MOD(INT(N/256^2),256))&CHR$(MOD(INT(N/256),256))&CHR$(MOD(N,256))
   END IF
NEXT I
LET DECODEBASE64$=DEC$
END FUNCTION
 

Re: カメラ映像表示

 投稿者:しばっち  投稿日:2020年 9月 9日(水)18時42分22秒
返信・引用
  twagaさんへのお返事です。

> opencv_world300.dll
> getcameraframe.dll
>
> を再度アップロードしていただくことはできませんでしょうか。
>
> 十進BASICでカメラ映像を表示したいと思っており、検索していたらこちらの掲示板にたどりつきました。
>

この度リクエストを頂き再投稿致します。残念ながら当時のアーカイブはもう破棄してありませんので
収録したファイルを思い出しながら、再現してみました。
全く同じ内容というわけではありませんが、遜色はないと思います。

当時の掲示板にも記したようにGETCAMERAFRAMEDLL.BAS(getcameraframe.dll)はwebカメラ映像を表示させるものですが、
webカメラ(USBカメラ)を私は持っていないので、このプログラムは未テスト(未確認)です(カメラデバイスがないと表示されるだけ!?)

また、誤解のないように付け加えておきますが、このプログラムはリアルタイム(30~60fps)で表示させるものではなく
静止画として取得しそれを連続で表示させるものでウェイトがかかります。それでも3~6fps程度はいけるかと思います。
WAIT DELAY文で調整してください。もし、外してしまうと負荷がかなり高くなると思います。

また、このプログラムは映像のみで音声には対応していません。

opencv_world300.dllはBASIC.EXEと同じフォルダに入れてください。
getcameraframe.dllはASSIGN文でパスをしてしてください。
※zipを解凍してできたbasフォルダとdllフォルダをそのままBASIC.EXEと同じフォルダに入れれば動くはずです。



下記よりダウンロードしてください(imagetool.zip(x86版) 24.5MB)

https://6.gigafile.nu/1108-d58b2b2575bc12ca5baa3c43dd3e30f5c


ダウンロードキー:設定していません
ダウンロード期限:2020年11月8日(日)



動作報告等を頂けると嬉しいです。ちゃんと動くのか(GETCAMERAFRAMEDLL.BAS)まだ確認できていないので (^_^;)

 

Re: カメラ映像表示

 投稿者:twaga  投稿日:2020年 9月 7日(月)23時07分9秒
返信・引用
  > No.4728[元記事へ]

opencv_world300.dll
getcameraframe.dll

を再度アップロードしていただくことはできませんでしょうか。

十進BASICでカメラ映像を表示したいと思っており、検索していたらこちらの掲示板にたどりつきました。

しばっちさんへのお返事です。


>
> なお、実行時にはopencv_world300.dllが必要です(BASIC.EXEと同じフォルダに入れてください)
>
> 下記URLからダウンロードしてください。(imagetool.zip)
>
> https://36.gigafile.nu/1125-n8d2d72a2da1c926a4d213cd6f41f8bd3
>
> ダウンロード期限:2019年11月25日(月)
> ダウンロードキー:設定していません
>


> !'
> FUNCTION GETCAMERAFRAME_(ID,WIDTH,HEIGHT,MAP$)
>    ASSIGN ".\DLL\getcameraframe.dll","getcameraframe"
> END FUNCTION
> END SUB
>
> EXTERNAL SUB GINIT(XSIZE,YSIZE)
> SET BITMAP SIZE XSIZE,YSIZE
> SET COLOR MIX(0) 0,0,0
> SET COLOR MODE "NATIVE"
> CLEAR
> SET POINT STYLE 1
> SET WINDOW 0,XSIZE-1,YSIZE-1,0
> END SUB
>
> --------------------------------------------------------------------------
>                              getcameraframe.cpp
>
>
> #include <opencv2/core/core.hpp>
> #include <opencv2/imgproc/imgproc.hpp>
> #include <opencv2/objdetect/objdetect.hpp>
> #include <opencv2/highgui/highgui.hpp>
>
> using namespace std;
> using namespace cv;
>
> extern "C"  __declspec(dllexport) int getcameraframe(int n,int width,int height,char *framedata)
> {
>     Mat img;
>     VideoCapture cap(n);
>     if (!cap.isOpened()) return -1;
>     cap.set(CV_CAP_PROP_FRAME_WIDTH,width); //縦の大きさ
>     cap.set(CV_CAP_PROP_FRAME_HEIGHT,height); //横の大きさ
>     if (!cap.read(img)) return -2;
>     cap>>img ; //1フレーム分取り出してimgに保持させる
>     for(int y=0; y<height; y++)
>         for(int x=0; x<width; x++)
>             for(int c=0; c<3; c++)
>                 framedata[(y*width+x)*3+c]=img.at<cv::Vec3b>(y,x)[c]; // c=0 blue, c=1 green, c=2 red
>     return 0;
> }
>            
 

正規表現

 投稿者:しばっち  投稿日:2020年 8月26日(水)20時44分23秒
返信・引用
  C++ライブラリーを使用して十進BASIC上で正規表現が使えるようになりました。
今回はC++標準ライブラリーのみなので下記のcppソースだけでコンパイル可能です。

https://ja.wikipedia.org/wiki/正規表現
https://murashun.jp/blog/20190215-01.html
https://userweb.mnet.ne.jp/nakama/

サンプル
https://hodade.com/seiki/page.php?chapter_3
https://www.megasoft.co.jp/mifes/seiki/index.html

オンラインテスト
https://regex101.com/


検索文字列がはっきりしている場合は、対象が "ABCDE" なら十進BASICにあるPOS("ABCDE",A$)のようにPOS文で
検索できますが、3桁の数字に"-"(ハイフン)そして4桁の数字といった検索では少しやっかいです。
これは郵便番号を表すものですが、正規表現では "\d{3}-\d{4}" とすれば検索できます。("\d\d\d-\d\d\d\d"としても同じです)

但し、これでは電話番号の一部も検索対象になってしまいます。
郵便番号の後が半角スペースなら "\d{3}-\d{4} " とすればいいのですが
行末にある場合には対象になりません。この場合は正規表現のor表現を使って
"\d{3}-\d{4}( |$)" とすれば郵便番号の後が半角スペースか行末でも検索できるようになります。


使いこなすには慣れが必要ですが、正規表現を使えばこのような検索ができるようになります。




以下のプログラムは該当するファイル名を表示します。

OPTION CHARACTER BYTE
LET PATTERN$="^[A-E]" !'先頭文字がA~E
!'LET PATTERN$="[0-9]$" !'行末文字が数字
DIRECTORY GETNAME F$
LET F$=F$&"\*.*"
LET K=FILES(F$)
IF K>0 THEN
   DIM N$(K)
   FILE LIST F$,N$
ELSE
   STOP
END IF
FOR I=1 TO K
   FILE SPLITNAME(N$(I)) PATH$,NAME$,EXT$
   LET L=SEARCH_POS(PATTERN$,NAME$) !'部分一致
   !'LET L=SEARCH_LEN(PATTERN$,NAME$) !'部分一致
   !'LET L=MATCH(PATTERN$,NAME$) !'完全一致
   IF L>0 THEN
      PRINT NAME$;EXT$
   ELSEIF L=-9999 THEN
      PRINT "ERROR"
      STOP
   END IF
NEXT I
END

EXTERNAL  FUNCTION SEARCH_POS(PATTERN$,S$)
OPTION CHARACTER BYTE
ASSIGN ".\DLL\regex.dll","search_pos"
END FUNCTION

EXTERNAL  FUNCTION SEARCH_LEN(PATTERN$,S$)
OPTION CHARACTER BYTE
ASSIGN ".\DLL\regex.dll","search_len"
END FUNCTION

EXTERNAL  SUB SEARCH_STR(PATTERN$,S$,RESULT$)
OPTION CHARACTER BYTE
LET RES$=REPEAT$(CHR$(0),LEN(S$)+100)
LET L=SEARCH_STR_(PATTERN$,S$,RES$)
IF L>0 THEN
   FOR I=1 TO LEN(RES$)
      IF RES$(I:I)=CHR$(0) THEN EXIT FOR
   NEXT I
   LET RESULT$=RES$(1:I-1)
ELSE
   LET RESULT$=""
END IF

FUNCTION SEARCH_STR_(PATTERN$,S$,RES$)
   ASSIGN ".\DLL\regex.dll","search_str"
END FUNCTION
END SUB

EXTERNAL  SUB SEARCHES_POS(PATTERN$,SS$,P,OUT$)
OPTION CHARACTER BYTE
LET RET$=REPEAT$(CHR$(0),LEN(SS$))
LET P=SEARCHES_POS_(PATTERN$,SS$,RET$)
FOR I=1 TO LEN(RET$)
   IF RET$(I:I)=CHR$(0) THEN EXIT FOR
NEXT I
LET OUT$=RET$(1:I-1)

FUNCTION SEARCHES_POS_(PATTERN$,S$,OUT$)
   ASSIGN ".\DLL\regex.dll","searches_pos"
END FUNCTION
END SUB

EXTERNAL  SUB SEARCHES_LEN(PATTERN$,SS$,L,OUT$)
OPTION CHARACTER BYTE
LET RET$=REPEAT$(CHR$(0),LEN(SS$))
LET L=SEARCHES_LEN_(PATTERN$,SS$,RET$)
FOR I=1 TO LEN(RET$)
   IF RET$(I:I)=CHR$(0) THEN EXIT FOR
NEXT I
LET OUT$=RET$(1:I-1)

FUNCTION SEARCHES_LEN_(PATTERN$,S$,OUT$)
   ASSIGN ".\DLL\regex.dll","searches_len"
END FUNCTION
END SUB

EXTERNAL  SUB SEARCHES_STR(PATTERN$,S$,OUT$,RESULT$)
OPTION CHARACTER BYTE
LET RES$=REPEAT$(CHR$(0),LEN(S$)+100)
LET T$=REPEAT$(CHR$(0),LEN(S$))
LET L=SEARCHES_STR_(PATTERN$,S$,T$,RES$)
IF L>0 THEN
   FOR I=1 TO LEN(RES$)
      IF RES$(I:I)=CHR$(0) THEN EXIT FOR
   NEXT I
   LET RESULT$=RES$(1:I-1)
ELSE
   LET RESULT$=""
END IF
FOR I=1 TO LEN(T$)
   IF T$(I:I)=CHR$(0) THEN EXIT FOR
NEXT I
LET OUT$=T$(1:I-1)

FUNCTION SEARCHES_STR_(PATTERN$,S$,T$,RES$)
   ASSIGN ".\DLL\regex.dll","searches_str"
END FUNCTION
END SUB

EXTERNAL  FUNCTION MATCH(PATTERN$,S$)
OPTION CHARACTER BYTE
ASSIGN ".\DLL\regex.dll","match"
END FUNCTION

EXTERNAL  FUNCTION REPLACE$(PATTERN$,S$,REP$)
OPTION CHARACTER BYTE
LET RESULT$=REPEAT$(CHR$(0),LEN(S$)+500)
IF REPLACE_(PATTERN$,S$,REP$,RESULT$)=1 THEN
   FOR I=1 TO LEN(RESULT$)
      IF RESULT$(I:I)=CHR$(0) THEN EXIT FOR
   NEXT I
   LET REPLACE$=RESULT$(1:I-1)
ELSE
   LET REPLACE$=""
END IF

FUNCTION REPLACE_(PATTERN$,S$,REP$,RESULT$)
   ASSIGN ".\DLL\regex.dll","replace"
END FUNCTION
END FUNCTION
--------------------------------------------------------------------
                              regex.cpp

#include <regex>
#include <string>

using namespace std;

extern "C"  __declspec(dllexport) int search_pos(char *pattern,char *ss)
{
    smatch match;
    string str=ss;

    try {
        if (regex_search(str, match, regex(pattern)))
            return match.position(0)+1;
        else return 0;
    } catch(...) {
        return -9999;
    }
}

extern "C"  __declspec(dllexport) int search_len(char *pattern,char *ss)
{
    smatch match;
    string str=ss;

    try {
        if (regex_search(str, match, regex(pattern)))
            return match.length(0);
        else return 0;
    } catch(...) {
        return -9999;
    }
}

extern "C"  __declspec(dllexport) int search_str(char *pattern,char *ss,char *result)
{
    smatch match;
    string str=ss,tt;

    try {
        if (regex_search(str, match, regex(pattern)))
        {
            tt=match[0].str();
            strcpy(result,tt.c_str());
            return 1;
        }
        else return 0;
    } catch(...) {
        return -9999;
    }
}

extern "C"  __declspec(dllexport) int searches_pos(char *pattern,char *ss,char *out)
{
    smatch match;
    string str=ss;
    int pos;

    try {
        if (regex_search(str, match, regex(pattern)))
        {
            pos=match.position(0)+1;
            str=match.suffix();
            strcpy(out,str.c_str());
            return pos;
        }
        else return 0;
    } catch(...) {
        return -9999;
    }
}

extern "C"  __declspec(dllexport) int searches_len(char *pattern,char *ss,char *out)
{
    smatch match;
    string str=ss;
    int len;

    try {
        if (regex_search(str, match, regex(pattern)))
        {
            len=match.length(0);
            str=match.suffix();
            strcpy(out,str.c_str());
            return len;
        }
        else return 0;
    } catch(...) {
        return -9999;
    }
}

extern "C"  __declspec(dllexport) int searches_str(char *pattern,char *ss,char *out,char *result)
{
    smatch match;
    string str=ss,tt;

    try {
        if (regex_search(str, match, regex(pattern)))
        {
            tt=match[0].str();
            strcpy(result,tt.c_str());
            str=match.suffix();
            strcpy(out,str.c_str());
            return 1;
        }
        else return 0;
    } catch(...) {
        return -9999;
    }
}

extern "C"  __declspec(dllexport) int match(char *pattern,char *ss)
{
    smatch match;
    string str=ss;

    try {
        if (regex_match(str, match, regex(pattern)))
            return match.length(0);
        else return 0;
    } catch(...) {
        return -9999;
    }
}

extern "C"  __declspec(dllexport) int replace(char *pattern,char *ss,char *rep,char *result)
{
    string str=ss,r;

    try {
        r=regex_replace(str, regex(pattern),rep);
        strcpy(result,r.c_str());
        return 1;
    } catch(...) {
        return -9999;
    }
}



下記はテキストファイルを読み込み該当するデータを抽出し表示します。

FILE GETNAME F$
IF F$="" THEN STOP
OPEN #1:NAME F$
DO
   LINE INPUT #1,IF MISSING THEN EXIT DO:A$
   IF A$<>"" THEN
   !  LET P=SEARCH_POS("\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*",A$) !'Email アドレス
   !  LET L=SEARCH_LEN("\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*",A$) !'Email アドレス
   !  IF P>0 THEN
   !     PRINT A$(P:P+L-1)
   !  END IF

      LET R$=SEARCH_STR$("\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*",A$) !'Email アドレス
      IF R$<>"" THEN PRINT R$

      LET R$=SEARCH_STR$("(https|http)?://([\w-]+\.)+[\w-]+(/[\w-./?%&=]*)?",A$) !'URL
      IF R$<>"" THEN PRINT R$

      LET R$=SEARCH_STR$("0\d(-\d{4}|\d-\d{3}|\d\d-\d\d|\d{3}-\d)-\d{4}",A$) !'固定電話
      IF R$<>"" THEN PRINT R$

      LET R$=SEARCH_STR$("0[789]0-\d{4}-\d{4}",A$) !'携帯電話
      IF R$<>"" THEN PRINT R$

      LET R$=SEARCH_STR$("(0120|0800)-\d{3}-\d{3}",A$) !'フリーダイヤル
      IF R$<>"" THEN PRINT R$

      LET R$=SEARCH_STR$("\d{4}.\d\d.\d\d",A$) !'日付 (YYYY-MM-DD形式)
      IF R$<>"" THEN PRINT R$

      LET R$=SEARCH_STR$("\d{3}-\d{4}",A$) !'郵便番号
      IF R$<>"" THEN PRINT R$

   END IF
LOOP
CLOSE #1
END

同一行内に検索対象が複数個所ある場合はループを使用して処理します。
dll内で行うには都合が悪かったのでBASIC側にてループで処理します。

LET A$="abcdef    Abc    1230abcde   abc "
DO
   CALL SEARCHES_STR("( |^)[a-z]+",A$,OUT$,RESULT$)
   IF RESULT$="" THEN EXIT DO
   PRINT RESULT$
   LET A$=OUT$
LOOP
PRINT "---------------------------------------"
LET A$="abcdef    Abc    1230abcde   abc "
DO
   CALL SEARCHES_POS("( |^)[a-z]+",A$,P,OUT$)
   IF P=0 THEN EXIT DO
   CALL SEARCHES_LEN("( |^)[a-z]+",A$,L,OUT$)
   PRINT A$(P:P+L-1)
   LET A$=OUT$
LOOP
END


VC++2019にてコンパイルしました。(regex.zip)
下記よりダウンロードしてください。

https://16.gigafile.nu/0925-d0a767ca924f6da0c68d30eba2537358d


ダウンロードパス:設定していません
ダウンロード期限:2020年9月25日(金)
 

Re: Linux版Decimal Basicに付いて

 投稿者:came_tongue  投稿日:2020年 8月 1日(土)23時45分44秒
返信・引用
  > No.4869[元記事へ]

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

色々と教えてもらってありがとうございました。
 

Re: Linux版Decimal Basicに付いて

 投稿者:SHIRAISHI Kazuo  投稿日:2020年 7月31日(金)08時07分51秒
返信・引用
  > No.4867[元記事へ]

came_tongueさんへのお返事です。

> SHIRAISHI Kazuoさんへのお返事です。
>
>
> >
> > Full BASICに
> > ON ・・・ GOTO
> > ON ・・・ GOSUB
> > の構文がありますが,・・・に書けるのは数値式のみです。たとえば
> > ON ERROR GOSUB
> > を書いても文法誤りになりませんが,ERRORは単なる数値変数です。
> > https://hp.vector.co.jp/authors/VA008683/FAQ_OnError.htm
> >
>
> ありがとうございます。
> あと、古いBASICで
>
> PRINT: PRINT: PRINT: PRINT: PRINT:
>
> 等を良く見かけるんですが(Cで言うprintf("\n\n\n\n\n");ですよね)、これに類する書き方、と言うのはFull BASICに存在するのでしょうか。
> あるいは単に、正攻法で
>
> PRINT
> PRINT
> PRINT
> PRINT
> PRINT
>
> って書くべきなのでしょうか。

Cのprintf("\n\n\n\n\n");に相当することをLinux上で行いたければ

LET n$=CHR$(10)
PRINT n$;n$;n$;n$;n$

です。Windowsだと

LET n$=CHR$(13)&CHR$(10)
PRINT n$;n$;n$;n$;n$


 

データファイル集

 投稿者:しばっち  投稿日:2020年 7月30日(木)20時34分30秒
返信・引用
  新たな試みとして十進BASIC等を使用して作成したデータファイル集(画像ファイル等)を公開したいと思います。
下記URLよりダウンロードできます。ぜひご堪能ください。(data.zip 459MB)

https://4.gigafile.nu/0829-e0c371e3106eb5417847b2ebcb9ee4d31


ダウンロードパス:設定していません
ダウンロード期限:2020年8月29日(土)


 

Re: Linux版Decimal Basicに付いて

 投稿者:came_tongue  投稿日:2020年 7月30日(木)18時26分37秒
返信・引用
  > No.4866[元記事へ]

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


>
> Full BASICに
> ON ・・・ GOTO
> ON ・・・ GOSUB
> の構文がありますが,・・・に書けるのは数値式のみです。たとえば
> ON ERROR GOSUB
> を書いても文法誤りになりませんが,ERRORは単なる数値変数です。
> https://hp.vector.co.jp/authors/VA008683/FAQ_OnError.htm
>

ありがとうございます。
あと、古いBASICで

PRINT: PRINT: PRINT: PRINT: PRINT:

等を良く見かけるんですが(Cで言うprintf("\n\n\n\n\n");ですよね)、これに類する書き方、と言うのはFull BASICに存在するのでしょうか。
あるいは単に、正攻法で

PRINT
PRINT
PRINT
PRINT
PRINT

って書くべきなのでしょうか。
 

Re: Linux版Decimal Basicに付いて

 投稿者:SHIRAISHI Kazuo  投稿日:2020年 7月30日(木)16時18分28秒
返信・引用
  > No.4865[元記事へ]

came_tongueさんへのお返事です。

> SHIRAISHI Kazuoさんへのお返事です。
>
> すみません。そもそもMAXNUMが何を返すか見てなかったこちらの失敗です(何らかのconcreteな整数を返すと思い込んでいました)。
> それに、単純に10のべき乗を使っても、処理系が返す浮動小数点の桁数以上だったらおかしな結果になりますよね・・・・・。
> そっちに気づかないで、条件節の書き方が悪かったのか、とコードを差し替え差し替えハマっていました。
>
> ご助言、ありがとうございます。
>
> もう一つ質問なんですが、古いBASIC(例えばHP BASICとか)で書かれたソースコードをFull BASICに移植する際の注意事項なんかはあるでしょうか?
> 「こういう辺りで良くハマる」
> と言うような助言があれば嬉しいのですが。

Full BASICに
ON ・・・ GOTO
ON ・・・ GOSUB
の構文がありますが,・・・に書けるのは数値式のみです。たとえば
ON ERROR GOSUB
を書いても文法誤りになりませんが,ERRORは単なる数値変数です。
https://hp.vector.co.jp/authors/VA008683/FAQ_OnError.htm
 

Re: Linux版Decimal Basicに付いて

 投稿者:came_tongue  投稿日:2020年 7月30日(木)15時54分24秒
返信・引用
  > No.4864[元記事へ]

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

すみません。そもそもMAXNUMが何を返すか見てなかったこちらの失敗です(何らかのconcreteな整数を返すと思い込んでいました)。
それに、単純に10のべき乗を使っても、処理系が返す浮動小数点の桁数以上だったらおかしな結果になりますよね・・・・・。
そっちに気づかないで、条件節の書き方が悪かったのか、とコードを差し替え差し替えハマっていました。

ご助言、ありがとうございます。

もう一つ質問なんですが、古いBASIC(例えばHP BASICとか)で書かれたソースコードをFull BASICに移植する際の注意事項なんかはあるでしょうか?
「こういう辺りで良くハマる」
と言うような助言があれば嬉しいのですが。
 

レンタル掲示板
/174