十進BASIC 第2掲示板過去ログ2020

Re: BASICAcc でCDECLの32ビットDLLを使う方法

投稿者：しばっち投稿日：2020年 1月 1日(水)09時45分6秒

> No.4756[元記事へ] SHIRAISHI Kazuoさんへのお返事です。 > BASICAcc1.2 source\Winlib.pasの226行目 > result:=ProcAddr; > の直後に，こちらでは226行目は i:integer; となっています。まず、確認ですが BASICAcc1202 winlib.pasのファイルサイズ16,260 バイト更新日時 2018年12月3日、15:13:54 となっています。こちらでは result:=ProcAddr; は265行目となります。他に548行目にもあります。下記は221行目からのコピペです function Assign(const DLLName,FUNCName:string; a:array of const):cardinal; var handle:THandle; ProcAddr:TLongIntFunction; params:PPointerArray; i:integer; p:pointer; begin Handle:=LoadLibrary(PChar(ExtractFilePath(Application.ExeName)+DLLName)); if Handle=0 then Handle:=LoadLibrary(PChar(DLLName)); if (Handle=0) then SetExceptionWith(DLLName+' Not Found',DLL_Error); @ProcAddr:=GetProcAddress(Handle,PChar(FuncName)); if @ProcAddr=nil then SetExceptionWith(FuncName+' Not Found',DLL_Error); params:=AllocMem(sizeof(pointer)*Length(a)); try for i:=0 to High(a) do with a[i] do begin case VTYPE of VTINTEGER: longint(params^[i]):=VInteger; VTInt64: Cardinal(params^[i]):=VINT64^; VTExtended: longint(params^[i]):=RoundToLongint(VExtended^); vtAnsistring:params^[i]:=PChar(VAnsistring); else setexceptionWith(IntToStr(i)+'th Parameter imcompatible',Dll_Error); end; end; try for i:=high(a) downto 0 do begin p:=@params^[i]; asm mov eax, p push dword ptr [eax] end; end; result:=ProcAddr; もう一度ご確認ください。

Re: BASICAcc でCDECLの32ビットDLLを使う方法

投稿者：SHIRAISHI Kazuo 投稿日：2020年 1月 1日(水)13時55分9秒

> No.4758[元記事へ] しばっちさんへのお返事です。 32ビット版BASICAccだと265行目の直後でした。 64ビット版公開のために不要なプロシージャを削除して修正した後であることを忘れていました。なお，function Assign　は通常のASSIGN文に対応しますが， AssignFPU(323行めの後） TSyncAssign.exec（201行目の後）も同様の修正が可能です。 ASSIGNFPUは，ASSIGN　○，○, FPU TSyncAssign.exec　は　ASSIGN ○，○，GUI に対応します。 > SHIRAISHI Kazuoさんへのお返事です。 > > > BASICAcc1.2 source\Winlib.pasの226行目 > > result:=ProcAddr; > > の直後に， > > こちらでは226行目は > i:integer; > となっています。 > > まず、確認ですが > BASICAcc1202 > > winlib.pasのファイルサイズ16,260 バイト > 更新日時 2018年12月3日、15:13:54 > となっています。 > > こちらでは > result:=ProcAddr; > > は265行目となります。 > 他に548行目にもあります。 > > 下記は221行目からのコピペです > > function Assign(const DLLName,FUNCName:string; a:array of const):cardinal; > var > handle:THandle; > ProcAddr:TLongIntFunction; > params:PPointerArray; > i:integer; > p:pointer; > begin > Handle:=LoadLibrary(PChar(ExtractFilePath(Application.ExeName)+DLLName)); > if Handle=0 then > Handle:=LoadLibrary(PChar(DLLName)); > if (Handle=0) then > SetExceptionWith(DLLName+' Not Found',DLL_Error); > > @ProcAddr:=GetProcAddress(Handle,PChar(FuncName)); > if @ProcAddr=nil then > SetExceptionWith(FuncName+' Not Found',DLL_Error); > > params:=AllocMem(sizeof(pointer)*Length(a)); > try > for i:=0 to High(a) do > with a[i] do > begin > case VTYPE of > VTINTEGER: longint(params^[i]):=VInteger; > VTInt64: Cardinal(params^[i]):=VINT64^; > VTExtended: longint(params^[i]):=RoundToLongint(VExtended^); > vtAnsistring:params^[i]:=PChar(VAnsistring); > else > setexceptionWith(IntToStr(i)+'th Parameter imcompatible',Dll_Error); > end; > end; > > > try > for i:=high(a) downto 0 do > begin > p:=@params^[i]; > asm > mov eax, p > push dword ptr [eax] > end; > end; > > result:=ProcAddr; > > もう一度ご確認ください。 >

多倍長計算

投稿者：しばっち投稿日：2020年 1月 5日(日)19時06分46秒

GMP互換のmpirライブラリー、mpfrライブラリーを使用して多倍長計算を行います。 https://gmplib.org http://mpir.org https://www.mpfr.org mpirには整数型、浮動小数型、有理数型がありますが四則計算しかサポートされていません。そこでmpirを使って関数を使えるようにしたのがmpfrです。初等関数等がサポートされています。 mpfrを使って複素数を使えるようにしたのがmpcです。自前で定義するより高速に計算できます。 mpfr及びmpcはC++インターフェイスがありません(Cインターフェイスのみ)のでラッパーにboostライブラリーを使用しています。 (※C++インターフェイスは関数定義でCインターフェイスは副プログラム定義のようなもの) なお、これらのDLLは自前でライブラリーをビルドしたものではなく、ネットよりダウンロードして入手したものです。予めご了承ください。 https://www.dll4free.com 1000桁モードで使用できるように関数として定義する場合と 2進モードや10進モードで使用する副プログラムとして定義する2通りがあります。 1000桁モードで使用する場合は下記のように関数として定義します。 OPTION ARITHMETIC DECIMAL_HIGH INPUT X PRINT LEXP(X) END EXTERNAL FUNCTION LEXP(X) OPTION ARITHMETIC DECIMAL_HIGH OPTION CHARACTER BYTE LET KETA=1000 LET X$=STR$(X) LET B$=REPEAT$(CHR$(32),KETA+100) CALL EXP1000(KETA,X$,B$) FOR I=LEN(B$) TO 1 STEP -1 IF B$(I:I)<="9" AND B$(I:I)>="0" THEN EXIT FOR END IF NEXT I LET LEXP=VAL(B$(1:I)) SUB EXP1000(KETA,X$,Y$) IF POS(X$,"/")>0 OR POS(X$,"(")>0 OR X$="" THEN PRINT "ERROR" STOP END IF ASSIGN ".\DLL\exp1000.dll","exp1000" END SUB END FUNCTION 1000桁モードではほぼ数式通りの記述ができます。 LET N=LEXP(-X)*X 副プログラムとして定義する場合は OPTION CHARACTER BYTE LET X$="1.04719755119659774615421446109316762806572313312503527365831486410260546876206966620934494178070568932738269550442743554903128153651686074390845313604282703915009470090064617370185321487431631831012732147627032522197781537615854941126226105509040063638188285564115344953681810888273779786908674971375790819566886877186272496050697365427641803057178812263086345333711017684960682217379471565064717053647768575678858653065103072870579397753726436837284935815412665424985578396191757496374264606100398304327789112081355221436200713164879840824573023405995364790092351307239209772558412822493948922313504400018937571508785360926192378091926320305787905957382281363374165114338218319512368359742656308630784733998537070967398695467813938660454325825710332017290240378333333279099268331701991057760536543953167481981844896943421417410275111489501175397706272367000104594625096219584440279380687239255638243453275116347625182291038652095462745126253125065259395259351072374226887100064262553706530307214006633333333333333" CALL LSIN(1000,X$,RESULT$) PRINT RESULT$ END EXTERNAL SUB LSIN(KETA,X$,RESULT$) OPTION CHARACTER BYTE LET B$=REPEAT$(CHR$(32),KETA+100) CALL SIN1000(KETA,X$,B$) FOR I=LEN(B$) TO 1 STEP -1 IF B$(I:I)<="9" AND B$(I:I)>="0" THEN EXIT FOR END IF NEXT I LET RESULT$=B$(1:I) SUB SIN1000(KETA,X$,Y$) IF POS(X$,"/")>0 OR POS(X$,"(")>0 OR X$="" THEN PRINT "ERROR" STOP END IF ASSIGN ".\DLL\sin1000.dll","sin1000" END SUB END SUB 副プログラムとして定義する場合は数式通りには記述できません。 LET N=LEXP(-X)*X PRINT N これを記述し直すと LET KETA=4000 !!! CALL LMUL(KETA,X$,STR$(-1),XX$) LET XX$="-" & X$ CALL LEXP(KETA,XX$,Y$) ! Y=EXP(-X) CALL LMUL(KETA,Y$,X$,N$) ! N=Y*X PRINT N$ ! CALL DISPLAY(N$) 記述通りに書けない代わりに1000桁である必要もないので例では4000桁を計算します。あまり意味はありませんが、桁数を16桁とすると2進モード、10進モードでも使用できます。 PRINT LSIN(PI/6) END EXTERNAL FUNCTION LCOS(X) OPTION CHARACTER BYTE LET B$=REPEAT$(CHR$(32),32) CALL COS1000(16,STR$(X),B$) FOR I=LEN(B$) TO 1 STEP -1 IF B$(I:I)<="9" AND B$(I:I)>="0" THEN EXIT FOR END IF NEXT I LET LCOS=VAL(B$(1:I)) SUB COS1000(KETA,X$,Y$) IF POS(X$,"/")>0 OR POS(X$,"(")>0 OR X$="" THEN PRINT "ERROR" STOP END IF ASSIGN ".\DLL\cos1000.dll","cos1000" END SUB END FUNCTION 複素数モードで使用できる関数も定義してみました。 OPTION ARITHMETIC COMPLEX PRINT CSIN(COMPLEX(PI/4,0)) END EXTERNAL FUNCTION CSIN(X) OPTION CHARACTER BYTE OPTION ARITHMETIC COMPLEX LET X$=REPEAT$(CHR$(0),32) LET Y$=REPEAT$(CHR$(0),32) CALL CSIN1000(16,STR$(RE(X)),STR$(IM(X)),X$,Y$) FOR I=LEN(X$) TO 1 STEP -1 IF X$(I:I)<="9" AND X$(I:I)>="0" THEN EXIT FOR NEXT I FOR I=LEN(Y$) TO 1 STEP -1 IF Y$(I:I)<="9" AND Y$(I:I)>="0" THEN EXIT FOR NEXT I LET CSIN=COMPLEX(RE(VAL(X$(1:I))),IM(VAL(Y$(1:I)))) SUB CSIN1000(KETA,A$,B$,X$,Y$) IF POS(A$,"/")>0 OR POS(B$,"/")>0 OR POS(A$,"(")>0 OR POS(B$,"(")>0 OR A$="" OR B$="" THEN PRINT "ERROR" STOP END IF ASSIGN ".\DLL\complex1000.dll","csin1000" END SUB END FUNCTION 副プログラムとして定義すれば、複素数多倍長で計算できます。 OPTION CHARACTER BYTE LET A=1 LET B=2 CALL CEXP(1000,STR$(A),STR$(B),RE$,IM$) PRINT "(";RE$;" , ";IM$;")" END EXTERNAL SUB CEXP(KETA,A$,B$,RE$,IM$) OPTION CHARACTER BYTE LET X$=REPEAT$(CHR$(32),KETA+100) LET Y$=REPEAT$(CHR$(32),KETA+100) CALL CEXP1000(KETA,A$,B$,X$,Y$) FOR I=LEN(X$) TO 1 STEP -1 IF X$(I:I)<="9" AND X$(I:I)>="0" THEN EXIT FOR NEXT I LET RE$=X$(1:I) FOR I=LEN(Y$) TO 1 STEP -1 IF Y$(I:I)<="9" AND Y$(I:I)>="0" THEN EXIT FOR NEXT I LET IM$=Y$(1:I) SUB CEXP1000(KETA,A$,B$,X$,Y$) IF POS(A$,"/")>0 OR POS(B$,"/")>0 OR POS(A$,"(")>0 OR POS(B$,"(")>0 OR A$="" OR B$="" THEN PRINT "ERROR" STOP END IF ASSIGN ".\DLL\cexp1000.dll","cexp1000" END SUB END SUB 三角関数(SIN,COS等)、逆三角関数(ASIN,ACOS等)、双曲線関数(COSH,TANH等)、逆双曲線関数(ACOSH,ASINH等)、指数関数(EXP)、対数関数(LOG)等定数計算として副プログラムで円周率(π)、ネイピア数(e)、log(2)等を定義しています。また、ガウス・ルジャンドル則(有限区間:-1～1)、ガウス・ラゲール則(半無限区間:0～∞)、ガウス・エルミート則(無限区間:-∞～∞)等を使用し高精度数値積分をサポートしました。 #214 #215 #216 これは、1000桁モード等で使用するためにその零点及び重み係数を1000桁等の精度で算出し次数も1000次(1000点)等という超高精度で数値積分を行おうというものです。但し、DATA文として記述するにはサイズが大きすぎるため、データはファイルからの読み出しになります。 (1000桁で零点と重み係数がそれぞれ1000点では2MB近いファイルサイズになります) ガウス・ルジャンドル則で被積分関数 f(x)=1/(1+x*x) を積分区間A～Bで数値積分します。 OPTION ARITHMETIC DECIMAL_HIGH LET N=1000 !次数 LET A=0 !下限 LET B=1 !上限 !'INPUT B LET U=(B+A)/2 LET V=(B-A)/2 OPEN #1:NAME "..\data\legendre1000_"&STR$(N)&".txt" FOR I=1 TO N LINE INPUT #1:X$ LINE INPUT #1:W$ LET X=VAL(X$) LET WEIGHT=VAL(W$) LET S=S+F(U+V*X)*V*WEIGHT NEXT I PRINT S*4 !ATN(B) PRINT PI END EXTERNAL FUNCTION F(X) OPTION ARITHMETIC DECIMAL_HIGH LET F=1/(1+X*X) END FUNCTION 実行結果 3.141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408128481117450284102701938521105559644622948954930381964428810975665933446128475648233786783165271201909145648566923460348610454326648213393607260249141273724587006606315588174881520920962829254091715364367892590360011330530548820466521384146951941511609433057270365759591953092186117381932611793105118548074462379962749567351885752724891227938183011949129833673362440656643086021394946395224737190702179860943702770539217176293176752384674818467669405132000568127145263560827785771342757789609173637178721468440901224953430146549585371050792279689258923542019956112129021960864034418159813629774771309960518707211349999998372978049951059731732816096318595024459455346908302642522308253344685035261931188171010003137838752886587533208381420617177669147303598253490428755468731159562863882353787593751957781857780532171226806613001927876611195909216420198938095324 3.141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408128481117450284102701938521105559644622948954930381964428810975665933446128475648233786783165271201909145648566923460348610454326648213393607260249141273724587006606315588174881520920962829254091715364367892590360011330530548820466521384146951941511609433057270365759591953092186117381932611793105118548074462379962749567351885752724891227938183011949129833673362440656643086021394946395224737190702179860943702770539217176293176752384674818467669405132000568127145263560827785771342757789609173637178721468440901224953430146549585371050792279689258923542019956112129021960864034418159813629774771309960518707211349999998372978049951059731732816096318595024459455346908302642522308253344685035261931188171010003137838752886587533208381420617177669147303598253490428755468731159562863882353787593751957781857780532171226806613001927876611195909216420199 注意点として1000桁精度で数値積分を行っても、計算結果も1000桁の精度があるわけではありません。計算結果が既知である場合は、その値と比較して計算精度を確認してください。計算結果が未知である場合は、数値積分を精度を変えて2度(800点と1000点等)行い、どこまで一致しているかで計算精度を確認してください。下記は副プログラムで定義して計算しています。被積分関数 f(x)=exp(-x*x)として無限区間積分をガウス・エルミート則で行っています。例えばファイルに2000桁で係数を求めていれば2000桁までの数値積分ができます。 OPTION CHARACTER BYTE LET KETA=1000 LET N=1000 !次数 OPEN #1:NAME "..\data\hermite1000_"&STR$(N)&".txt" FOR I=1 TO N LINE INPUT #1:X$ LINE INPUT #1:WEIGHT$ CALL LMUL(KETA,X$,X$,W$) !'W=X*X CALL LEXP(KETA,"-"&W$,F$) !'F=EXP(-W) CALL LMUL(KETA,F$,WEIGHT$,S$) !' S=F*WEIGHT CALL LADD(KETA,SS$,S$,TOTAL$) !'TOTAL=SS+S LET SS$=TOTAL$ NEXT I CALL DISPLAY(SS$) ! SQR(PI) END EXTERNAL SUB LEXP(KETA,X$,RESULT$) OPTION CHARACTER BYTE LET B$=REPEAT$(CHR$(32),KETA+100) CALL EXP1000(KETA,X$,B$) FOR I=LEN(B$) TO 1 STEP -1 IF B$(I:I)<="9" AND B$(I:I)>="0" THEN EXIT FOR END IF NEXT I LET RESULT$=B$(1:I) SUB EXP1000(KETA,X$,Y$) IF POS(X$,"/")>0 OR POS(X$,"(")>0 OR X$="" THEN PRINT "ERROR" STOP END IF ASSIGN ".\DLL\exp1000.dll","exp1000" END SUB END SUB EXTERNAL SUB LADD(KETA,X$,Y$,RESULT$) OPTION CHARACTER BYTE LET B$=REPEAT$(CHR$(32),KETA+100) IF X$="" THEN LET X$="0" IF Y$="" THEN LET Y$="0" CALL LADD1000(KETA,X$,Y$,B$) FOR I=LEN(B$) TO 1 STEP -1 IF B$(I:I)<="9" AND B$(I:I)>="0" THEN EXIT FOR END IF NEXT I LET RESULT$=B$(1:I) SUB LADD1000(KETA,X$,Y$,RESULT$) IF POS(X$,"/")>0 OR POS(Y$,"/")>0 OR POS(X$,"(")>0 OR POS(Y$,"(")>0 OR X$="" OR Y$="" THEN PRINT "ERROR" STOP END IF ASSIGN ".\DLL\calc1000.dll","add1000" END SUB END SUB EXTERNAL SUB LSUB(KETA,X$,Y$,RESULT$) OPTION CHARACTER BYTE LET B$=REPEAT$(CHR$(32),KETA+100) IF X$="" THEN LET X$="0" IF Y$="" THEN LET Y$="0" CALL LSUB1000(KETA,X$,Y$,B$) FOR I=LEN(B$) TO 1 STEP -1 IF B$(I:I)<="9" AND B$(I:I)>="0" THEN EXIT FOR END IF NEXT I LET RESULT$=B$(1:I) SUB LSUB1000(KETA,X$,Y$,RESULT$) IF POS(X$,"/")>0 OR POS(Y$,"/")>0 OR POS(X$,"(")>0 OR POS(Y$,"(")>0 OR X$="" OR Y$="" THEN PRINT "ERROR" STOP END IF ASSIGN ".\DLL\calc1000.dll","sub1000" END SUB END SUB EXTERNAL SUB LMUL(KETA,X$,Y$,RESULT$) OPTION CHARACTER BYTE LET B$=REPEAT$(CHR$(32),KETA+100) IF X$="" THEN LET X$="1" IF Y$="" THEN LET Y$="1" CALL LMUL1000(KETA,X$,Y$,B$) FOR I=LEN(B$) TO 1 STEP -1 IF B$(I:I)<="9" AND B$(I:I)>="0" THEN EXIT FOR END IF NEXT I LET RESULT$=B$(1:I) SUB LMUL1000(KETA,X$,Y$,RESULT$) IF POS(X$,"/")>0 OR POS(Y$,"/")>0 OR POS(X$,"(")>0 OR POS(Y$,"(")>0 OR X$="" OR Y$="" THEN PRINT "ERROR" STOP END IF ASSIGN ".\DLL\calc1000.dll","mul1000" END SUB END SUB EXTERNAL SUB DISPLAY(X$) OPTION CHARACTER BYTE LET N=POS(X$,".") IF N>0 THEN FOR I=1 TO N PRINT X$(I:I); IF MOD(I,5)=0 THEN PRINT " "; IF MOD(I,50)=0 THEN PRINT " "; IF MOD(I,100)=0 THEN PRINT NEXT I PRINT END IF FOR I=0 TO LEN(X$)-N STEP 5 PRINT X$(I+N+1:I+N+5);" "; IF MOD(I+5,100)<>0 AND MOD(I+5,50)=0 THEN PRINT " "; IF MOD(I+5,100)=0 THEN PRINT ":";I+5 IF MOD(I+5,1000)=0 THEN PRINT IF MOD(I+5,10000)=0 THEN PRINT NEXT I END SUB パーサーも作ってみました。sin,cos,tan,sqrt,%,^,abs,exp,log,max,acos,sinhなどの関数が使えます。 EXPRESSION1$にはf(x) (1変数) EXPRESSION2$にはg(x,y) (2変数)を EXPRESSION3$にはh(x,y,z) (3変数)の関数定義します。 FUNC$に呼び出す関数を入れます。パラメーターにu,v,w,x,y,zが使用できます。 EXPRESSION1$に被積分関数 1/(1+x*x)を定義し EXPRESSION2$で和を求めています。 OPTION CHARACTER BYTE LET KETA=1000 LET A=0 !下限 LET B=1 !上限 LET U=(B+A)/2 LET V=(B-A)/2 LET EXPRESSION1$="1/(1+x*x)" LET EXPRESSION2$="y+x" LET N=800 OPEN #1:NAME "..\data\legendre1000_"+STRT$(N)+".txt" FOR I=1 TO N LINE INPUT #1:X$ LINE INPUT #1:WEIGHT$ LET FUNC$="f(u+v*x)*v*w" CALL PARSER(KETA,FUNC$,STR$(U),STR$(V),WEIGHT$,X$,"","",EXPRESSION1$,EXPRESSION2$,EXPRESSION3$,OUTPUT$) LET FUNC$="g(x,y)" CALL PARSER(KETA,FUNC$,"","","",OUTPUT$,Y$,"",EXPRESSION1$,EXPRESSION2$,EXPRESSION3$,S$) LET Y$=S$ NEXT I CLOSE #1 CALL PARSER(KETA,"f(x)",U$,V$,W$,S$,Y$,Z$,"4*x",EXP2$,EXP3$,S$) PRINT S$ END EXTERNAL SUB PARSER(KETA,INPUT$,U$,V$,W$,X$,Y$,Z$,EXPRESSION1$,EXPRESSION2$,EXPRESSION3$,OUTPUT$) OPTION CHARACTER BYTE LET B$=REPEAT$(CHR$(32),KETA+100) IF EXPRESSION1$="" THEN LET EXPRESSION1$="x" !' F(X) IF EXPRESSION2$="" THEN LET EXPRESSION2$="x" !' G(X,Y) IF EXPRESSION3$="" THEN LET EXPRESSION3$="x" !' H(X,Y,Z) IF INPUT$="" THEN PRINT "ERROR" STOP END IF IF U$="" THEN LET U$="0" IF V$="" THEN LET V$="0" IF W$="" THEN LET W$="0" IF X$="" THEN LET X$="0" IF Y$="" THEN LET Y$="0" IF Z$="" THEN LET Z$="0" CALL PARSER1000(KETA,LCASE$(INPUT$),U$,V$,W$,X$,Y$,Z$,LCASE$(EXPRESSION1$),LCASE$(EXPRESSION2$),LCASE$(EXPRESSION3$),B$) IF B$(1:5)="error" THEN PRINT "ERROR!!" STOP ELSE FOR I=LEN(B$) TO 1 STEP -1 IF B$(I:I)<="9" AND B$(I:I)>="0" THEN EXIT FOR END IF NEXT I LET OUTPUT$=B$(1:I) END IF SUB PARSER1000(KETA,INPUT$,U$,V$,W$,X$,Y$,Z$,EXP1$,EXP2$,EXP3$,OUTPUT$) ASSIGN ".\DLL\parser1000_3.dll","parser1000" END SUB END SUB

Re: 多倍長計算

投稿者：しばっち投稿日：2020年 1月 5日(日)19時08分52秒

> No.4760[元記事へ] なお、係数算出にはコンソールアプリですが作成しました。 win32版、win64版を用意しました。 --------------------------------------------------------------------- legendre.cpp #include <iostream> #include <iomanip> #include <string> #include <cstdio> #include <boost/multiprecision/mpfr.hpp> #pragma comment(lib, "mpir.lib") #pragma comment(lib, "mpfr.lib") using namespace std; using namespace boost::multiprecision; int flg=0; mpfr_float eps; void derivative(int n,mpfr_float *a,mpfr_float *b) { int i; for(i=0; i<=n; i++) b[i]=0.0; for(i=n; i>=1; i--) b[i-1]=(mpfr_float)i*a[i]; } void div(int n,mpfr_float *a,mpfr_float p) { mpfr_float *c; c=new mpfr_float [n+1]; int i; for(i=0; i<=n; i++) c[i]=0.0; for(i=n; i>=1; i--) c[i-1]=a[i]+c[i]*p; for(i=0; i<=n; i++) a[i]=c[i]; delete [] c; } void legendrepoly(int kk,mpfr_float *newp) { mpfr_float *p,*oldp; p=new mpfr_float [kk+1]; oldp=new mpfr_float [kk+1]; int k,j,i; for(i=0; i<=kk; i++) { newp[i]=0.0; p[i]=0.0; oldp[i]=0.0; } oldp[0]=1.0; p[1]=1.0; for(k=2; k<=kk; k++) { for(j=1; j<=k; j++) { newp[j]=newp[j]+((mpfr_float)2.0*(mpfr_float)k-1.0)/(mpfr_float)k*p[j-1]; newp[j-1]=newp[j-1]-((mpfr_float)k-1.0)/(mpfr_float)k*oldp[j-1]; } if(k<kk) for(i=0; i<=k; i++) { oldp[i]=p[i]; p[i]=newp[i]; newp[i]=0.0; } } delete [] p; delete [] oldp; } mpfr_float horner(int n,mpfr_float *a,mpfr_float xx) { int i; mpfr_float y; y=a[n]; for(i=n-1; i>=0; i--) y=y*xx+a[i]; return y; } mpfr_float legendre(int k,mpfr_float x) { mpfr_float oldp,newp,p; int n; oldp=1.0; p=x; for(n=1; n<=k-1; n++) { newp=((2.0*(mpfr_float)n+1.0)*x*p-(mpfr_float)n*oldp)/((mpfr_float)n+1.0); oldp=p; p=newp; } return p; } mpfr_float legendrediff(int n,mpfr_float x) { return ((mpfr_float)n*x*legendre(n,x)-(mpfr_float)n*legendre(n-1,x))/(x*x-(mpfr_float)1.0); } mpfr_float weight(int n,mpfr_float x) { mpfr_float s; s=(mpfr_float)n*legendre(n-1,x); return (mpfr_float)2.0*(1.0-x*x)/s/s; } void legendrepara(int n,mpfr_float *a,mpfr_float *w) { mpfr_float *p,*d,x,xx; p=new mpfr_float [n+1]; d=new mpfr_float [n+1]; int i,j; for(i=0; i<=n; i++) { p[i]=0.0; d[i]=0.0; } legendrepoly(n,p); for(i=1; i<=(n+1)/2; i++) { if (flg==0) cerr << "あと " << (n+1)/2-i << endl; if (n % 2==1 && i==(n+1)/2) { a[(n+1)/2]=0.0; w[(n+1)/2]=weight(n,0.0); } else { for(j=n; j>=0; j--) if (p[j]!=0.0) break; for(int k=0; k<j; k++) p[k]/=p[j]; p[j]=1.0; derivative(n,p,d); xx=-1.0; for(j=0; j<1000; j++) { x=xx; xx=x-horner(n,p,x)/horner(n,d,x); if (fabs(x-xx)<eps) break; } a[i]=xx; a[n-i+1]=-xx; w[i]=weight(n,xx); w[n-i+1]=w[i]; div(n,p,xx); } } delete [] p; delete [] d; } int main(int argc, char *argv[]) { int keta=0,prec=0,maxlevel=0; if (argc==4 || argc==5) { keta=atoi(argv[1]); prec=atoi(argv[2]); maxlevel=atoi(argv[3]); } else { cerr << "計算精度(桁) "; cin >> keta; cerr << "出力精度(桁) "; cin >> prec; cerr << "求める次数 "; cin >> maxlevel; } if (argc==5) flg=1; if (keta<=0) keta=100; if (prec<=0) prec=16; if (maxlevel<=0) maxlevel=20; mpfr_float::default_precision(keta); mpfr_float *x,*w; eps=pow(10.0,-prec); x=new mpfr_float [maxlevel+1]; w=new mpfr_float [maxlevel+1]; legendrepara(maxlevel,x,w); for(int i=1; i<=maxlevel; i++) { if (prec<=32) cout << std::scientific << setprecision(prec+1) << x[i] << " , " << w[i] << endl; else { cout << std::scientific << setprecision(prec+1) << x[i] << endl; cout << std::scientific << setprecision(prec+1) << w[i] << endl; } } cout << endl; delete [] x; delete [] w; return 0; } バッチファイル(.bat)を作成すると簡単です。標準出力に書き出すのでリダイレクトします。 makedata.bat legendre 2000 1008 500 > legendre1000_500.txt legendre 2000 1008 800 > legendre1000_800.txt legendre 2000 1008 1000 > legendre1000_1000.txt legendre 2000 1008 1200 > legendre1000_1200.txt 計算精度や出力精度、次数を指定します。ニュートン法を使用し、出力精度分収束したらループを打ち切るようにしています。誤差が累積していくので計算精度は出力精度以上(出力精度の2倍近く)で計算させます。 laguerre 128 16 8 > laguerre16_8.txt laguerre 128 16 15 > laguerre16_15.txt laguerre 128 16 20 > laguerre16_20.txt のように出力精度16桁にすると2進モード、10進モードでも利用できます。 ※計算精度を高めにしています。 legendre 4000 2000 1500 * > legendre2000_1500.txt のように次数指定のあとに何か書くと残数表示しません。時間がかかりすぎる等途中で止めたい時は、CTRL+C で実行中断します。次にライブラリーを呼び出しているだけで計算方法は全く不明なのですが... OPTION CHARACTER BYTE !!LET KETA=100000000 !1億桁 LET KETA=1000000 !100万桁 LET T=TIME CALL PI1000(KETA,RESULT$) PRINT TIME-T OPEN #1:NAME "pi.txt" ERASE #1 PRINT #1:RESULT$ CLOSE #1 END EXTERNAL SUB PI1000(KETA,RESULT$) OPTION CHARACTER BYTE LET B$=REPEAT$(CHR$(32),KETA+100) CALL PI_CALC(KETA,B$) IF B$(1:5)="error" THEN PRINT "ERROR" STOP ELSE FOR I=LEN(B$) TO 1 STEP -1 IF B$(I:I)<="9" AND B$(I:I)>="0" THEN EXIT FOR END IF NEXT I LET RESULT$=B$(1:I) END IF SUB PI_CALC(KETA,X$) ASSIGN ".\DLL\pi1000_2.dll","pi1000" END SUB END SUB ------------------------------------------------------------------ pi1000_2.cpp #include <string> #include <mpreal.h> #include <sstream> #pragma comment(lib, "mpir.lib") #pragma comment(lib, "mpfr.lib") using namespace std; using mpfr::mpreal; extern "C" __declspec(dllexport) void pi1000(int keta,char *b) { mpreal::set_default_prec(mpfr::digits2bits(keta)); string s; ostringstream oss; try { const mpreal pi=mpfr::const_pi(); oss.precision(keta); oss << pi; s=oss.str(); } catch (...) { s="error"; } strcpy(b,s.c_str()); } 桁数に1億桁の指定ができます。(mpreal型) (※mpfr_float型ではどうやら400万桁程で打ち切りのようです。未確認) BASICAcc(x64版)で 712.827秒実行するとおよそ100MB程のファイル(pi.txt)ができました。なお、BASIC(x86版)だと 1687.12秒かかりました。今回は64ビット版(BASICAcc.exe)がリリースされましたので BASICAcc(x64)用にx64版DLL 及び 32ビット版BASIC用にx86版DLLを公開します。 x64版はVC++2019(x64)でx86版はVC++2012(x86)でコンパイルしています。 BASICAccには1000桁モードはありませんので副プログラム定義のみです。 32ビット版BASICには1000モード用の関数定義と副プログラム定義を入れています。下記からダウンロードしてください。 ●BASICAcc(win64) x64版 (multi precision(x64).zip) https://5.gigafile.nu/0305-cf927d401fe60d0851521225f84509659 ダウンロード期限：2020年3月5日(木) ダウンロードパスワード：未設定 ●BASIC(win32) x86版 (multi precision(x86).zip) https://5.gigafile.nu/0305-c438fcda253ac5ecae0510162529420fc ダウンロード期限：2020年3月5日(木) ダウンロードパスワード：未設定解凍してできたdataフォルダやdllフォルダ、mpir.dll,mpfr.dll,libgmp-10.dll,libmpfr-4.dll,libmpc-3.dll等は BASIC.exe(x86) 又はBASICAcc.exe(x64)と同じフォルダに入れてください。実行時にmpir.dll,mpfr.dll 又はlibgmp-10.dll,libmpfr-4.dll,libmpc-3.dllが必要です(x86版とx64版があります) BASICAcc1202(x64)ではコンパイルするとoutputフォルダに実行ファイルが出力されるためエラーが出ます。そのまま終了させてoutputフォルダから取り出してから実行し直してください。

ミラーラビン素数判定法

投稿者：しばっち投稿日：2020年 1月15日(水)19時11分58秒

ミラーラビン素数判定法を追加しました。 OPTION CHARACTER BYTE LET NUM=10 FOR I=2 TO 1000 LET N$=STR$(I) PRINT I;":"; LET L=ISPRIME2(N$,NUM) SELECT CASE L CASE 0 PRINT "合成数" CASE 1 PRINT "確率的素数" CASE 2 PRINT "確定的素数" END SELECT NEXT I END EXTERNAL FUNCTION ISPRIME2(N$,NUM) OPTION CHARACTER BYTE ASSIGN ".\DLL\isprime2.dll","isprime" END FUNCTION ------------------------------------------------------------------------------------ isprime2.cpp #include <mpirxx.h> #pragma comment(lib, "mpir.lib") using namespace std; mpz_class atompz(char *str) { mpz_class result = 0; while (*str>='0' && *str<='9') { result=(result*10)+(*str++ - '0'); } return result; } extern "C" __declspec(dllexport) int isprime(char *x,int num) { int m; mpz_class n; n=atompz(x); m=mpz_probab_prime_p(n.get_mpz_t(), num); // convert mpz_class to mpz_t return m; } 有理数モードで「色々」な素数を求めてみました。 !'メルセンヌ素数(2^n-1) !'n=2, 3, 5, 7, 13, 17, 19, 31, 61, 89, 107, 127, 521, 607, 1279, 2203, 2281, 3217, 4253, 4423, 9689, 9941 !'階乗素数(n! + 1) !'n = 1 2 3 11 27 37 41 73 77 116 154 320 340 399 427 872 !'階乗素数(n! - 1) !'n = 3 4 6 7 12 14 30 32 33 38 94 166 324 379 469 546 OPTION CHARACTER BYTE OPTION ARITHMETIC RATIONAL FOR I=2 TO 1000 !' LET A$=STR$(3^I-2) !' 2 4 5 6 9 22 37 41 90 102 105 317 520 541 561 648 780 786 957 1353 2224 2521 !' LET A$=STR$(5^I-2) !' 2 14 26 50 126 144 260 624 !' LET A$=STR$(5^I-4) !' 5 7 15 47 81 115 267 285 LET A$=STR$(2^I-1) !' 2 3 5 7 13 17 19 31 61 89 107 127 521 607 1279 2203 2281 3217 4253 4423 9689 9941 !' LET A$=STR$(7^I-2) !' 1 2 4 7 8 12 15 28 31 84 98 128 238 302 859 1508 1586 2091 !' LET A$=STR$(7^I-6) !' 2 3 6 9 21 25 33 49 54 133 245 255 318 !' LET A$=STR$(11^I-4) !' 1 3 5 21 119 891 IF ISPRIME2(A$,50)>0 THEN PRINT I;LEN(A$);"桁" NEXT I END EXTERNAL FUNCTION ISPRIME2(N$,NUM) OPTION CHARACTER BYTE OPTION ARITHMETIC RATIONAL ASSIGN ".\DLL\isprime2.dll","isprime" END FUNCTION なお、実行時には mpir.dllが別途必要です。(isprime.dllを除く (ISPRIMEDLL.BAS)) 前頁の「多倍長計算」と合わせて一緒にダウンロードしてください。下記からダウンロードしてください。 ●BASICAcc(win64) x64版 (miller-rabin(x64).zip) https://37.gigafile.nu/0315-ce6a5364e26e6e83196ce0dea4186b222 ダウンロード期限：2020年3月15日(日) ダウンロードパスワード：未設定 ●BASIC(win32) x86版 (miller-rabin(x86).zip) https://37.gigafile.nu/0315-c9a355280d5fb4c52e48c947e7209da16 ダウンロード期限：2020年3月15日(日) ダウンロードパスワード：未設定

今週の「算チャレ」問題

投稿者：SECOND 投稿日：2020年 1月16日(木)17時12分11秒

!------------------------------------------- ! http://www.sansu.org/ !第１１２０回問題（１月１６日～１月２４日） ! ! ∠ＡＤＣ＝９０°、ＡＢ＝９cm の四角形ＡＢＣＤ ! 対角線ＡＣをひくと、∠ＢＡＣ＝７０°、∠ＤＡＣ＝５５° ! 辺ＢＣの中点Ｍと頂点Ｄを結んだところ、ＤＭ＝８cm ! 対角線ＡＣの長さは何cm？ !------------------------------------------- OPTION ARITHMETIC COMPLEX SET WINDOW -2,12, -3,11 SET TEXT background "opaque" SET POINT COLOR "red" SET POINT STYLE 7 !-- LET B=0 LET aa=PI/3 LET act=-50 SUB calc LET A=9*EXP(COMPLEX(0,aa)) LET C=intsec2(B,A,10,(B-A)*EXP(COMPLEX(0,PI*70/180))+A) LET M=(B+C)/2 LET ww=(C-A)*EXP(COMPLEX(0,PI*55/180)) LET D=intsec2(A,C,ww+A,ww*COMPLEX(0,1)+C) LET AC=ABS(A-C) LET DM=ABS(D-M) IF i$="" THEN LET aa=aa-(DM-8)*.1 END IF END SUB SUB draw00 SET DRAW mode hidden CLEAR DRAW grid !-- SET LINE COLOR "blue" CALL rect_m3(A,D,.5) PLOT TEXT,AT arc2(B,A,C,.8)+COMPLEX(-.3,-.53) :"70°" PLOT TEXT,AT arc2(C,A,D,.7)+COMPLEX( 0,-.5 ) :"55°" SET LINE COLOR "black" PLOT LINES: A;B;C;D;A;C PLOT LINES: M;D PLOT POINTS: (B+M)/2; (M+C)/2 !-- PLOT TEXT,AT A+COMPLEX( 0, 0) :"A" PLOT TEXT,AT B+COMPLEX(-.3,-.1) :"B" PLOT TEXT,AT C+COMPLEX( .1,-.1) :"C" PLOT TEXT,AT D+COMPLEX( 0, 0) :"D" PLOT TEXT,AT M+COMPLEX( 0,-.5) :"M" !-- SET LINE STYLE 3 PLOT TEXT,AT arch_(A,B, 1)+COMPLEX( 0, 0) :"9cm" PLOT TEXT,AT arch_(D,M,.8)+COMPLEX(-.8,-.8) :STR$(ROUND(DM,2))& "cm" SET LINE STYLE 1 !-- PLOT TEXT,AT COMPLEX(6.2,-1.6) :"AC= "& STR$(AC)& "cm" IF ABS(DM-8)< 1e-14 THEN PLOT TEXT,AT COMPLEX(6.2,-1.6) :"答えを見るには？" !←消す !-- PLOT TEXT,AT -.5, 9.5 :"左ボタンで、Ａ点の旋回(中心B) がドラッグ可。" PLOT TEXT,AT -.5, 8.9 :"十分離れた白地の所で、左ボタンを押し続けると" PLOT TEXT,AT -.5, 8.3 :"題意に沿う様自動変形する。　右ボタン終了。" SET DRAW mode explicit END SUB DO CALL calc CALL draw00 mouse poll x,y,mlb,mrb DO WHILE mlb=0 AND mrb=0 AND 0< act WAIT DELAY .01 !待機中の省電力 mouse poll x,y,mlb,mrb LET z=COMPLEX(x,y) LET i$="A" LET i=ABS(z-A) IF 1< i THEN LET i$="" LOOP IF i$="A" THEN LET aa=ANGLE(x,y) LET act=act+1 LOOP UNTIL mlb=0 AND mrb=1 !-------------------- !　│　直角の印 (幅w) !　├┐ ! B└┴─A !-------------------- SUB rect_m3(A,B,w) local i IF A<>B THEN LET i=w*(A-B)/ABS(A-B) PLOT LINES: B+i; B+i*COMPLEX(1,1); B+i*COMPLEX(0,1) END IF END SUB !------------------------------------------- ! 寸法表示用弓状の線 (返り値：弓の中腹座標) ! A　　 B B＼／A ! ＼_／　　 | | ! A／ B／~＼A ＼B !------------------------------------------- FUNCTION arch_(A,B,h) !h=中腹の膨らみ幅 local C,O,r,i,e LET C=h*(A-B)/ABS(B-A)*COMPLEX(0,1)+(A+B)/2 LET O=fO_(A,B,C) LET r=ABS(A-O) LET e=arg(B-O) IF arg(A-O) > e THEN LET e=e+2*PI FOR i=arg(A-O) TO e STEP .1/r PLOT LINES: r*EXP(COMPLEX(0,i))+O; NEXT i PLOT LINES: r*EXP(COMPLEX(0,e))+O LET arch_=C END FUNCTION !-------------------------- ! 点 A,B,C を通る円の中心 O !-------------------------- DEF fO_(A,B,C)= intsec2((A-B)*COMPLEX(0,1)+(B+A)/2, (B+C)/2, (B+A)/2, (C-B)*COMPLEX(0,1)+(B+C)/2) !-------------------------------------------------------------------------- ! ∠ABC の AB からBC まで中心B 半径r の左回転円弧（返り値：円弧の中腹座標) !-------------------------------------------------------------------------- FUNCTION arc2(A,B,C,r) local w,s,i LET w=arg((C-B)/(A-B)) LET s=r*(A-B)/ABS(A-B) FOR i=0 TO w STEP PI/36 PLOT LINES: s*EXP(COMPLEX(0,i))+B; NEXT i PLOT LINES: s*EXP(COMPLEX(0,w))+B LET arc2=s*EXP(COMPLEX(0,w/2))+B END FUNCTION !--------------------------------------------- ! A＼　／D　　　　　Ｐ交点　 A＼　　　　／D !　　Ｐ交点　　　　／＼　　　　　＼C　B／ ! B／　＼C　　　　／D　A＼　　　　　＼／ !　　　　　　　B／　　　＼C　　　　Ｐ交点 !--------------------------------------------- FUNCTION intsec2(A,B,C,D) local da,ab LET da=im((D-A)/(C-A)) LET ab=im((A-B)/(C-A)) LET intsec2= ab/(da+ab)*(D-B)+B END FUNCTION END

エラー発生につて

投稿者：村上元佑投稿日：2020年 1月23日(木)07時53分17秒

NEC LAVIE win10 デスクトップPCに於いて 1月中旬ごろOSの更新を、行って以後、十進basic をRUNさすと、4分ごろ走行時、メモリ何とかエラーで、シャットダウンしてしまいますメッセイージの表示時間が、ほぼ瞬間なので、読み取れませせん最新版の十進basic Version 7.8.5.4をダウンロードして、動作させても、同様な現象がでます思うにOSに何らかの不具合が有ると思うのですが．．．．もしも、何か対策有れば、教示ください motosuke.muraka@gmail.com

Re: エラー発生につて

投稿者：SHIRAISHI Kazuo 投稿日：2020年 1月23日(木)20時13分34秒

> No.4766[元記事へ] どんなプログラムを動かしても4分経つとエラーが出るのでしょうか。そうではなくて，4分間は黙々と計算し，4分経ったら表示するプログラムだということはないでしょうか。 > NEC LAVIE win10 デスクトップPCに於いて 1月中旬ごろOSの更新を、行って以後、 > 十進basic をRUNさすと、4分ごろ走行時、メモリ何とかエラーで、シャットダウンしてしまいます > > メッセイージの表示時間が、ほぼ瞬間なので、読み取れませせん > > > 最新版の十進basic Version 7.8.5.4をダウンロードして、動作させても、 > 同様な現象がでます > > 思うにOSに何らかの不具合が有ると思うのですが．．．． > > もしも、何か対策有れば、教示ください > > motosuke.muraka@gmail.com

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

パスワードジェネレータ

投稿者：しばっち投稿日：2020年 1月26日(日)10時59分53秒

RANDOMIZE LET A$="0123456789" LET B$="abcdefghijklmnopqrstuvwxyz" LET C$="ABCDEFGHIJKLMNOPQRSTUVWXYZ" LET D$="!#$%&'()=~\|/*-+.?_<>" PRINT "数字のみ(1)" PRINT "アルファベット小文字のみ(2)" PRINT "アルファベット大文字のみ(3)" PRINT "記号のみ(4)" PRINT "数字+アルファベット小文字(5)" PRINT "数字+アルファベット小文字+アルファベット大文字(6)" PRINT "数字+アルファベット小文字+アルファベット大文字+記号(7)" INPUT PROMPT "MODE=":MODE$ IF MODE$="" THEN LET MODE=5 ELSE LET MODE=VAL(MODE$) SELECT CASE MODE CASE 1 LET S$=A$ CASE 2 LET S$=B$ CASE 3 LET S$=C$ CASE 4 LET S$=D$ CASE 5 LET S$=A$&B$ CASE 6 LET S$=A$&B$&C$ CASE 7 LET S$=A$&B$&C$&D$ CASE ELSE LET S$=A$&B$ END SELECT INPUT PROMPT "文字数<(0,RET=任意> =":N$ PRINT FOR J=1 TO 10 IF N$="" OR N$="0" THEN LET N=INT(RND*16)+4 ELSE LET N=VAL(N$) LET L$="" FOR I=1 TO N LET K=INT(RND*LEN(S$))+1 LET L$=L$&S$(K:K) NEXT I PRINT L$ NEXT J END

アナログ時計を作りましょう

投稿者：名無しさん投稿日：2020年 1月26日(日)22時34分11秒

　読者諸兄は、十進ＢＡＳＩＣは時計を作成するのに最適化した言語であることをご存知でしょうか？そもそも、プログラミング言語でアナログ時計を作成しようとすれば、たとえば、秒針の先を指定するのに、　x=r*cos(90-(360/60*theta)) y=r*sin(90-(360/60*theta))　、といったように三角関数を使わなければなりません。　ところが我が十進ＢＡＳＩＣでは、絵定義があるので三角関数を使う必要がありません。　時間計算と度数法の概念だけ理解してればいーので､小学生でも作れます。　以下プログラムコードです。 OPTION ANGLE DEGREES !ウインドウ上部にあるアイコンをクリックすればこれさえも不要 SET WINDOW 100,-100,-100,100 !角座標系をいわゆる時計回りにするためにｘ座標の正負を逆転 SET TEXT JUSTIFY"center","half" !これにより文字配置の微調整を省略できる SET TEXT HEIGHT 12.5 do draw 時計 wait delay .5 loop picture 時計 set draw mode hidden !最下段のexplicitとともに画面のちらつきを消す、ハイスペックなハードなら不要 CALL 枠 call 文字盤全 call 針 set draw mode explicit end picture sub 枠 SET COLOR "black" draw disk with scale(98) SET COLOR "white" draw disk with scale(92) END SUB sub 文字盤全 SET COLOR "black" for q=1to 12 DRAW 文字(q)WITH SHIFT(0,83)*ROTATE(30*q) next Q for q=0to 59 draw 印 with rotate(6*q) next Q END SUB PICTURE 文字(q) PLOT label,AT 0,0:STR$(q) END PICTURE picture 印 !分秒の単位時間を示すために必要 SET LINE width 1 set COLOR "black" PLOT 0,90;0,91.5 !(90°-(... と書かないでも済むように縦描きで描く、以下同様 end picture sub 針 LET t$=time$ LET h=mod(val(t$(1:2)),12) LET m=val(t$(4:5)) !十進Bのtime$は0を充填した hh:mm:ss のフォーマットなのでint,mod関数を使った時間計算が不要! LET s=val(t$(7:8)) DRAW 時針 with rotate(30*h) DRAW 分針 with rotate(06*m) DRAW 秒針 with rotate(06*s) SET COLOR 12 DRAW disk WITH SCALE(8) !Windows7 時計ガジェットで言うところの「dot」 SET COLOR "white" draw disk with scale(2) END SUB PICTURE 時針 SET LINE width 10 set color "red" PLOT 0,0;0,60 END PICTURE PICTURE 分針 SET LINE width 5 SET COLOR "green" PLOT 0,0;0,85 END PICTURE PICTURE 秒針 SET LINE width 1 set COLOR "black" PLOT 0,0;0,90 END PICTURE END 　ねっ、簡単でしょ？　著者は、プログラムの骨格を作るのに１５分でできました（もっとも、どーしても細かい部分を加工したくなるのですべて完成させるのには１時間以上要しましたが）。時針､分針は各１時間、１分単位で動きます。実物のアナログ時計のように滑らかに動かすためには時間単位をもっと細かく設定しなければなりません。逆に時の文字盤の上に5,10,15..と刻む分秒用の文字盤を追加すれば解りやすい、川栄李っちゃんクラスでも読める時計を作ることができます。　著者は、あまりにもイージー過ぎるので長い間これを作るのを拒否してきました。それが作成する気になった理由は、Windows7で愛用してきたアナログ時計ガジェットがWindows10 で(8か？）廃止されてしまったので必要に迫られたためです(マイクロソフトバカヤロコノヤロ)。

初めまして　

投稿者：kikiriri_guest 投稿日：2020年 2月 5日(水)10時06分19秒

visual basic ではない、十進ベーシックの教科書的な、本があれば紹介してほしいです。ベーシック言語の、名著的な本と、入門用の本を御紹介していただければ嬉しいです。

Re: 初めまして　

投稿者：SHIRAISHI Kazuo 投稿日：2020年 2月 5日(水)10時34分27秒

> No.4770[元記事へ] kikiriri_guestさんへのお返事です。 > visual basic ではない、 > 十進ベーシックの教科書的な、本があれば紹介してほしいです。 > ベーシック言語の、名著的な本と、入門用の本を御紹介していただければ嬉しいです。プログラミングの視点で書かれた本だと「Full BASICによる算法通論」 http://www.utp.or.jp/book/b302144.html がいいのですが，品切・重版未定になっています。数学向きの本もありますが，言語全般の習得を目標として書かれていません。十進BASICリンク集から目的に合うものを探してください。 https://decimalbasic.ninja-web.net/link.html BASIC言語の名著として重要なのは Back to Basic: The History, Corruption, and Future of the Language John G. Kemeny (著), Thomas E. Kurtz (著) Addison-Wesley (1985/5/1) https://www.amazon.co.jp/Back-Basic-History-Corruption-Language/dp/0201134330 です。日本語版が啓学出版から出されたのですが，版元消滅で，現在，入手困難です。 https://iss.ndl.go.jp/books/R100000002-I000002059713-00 https://7net.omni7.jp/detail/1100750066 図書館などで探してみてください。

Re: 初めまして　

投稿者：kikiriri_guest 投稿日：2020年 2月 5日(水)11時13分32秒

> No.4771[元記事へ] SHIRAISHI Kazuoさんへのお返事です。 > kikiriri_guestさんへのお返事です。 > > > visual basic ではない、 > > 十進ベーシックの教科書的な、本があれば紹介してほしいです。 > > ベーシック言語の、名著的な本と、入門用の本を御紹介していただければ嬉しいです。 > > > プログラミングの視点で書かれた本だと > 「Full BASICによる算法通論」 > http://www.utp.or.jp/book/b302144.html > がいいのですが，品切・重版未定になっています。 > 数学向きの本もありますが，言語全般の習得を目標として書かれていません。 > 十進BASICリンク集から目的に合うものを探してください。 > https://decimalbasic.ninja-web.net/link.html > 白石先生へ早速の御返信ありがとうございます。探そうとは思うのですが。まずはベーシック言語の入門書。構造化ベーシック、どころか、普通のベーシックもある意味初心者なので、数学に特化したものでなく、プログラミングの入門書のような本、十進ベーシックの、リファレンス書というか、一昔前だと、サンプルのプログラム集とそのプログラムの詳解な解説いり。みたいな本があり自分は田舎者で本屋に雑誌で紹介されているような本も手にしたことがなく今を迎えているので、プログラム作成も超初心者です。これは、tiny basic for windows のページでも明らかです。要するに一から、プログラミング作成へ向けての本を御紹介いただけたらなという甘い考えもあります。この本を読めば、楽しくは入れて、難しい本質的な部分の理解まで行けます、的な本、または何冊かに分かれてもよいので、入門から課題プログラム製作までを見据えたような何冊かの本、ほんと、本の間に関連性があり、理解や知識の幅が広がり、趣味的なツールプログラムが作成できるような、状態になりたいと自分では思っています。身勝手かもしれませんが、御返信いただければとてもうれしいです。し、良かったなと思えます。よろしくお願いします。

Re: 初めまして　

投稿者：白石和夫投稿日：2020年 2月 5日(水)11時34分33秒

> No.4772[元記事へ] kikiriri_guestさんへのお返事です。 > SHIRAISHI Kazuoさんへのお返事です。 > > > kikiriri_guestさんへのお返事です。 > > > > > visual basic ではない、 > > > 十進ベーシックの教科書的な、本があれば紹介してほしいです。 > > > ベーシック言語の、名著的な本と、入門用の本を御紹介していただければ嬉しいです。 > > > > > > プログラミングの視点で書かれた本だと > > 「Full BASICによる算法通論」 > > http://www.utp.or.jp/book/b302144.html > > がいいのですが，品切・重版未定になっています。 > > 数学向きの本もありますが，言語全般の習得を目標として書かれていません。 > > 十進BASICリンク集から目的に合うものを探してください。 > > https://decimalbasic.ninja-web.net/link.html > > > 白石先生へ > 早速の御返信ありがとうございます。 > 探そうとは思うのですが。 > まずはベーシック言語の入門書。 > 構造化ベーシック、どころか、普通のベーシックもある意味初心者なので、数学に特化したものでなく、プログラミングの入門書のような本、十進ベーシックの、リファレンス書というか、 > 一昔前だと、サンプルのプログラム集とそのプログラムの詳解な解説いり。 > みたいな本があり自分は田舎者で本屋に雑誌で紹介されているような本も手にしたことがなく今を迎えているので、プログラム作成も超初心者です。 > これは、tiny basic for windows のページでも明らかです。 > 要するに一から、プログラミング作成へ向けての本を御紹介いただけたらなという甘い考えもあります。この本を読めば、楽しくは入れて、難しい本質的な部分の理解まで行けます、的な本、または何冊かに分かれてもよいので、入門から課題プログラム製作までを見据えたような何冊かの本、ほんと、本の間に関連性があり、理解や知識の幅が広がり、趣味的なツールプログラムが作成できるような、状態になりたいと自分では思っています。 > 身勝手かもしれませんが、御返信いただければとてもうれしいです。し、良かったなと思えます。 > よろしくお願いします。十進BASICにはtutorial.pdfが付属しています。 https://decimalbasic.ninja-web.net/IntelMac.htm でダウンロードすることもできます。何か疑問点がでてきたらこの掲示板や，十進BASIC　QA集 http://hp.vector.co.jp/authors/VA008683/QA.html を参照してください。

Re: 初めまして　

投稿者：kikiriri_guest 投稿日：2020年 2月 5日(水)11時48分12秒

白石和夫さんへのお返事です。 > kikiriri_guestさんへのお返事です。 > > > SHIRAISHI Kazuoさんへのお返事です。 > > > > > kikiriri_guestさんへのお返事です。 > > > > > > > visual basic ではない、 > > > > 十進ベーシックの教科書的な、本があれば紹介してほしいです。 > > > > ベーシック言語の、名著的な本と、入門用の本を御紹介していただければ嬉しいです。 > > > > > > > > > プログラミングの視点で書かれた本だと > > > 「Full BASICによる算法通論」 > > > http://www.utp.or.jp/book/b302144.html > > > がいいのですが，品切・重版未定になっています。 > > > 数学向きの本もありますが，言語全般の習得を目標として書かれていません。 > > > 十進BASICリンク集から目的に合うものを探してください。 > > > https://decimalbasic.ninja-web.net/link.html > > > > > 白石先生へ > > 早速の御返信ありがとうございます。 > > 探そうとは思うのですが。 > > まずはベーシック言語の入門書。 > > 構造化ベーシック、どころか、普通のベーシックもある意味初心者なので、数学に特化したものでなく、プログラミングの入門書のような本、十進ベーシックの、リファレンス書というか、 > > 一昔前だと、サンプルのプログラム集とそのプログラムの詳解な解説いり。 > > みたいな本があり自分は田舎者で本屋に雑誌で紹介されているような本も手にしたことがなく今を迎えているので、プログラム作成も超初心者です。 > > これは、tiny basic for windows のページでも明らかです。 > > 要するに一から、プログラミング作成へ向けての本を御紹介いただけたらなという甘い考えもあります。この本を読めば、楽しくは入れて、難しい本質的な部分の理解まで行けます、的な本、または何冊かに分かれてもよいので、入門から課題プログラム製作までを見据えたような何冊かの本、ほんと、本の間に関連性があり、理解や知識の幅が広がり、趣味的なツールプログラムが作成できるような、状態になりたいと自分では思っています。 > > 身勝手かもしれませんが、御返信いただければとてもうれしいです。し、良かったなと思えます。 > > よろしくお願いします。 > > 十進BASICにはtutorial.pdfが付属しています。 > https://decimalbasic.ninja-web.net/IntelMac.htm > でダウンロードすることもできます。 > 何か疑問点がでてきたらこの掲示板や，十進BASIC　QA集 > http://hp.vector.co.jp/authors/VA008683/QA.html > を参照してください。 > > 十進BASICにはtutorial.pdfが付属しています。 > https://decimalbasic.ninja-web.net/IntelMac.htm > でダウンロードすることもできます。白石先生へ早速の御返信ありがとうございました。上記のように、チュートリアルのページに飛べないので、pdfのファイルを見ることもダウンロードすることもできません。たすけていただけないですか。 tutorial.pdfのホームページに飛べません。なのでダウンロードもできないのですが、助けていただけないでしょうか。

Re: 初めまして　

投稿者：白石和夫投稿日：2020年 2月 5日(水)12時48分4秒

> No.4774[元記事へ] kikiriri_guestさんへのお返事です。 > 白石和夫さんへのお返事です。 > > > kikiriri_guestさんへのお返事です。 > > > > > SHIRAISHI Kazuoさんへのお返事です。 > > > > > > > kikiriri_guestさんへのお返事です。 > > > > > > > > > visual basic ではない、 > > > > > 十進ベーシックの教科書的な、本があれば紹介してほしいです。 > > > > > ベーシック言語の、名著的な本と、入門用の本を御紹介していただければ嬉しいです。 > > > > > > > > > > > > プログラミングの視点で書かれた本だと > > > > 「Full BASICによる算法通論」 > > > > http://www.utp.or.jp/book/b302144.html > > > > がいいのですが，品切・重版未定になっています。 > > > > 数学向きの本もありますが，言語全般の習得を目標として書かれていません。 > > > > 十進BASICリンク集から目的に合うものを探してください。 > > > > https://decimalbasic.ninja-web.net/link.html > > > > > > > 白石先生へ > > > 早速の御返信ありがとうございます。 > > > 探そうとは思うのですが。 > > > まずはベーシック言語の入門書。 > > > 構造化ベーシック、どころか、普通のベーシックもある意味初心者なので、数学に特化したものでなく、プログラミングの入門書のような本、十進ベーシックの、リファレンス書というか、 > > > 一昔前だと、サンプルのプログラム集とそのプログラムの詳解な解説いり。 > > > みたいな本があり自分は田舎者で本屋に雑誌で紹介されているような本も手にしたことがなく今を迎えているので、プログラム作成も超初心者です。 > > > これは、tiny basic for windows のページでも明らかです。 > > > 要するに一から、プログラミング作成へ向けての本を御紹介いただけたらなという甘い考えもあります。この本を読めば、楽しくは入れて、難しい本質的な部分の理解まで行けます、的な本、または何冊かに分かれてもよいので、入門から課題プログラム製作までを見据えたような何冊かの本、ほんと、本の間に関連性があり、理解や知識の幅が広がり、趣味的なツールプログラムが作成できるような、状態になりたいと自分では思っています。 > > > 身勝手かもしれませんが、御返信いただければとてもうれしいです。し、良かったなと思えます。 > > > よろしくお願いします。 > > > > 十進BASICにはtutorial.pdfが付属しています。 > > https://decimalbasic.ninja-web.net/IntelMac.htm > > でダウンロードすることもできます。 > > 何か疑問点がでてきたらこの掲示板や，十進BASIC　QA集 > > http://hp.vector.co.jp/authors/VA008683/QA.html > > を参照してください。 > > > > > 十進BASICにはtutorial.pdfが付属しています。 > > https://decimalbasic.ninja-web.net/IntelMac.htm > > でダウンロードすることもできます。 > > > 白石先生へ > > 早速の御返信ありがとうございました。 > 上記のように、チュートリアルのページに飛べないので、pdfのファイルを見ることもダウンロードすることもできません。 > たすけていただけないですか。 > > tutorial.pdfのホームページに飛べません。 > なのでダウンロードもできないのですが、助けていただけないでしょうか。 https://www.koshigaya.bunkyo.ac.jp/shiraish/basic/tutorial/contents.htm にもあります

Re: 初めまして　

投稿者：kikiriri_guest 投稿日：2020年 2月 5日(水)12時52分12秒

> No.4775[元記事へ] 白石和夫さんへのお返事です。 > kikiriri_guestさんへのお返事です。 > > > 白石和夫さんへのお返事です。 > > > > > kikiriri_guestさんへのお返事です。 > > > > > > > SHIRAISHI Kazuoさんへのお返事です。 > > > > > > > > > kikiriri_guestさんへのお返事です。 > > > > > > > > > > > visual basic ではない、 > > > > > > 十進ベーシックの教科書的な、本があれば紹介してほしいです。 > > > > > > ベーシック言語の、名著的な本と、入門用の本を御紹介していただければ嬉しいです。 > > > > > > > > > > > > > > > プログラミングの視点で書かれた本だと > > > > > 「Full BASICによる算法通論」 > > > > > http://www.utp.or.jp/book/b302144.html > > > > > がいいのですが，品切・重版未定になっています。 > > > > > 数学向きの本もありますが，言語全般の習得を目標として書かれていません。 > > > > > 十進BASICリンク集から目的に合うものを探してください。 > > > > > https://decimalbasic.ninja-web.net/link.html > > > > > > > > > 白石先生へ > > > > 早速の御返信ありがとうございます。 > > > > 探そうとは思うのですが。 > > > > まずはベーシック言語の入門書。 > > > > 構造化ベーシック、どころか、普通のベーシックもある意味初心者なので、数学に特化したものでなく、プログラミングの入門書のような本、十進ベーシックの、リファレンス書というか、 > > > > 一昔前だと、サンプルのプログラム集とそのプログラムの詳解な解説いり。 > > > > みたいな本があり自分は田舎者で本屋に雑誌で紹介されているような本も手にしたことがなく今を迎えているので、プログラム作成も超初心者です。 > > > > これは、tiny basic for windows のページでも明らかです。 > > > > 要するに一から、プログラミング作成へ向けての本を御紹介いただけたらなという甘い考えもあります。この本を読めば、楽しくは入れて、難しい本質的な部分の理解まで行けます、的な本、または何冊かに分かれてもよいので、入門から課題プログラム製作までを見据えたような何冊かの本、ほんと、本の間に関連性があり、理解や知識の幅が広がり、趣味的なツールプログラムが作成できるような、状態になりたいと自分では思っています。 > > > > 身勝手かもしれませんが、御返信いただければとてもうれしいです。し、良かったなと思えます。 > > > > よろしくお願いします。 > > > > > > 十進BASICにはtutorial.pdfが付属しています。 > > > https://decimalbasic.ninja-web.net/IntelMac.htm > > > でダウンロードすることもできます。 > > > 何か疑問点がでてきたらこの掲示板や，十進BASIC　QA集 > > > http://hp.vector.co.jp/authors/VA008683/QA.html > > > を参照してください。 > > > > > > > > 十進BASICにはtutorial.pdfが付属しています。 > > > https://decimalbasic.ninja-web.net/IntelMac.htm > > > でダウンロードすることもできます。 > > > > > > 白石先生へ > > > > 早速の御返信ありがとうございました。 > > 上記のように、チュートリアルのページに飛べないので、pdfのファイルを見ることもダウンロードすることもできません。 > > たすけていただけないですか。 > > > > tutorial.pdfのホームページに飛べません。 > > なのでダウンロードもできないのですが、助けていただけないでしょうか。 > > https://www.koshigaya.bunkyo.ac.jp/shiraish/basic/tutorial/contents.htm > にもあります > Yahoo!ジオシティーズは終了しましたと、コメントが出てダウンロードできませんでした、十進ベーシックを、USBメモリにダウンロード、保存、展開して、チュートリアル見えるようになりました。よかったですありがとうございました。

ピカチュウ曲線?

投稿者：しばっち投稿日：2020年 2月 5日(水)22時26分26秒

こんな関数がよく定義できたと関心するところです。一体どうやってこの関数を定義した(求めた)のでしょう。AIでも使っているのでしょうか? https://www.wolframalpha.com/input/?i=pikachu+curve&lang=ja 他のポケモンの「関数」もあるようです。 https://www.wolframalpha.com/input/?i=random+pokemon+curve&lang=ja OPTION ARITHMETIC COMPLEX SET WINDOW -600,400,-600,400 DRAW GRID(100,100) FOR T=0 TO 52*PI STEP 1/64 PLOT LINES:X(T),Y(T); IF IM(X(T))>0 OR IM(Y(T))>0 THEN PLOT LINES END IF NEXT T END EXTERNAL FUNCTION X(T) OPTION ARITHMETIC COMPLEX LET X = ((-1/4* SIN(10/7 - 23* T) - 3/10* SIN(4/3 - 22* T) - 2/5 *SIN(7/5 - 19* T) - 1/5* SIN(7/5 - 16* T) - 3/7* SIN(10/7 - 15* T) - 3/8* SIN(13/9 - 9* T) - 19/13* SIN(11/7 - 3* T) + 222/5* SIN(T + 11/7) + 41/2* SIN(2* T + 11/7) + 34/9* SIN(4* T + 11/7) + 1/3* SIN(5* T + 8/5) + 3/8* SIN(6* T + 8/5) + 12/7* SIN(7* T + 13/8) + 11/7* SIN(8* T + 13/8) + 1/4* SIN(10* T + 20/13) + 2/9* SIN(11* T + 16/9) + 3/8* SIN(12* T + 8/5) + 1/3* SIN(13* T + 7/4) + 1/2 *SIN(14* T + 17/10) + 5/7* SIN(17* T + 17/10) + 1/28* SIN(18* T + 9/2) + 1/2* SIN(20* T + 12/7) + 3/7* SIN(21* T + 16/9) + 6/11* SIN(24* T + 7/4) - 979/9)* TH(51*PI - T)* TH(T - 47*PI) + (-6/5* SIN(14/9 - 22* T) - 1/9* SIN(7/5 - 19* T) - 9/8* SIN(14/9 - 18* T) - 1/14* SIN(15/11 - 15* T) - 6/5* SIN(11/7 - 12* T) - 7/6* SIN(11/7 - 8* T) - 29/10* SIN(11/7 - 6* T) - 104/3* SIN(11/7 - 2* T) + 415/18* SIN(T + 11/7) + 71/18* SIN(3* T + 11/7) + 19/8* SIN(4* T + 33/7) + 22/21* SIN(5* T + 8/5) + 3/8* SIN(7* T + 61/13) + 5/9* SIN(9* T + 11/7) + & & 1/8* SIN(10* T + 14/3) + 4/7* SIN(11* T + 11/7) + 4/11* SIN(13* T + 14/3) + 1/7* SIN(14* T + 14/3) + 2/7* SIN(16* T + 5/3) + 1/6* SIN(17* T + 5/3) + 6/7* SIN(20* T + 8/5) + 1/7* SIN(21* T + 5/3) + 1/6* SIN(23* T + 8/5) - 2765/8)* TH(47*PI - T)* TH(T - 43 *PI) + (1189/22* SIN(T + 11/7) + 3/4* SIN(2* T + 13/8) + 11/2* SIN(3* T + 8/5) + 2/7* SIN(4* T + 17/7) + 22/9* SIN(5* T + 18/11) + 1/4 *SIN(6* T + 17/7) + 16/17* SIN(7* T + 20/11) + 1/5* SIN(8* T + 29/9) - 1627/7)* TH(43*PI - T)* TH(T - 39*PI) + (-3/7* SIN(1/18 - 5* T) - 3/4* SIN(1/2 - 3* T) + 109/9* SIN(T + 13/10) + 5/8* SIN(2* T + 11/3) + 5/9* SIN(4* T + 10/3) + 3/10* SIN(6* T + 21/8) + 2/9* SIN(7* T + 2/3) + 1/4 *SIN(8* T + 23/8) - 1190/9)* TH(39*PI - T)* TH(T - 35*PI) + (188/21* SIN(T + 27/28) + 2/5* SIN(2* T + 17/6) + 2/3* SIN(3* T + 91/23) + 3/8* SIN(4* T + 53/18) + 2/11* SIN(5* T + 1/7) - 369)* TH(35*PI - T)* TH(T - 31 *PI) + (-8/9* SIN(1/10 - 12* T) - 34/9* SIN(10/9 - 6* T) - 137/10* SIN(5/7 - 2* T) + 26/5* SIN(T + 13/4) & & + 118/5* SIN(3* T + 11/8) + 43/8* SIN(4* T + 13/7) + 49/6* SIN(5* T + 11/12) + 22/5* SIN(7* T + 13/4) + 17/16* SIN(8* T + 1/7) + 5/4* SIN(9* T + 1/4) + 5/7* SIN(10* T + 17/5) + 29/15* SIN(11* T + 5/6) - 1915/8)* TH(31*PI - T)* TH(T - 27*PI) + (-2/7 *SIN(10/7 - 7* T) - SIN(1/27 - 4* T) + 68/7* SIN(T + 44/15) + 76/9* SIN(2* T + 37/10) + 30/7* SIN(3* T + 1) + 8/9* SIN(5* T + 3/2) + 4/5* SIN(6* T + 31/8) + 3/7* SIN(8* T + 10/3) + 6/13* SIN(9* T + 8/7) + 1/3* SIN(10* T + 31/9) - 2135/9)* TH(27*PI - T)* TH(T - 23*PI) + (-3/8* SIN(1/4 - 23* T) - 3/5* SIN(1/8 - 22* T) - 13/8* SIN(5/4 - 20* T) - 9/7* SIN(3/2 - 16* T) - 41/5* SIN(4/3 - 4* T) + 768/7* SIN(T + 11/5) + 109/5* SIN(2* T + 16/7) + 150/13* SIN(3* T + 11/6) + 33/7* SIN(5* T + 97/24) + 23/4* SIN(6* T + 5/7) + 69/7* SIN(7* T + 9/8) + 32/5* SIN(8* T + 21/5) + 7/6* SIN(9* T + 22/9) + 28/5* SIN(10* T + 5/6) + 43/10* SIN(11* T + 26/7) + 14/9* SIN(12* T + 5/11) + 13/9* SIN(13* T + 40/9) + 11/6* SIN(14* T + 2/5) + 3/2* SIN(15* T + 17/10) & & + 7/11* SIN(17* T + 4/3) + 3/8* SIN(18* T + 31/10) + 4/7* SIN(19* T + 14/9) + 6/5* SIN(21* T + 17/7) + 4/7* SIN(24* T + 27/8) + 1006/11) *TH(23*PI - T) *TH(T - 19*PI) + (-63/8* SIN(2/7 - 8* T) - 38/13* SIN(11/9 - 6* T) - 14/5* SIN(1/17 - 4* T) + 77/9* SIN(T + 1/2) + 52/7* SIN(2* T + 10/3) + 22/9* SIN(3* T + 76/17) + 21/8* SIN(5* T + 26/7) + 3* SIN(7* T + 15/8) + 64/7* SIN(9* T + 57/14) + 6* SIN(10* T + 17/6) - 544/7)* TH(19*PI - T) *TH(T - 15*PI) + (-37/10* SIN(4/7 - 5* T) - 3* SIN(3/7 - 3* T) + 24/7* SIN(T + 7/6) + 9/7* SIN(2* T + 2/5) + 31/15* SIN(4* T + 37/8) + 9/5* SIN(6* T + 12/5) + 59/12* SIN(7* T + 13/6) + 15/7* SIN(8* T + 25/8) + 134/15* SIN(9* T + 7/3) + 73/8* SIN(10* T + 1/5) - 4406/11)* TH(15* PI - T)* TH(T - 11*PI) + (236/7* SIN(T + 6/5) + 1/2* SIN(2* T + 47/12) - 627/5)*TH (11*PI - T)*TH(T - 7*PI) + (69/2* SIN(T + 5/6) - 715/2) *TH(7*PI - T) *TH(T - 3* PI) + (-19/9 *SIN(6/5 - 21* T) - 37/10* SIN(7/9 - 19* T) - 23/8* SIN(1 - 17* T) - 16/3* SIN(7/6 - 16* T) & & - 29/5* SIN(1/5 - 9* T) - 919/11* SIN(1/7 - 3* T) + 1573/6* SIN(T + 91/45) + 214/5* SIN(2* T + 33/8) + 421/14* SIN(4* T + 13/8) + 61/6* SIN(5* T + 19/5) + 401/16* SIN(6* T + 43/14) + 511/51* SIN(7* T + 35/8) + 144/7* SIN(8* T + 5/6) + 137/10* SIN(10* T + 25/13) + 18/7* SIN(11* T + 15/7) + 17/9* SIN(12* T + 41/9) + 9/7* SIN(13* T + 13/7) + 29/10 *SIN(14* T + 22/7) + 25/8* SIN(15* T + 1/4) + 12/5 *SIN(18* T + 11/8) + 14/5* SIN(20* T + 27/7) + 13/8* SIN(22* T + 12/7) + 7/6* SIN(23* T + 7/9) + 26/11* SIN(24* T + 23/7) - 1891/8) *TH(3* PI - T)*TH(T + PI))*TH(SQR(SGN(SIN(T/2)))) END FUNCTION EXTERNAL FUNCTION Y(T) OPTION ARITHMETIC COMPLEX LET Y = ((-8/11* SIN(11/8 - 22* T) - 1/2* SIN(10/7 - 21* T) + 67/6* SIN(T + 33/7) + 1478/29* SIN(2* T + 11/7) + 3/5* SIN(3* T + 30/7) + 26/3* SIN(4* T + 11/7) + 1/6* SIN(5* T + 13/9) + 30/29* SIN(6* T + 8/5) + 2/5* SIN(7* T + 14/3) + 88/29* SIN(8* T + 8/5) + 1/4* SIN(9* T + 31/7) + 11/8* SIN(10* T + 8/5) + 1/16* SIN(11* T + 9/2) + 1/12* SIN(12* T + 5/4) + 1/10* SIN(13* T + 25/11) + 11/8* SIN(14* T + 18/11) + 2/7* SIN(15* T + 37/8) + 1/6* SIN(16* T + 11/8) + 2/9* SIN(17* T + 5/3) + 1/5* SIN(18* T + 17/10) + 1/13* SIN(19* T + 19/8) + 23/24* SIN(20* T + 12/7) + 7/11* SIN(23* T + 9/5) + 9/7* SIN(24* T + 7/4) - 1538/7)* TH(51* PI - T)* TH(T - 47* PI) + (-2/7* SIN(20/13 - 23* T) - 1/6* SIN(3/2 - 20* T) - 5/7* SIN(20/13 - 17* T) - 1/9* SIN(20/13 - 11* T) - 1/6* SIN(13/9 - 9* T) - 19/6* SIN(17/11 - 3* T) + 263/5* SIN(T + 11/7) + 614/15* SIN(2* T + 11/7) + 87/10* SIN(4* T + 11/7) + 1/7* SIN(5* T + 11/8) + 19/11* SIN(6* T + 11/7) + 7/5* SIN(7* T + 11/7) + 4/3* SIN(8* T + 8/5) & & + 9/5* SIN(10* T + 14/9) + 4/7* SIN(12* T + 8/5) + 3/11* SIN(13* T + 3/2) + 1/8* SIN(14* T + 22/15) + 1/9* SIN(15* T + 12/7) + 6/5* SIN(16* T + 11/7) + 2/9* SIN(18* T + 11/7) + 3/5* SIN(19* T + 8/5) + 1/26* SIN(21* T + 15/11) + 6/7* SIN(22* T + 8/5) - 1867/8)* TH(47* PI - T)* TH(T - 43* PI) + (118/39* SIN(T + 11/7) + 40/7* SIN(2* T + 33/7) + 49/25* SIN(3* T + 14/3) + 12/5* SIN(4* T + 8/5) + 1/9* SIN(5* T + 32/13) + 5/2* SIN(6* T + 13/8) + 2/5* SIN(7* T + 22/5) + 3/4* SIN(8* T + 7/4) - 143/10)* TH(43* PI - T)* TH(T - 39* PI) + (-1/8* SIN(2/3 - 8* T) - 1/2* SIN(7/5 - 2* T) - 246/19* SIN(1/7 - T) + 1/4* SIN(3* T + 33/16) + 1/6* SIN(4* T + 17/6) + 1/5* SIN(5* T + 31/7) + 1/11* SIN(6* T + 50/17) + 1/8* SIN(7* T + 30/7) + 665/6)* TH(39* PI - T)* TH(T - 35* PI) + (-119/10* SIN(7/15 - T) + 2/11* SIN(2* T + 25/7) + 2/9* SIN(3* T + 5/8) + 1/5* SIN(4* T + 33/7) + 1/4* SIN(5* T + 19/10) + 1023/10)* TH(35* PI - T)* TH(T - 31* PI) + (-1/7 *SIN(2/7 - 12* T) - 1/8* SIN(3/10 - 5* T) & & + 25/7* SIN(T + 77/17) + 355/59* SIN(2* T + 41/40) + 27/5* SIN(3* T + 46/15) + 33/7* SIN(4* T + 11/3) + 27/10* SIN(6* T + 13/9) + 5/11* SIN(7* T + 11/5) + 5/8* SIN(8* T + 3) + 8/5* SIN(9* T + 16/15) + 16/15* SIN(10* T + 1/7) + 7/9* SIN(11* T + 12/5) - 862/7)* TH(31* PI - T)* TH(T - 27* PI) + (-1/3* SIN(5/4 - 8* T) - 2/5* SIN(5/9 - 7* T) - 5/7* SIN(11/8 - 5* T) - 7/2* SIN(15/14 - 2* T) + 29/8* SIN(T + 41/10) + 11/6* SIN(3* T + 13/3) + 7/6* SIN(4* T + 1/27) + 2/7* SIN(6* T + 8/7) + 1/9* SIN(9* T + 9/5) + 2/7* SIN(10* T + 1/10) + 201/5)* TH(27* PI - T)* TH(T - 23* PI) + (-4/11* SIN(8/9 - 12* T) - 10/7* SIN(19/13 - 10* T) + 623/3* SIN(T + 10/7) + 39/5* SIN(2* T + 10/11) + 251/9* SIN(3* T + 4/3) + 5/7* SIN(4* T + 4/3) + 61/6* SIN(5* T + 4/3) + 14/9* SIN(6* T + 23/7) + 76/25* SIN(7* T + 9/7) + 3/4* SIN(8* T + 1/4) + 19/5* SIN(9* T + 3/2) + 17/6* SIN(11* T + 6/5) + 13/8* SIN(13* T + 14/13) + 8/9* SIN(14* T + 17/6) + 24/25* SIN(15* T + 1/2) + 1/6* SIN(16* T + 13/8) & & + 5/8* SIN(17* T + 1) + 1/7* SIN(18* T + 18/17) + 6/7* SIN(19* T + 1) + 1/4* SIN(20* T + 4/9) + 2/7* SIN(21* T + 7/5) + 1/3* SIN(22* T + 8/7) + 2/5* SIN(23* T + 1/26) + 2/11* SIN(24* T + 8/7) - 243/8) *TH(23* PI - T) *TH(T - 19* PI) + (-111/10* SIN(4/5 - 9* T) - 12/5* SIN(7/13 - 2* T) + 1/6* SIN(T + 48/11) + 13/8* SIN(3* T + 27/7) + 71/24* SIN(4* T + 6/11) + 22/9* SIN(5* T + 7/2) + 19/7* SIN(6* T + 8/17) + 20/7* SIN(7* T + 34/9) + 55/7* SIN(8* T + 6/5) + 64/9* SIN(10* T + 38/9) + 27/5)* TH(19* PI - T)* TH(T - 15* PI) + (-22/7* SIN(4/3 - 8* T) - 19/7* SIN(20/13 - 6* T) + 38/13* SIN(T + 1/24) + 12/11* SIN(2* T + 5/9) + 26/7* SIN(3* T + 7/9) + 11/5* SIN(4* T + 12/11) + 37/10* SIN(5* T + 17/10) + 51/10* SIN(7* T + 10/3) + 33/4* SIN(9* T + 26/7) + 41/5* SIN(10* T + 9/5) - 27/2)* TH(15* PI - T)*TH(T - 11*PI) + (-172/5* SIN(3/8 - T) + 5/4* SIN(2* T + 7/2) + 2303/24)*TH(11*PI - T)*TH(T - 7*PI) + (441/5 - 455/12* SIN(7/9 - T))*TH(7*PI - T)*TH(T - 3*PI) & & + (-1/3* SIN(1/20 - 18* T) - 7/5* SIN(7/9 - 17* T) - 18/11* SIN(2/5 - 14* T) - 24/5* SIN(1/13 - 9* T) + 2767/7* SIN(T + 11/3) + 229/5* SIN(2* T + 17/7) + 313/8* SIN(3* T + 22/5) + 32/3* SIN(4* T + 22/5) + 169/6* SIN(5* T + 21/8) + 23/7* SIN(6* T + 26/11) + 21/2* SIN(7* T + 5/6) + 55/6* SIN(8* T + 14/5) + 212/13* SIN(10* T + 24/7) + 26/9* SIN(11* T + 9/2) + 16/5* SIN(12* T + 25/6) + 35/17* SIN(13* T + 4/11) + 15/8* SIN(15* T + 7/10) + 2/3* SIN(16* T + 20/9) + 16/7* SIN(19* T + 4/5) + 13/7* SIN(20* T + 29/7) + 14/3 *SIN(21* T + 7/5) + 4/3* SIN(22* T + 7/4) + 12/7* SIN(23* T + 34/33) + 7/4* SIN(24* T + 27/7) - 211/5)*TH(3* PI - T)*TH(T + PI))*TH(SQR(SGN(SIN(T/2)))) END FUNCTION EXTERNAL FUNCTION TH(X) OPTION ARITHMETIC COMPLEX IF IM(X)>0 THEN PLOT LINES ELSE IF RE(X)<0 THEN LET TH=0 ELSE LET TH=1 END IF END IF END FUNCTION

しばっち様のカレンダーを加筆修正いたしました。前編

投稿者：unもといnuもといgnuutera2012 投稿日：2020年 2月 6日(木)01時18分49秒

長文なので、リンク先を掲載いたします。削除予定はありません。 https://blog-imgs-129.fc2.com/y/u/t/yutorinonatuyasumi/20200206010613e37.txt gnuutera2012

Re: しばっち様のカレンダーを加筆修正いたしました。前編

投稿者：unもといnuもといgnuutera2012 投稿日：2020年 2月 6日(木)01時23分57秒

ありがとうございます。やっと、私の環境からも投稿できました。追記いたします。しばっち様の元のプログラムです。 #3481 #3482 unもといnuもといgnuutera2012さんへのお返事です。 > 長文なので、リンク先を掲載いたします。 > 削除予定はありません。 > https://blog-imgs-129.fc2.com/y/u/t/yutorinonatuyasumi/20200206010613e37.txt > > gnuutera2012

Re: エラー発生につて投稿者：SHIRAISHI Kazuo

投稿者：村上元佑投稿日：2020年 2月 6日(木)16時31分27秒

本日、PCを出荷状態に戻したら、直りましたおさわがせ致しました

相談です

投稿者：名無しさん投稿日：2020年 2月 6日(木)18時15分10秒

　ありえないことが起きました。　wait delayステートメントの制御が利かないのです。　以下のソースコードは、３Ｄ空間に交わる２直線を描画したものです。プログのシナリオは、まず３次元座標軸を描画し、次に２本の直線を１本ずつ描画し、２直線の交点をマークする、というものです。因みに２直線の方程式は　　　　　　　　(3x-1)/2=(2-y)=4-z 　　　　　　　　(x-5)/4=y=(3-2z)/3 です。デバッグの最中にどっちがどの直線だかわからなくなったので、wait delayを使って時間差をつけようと思い、ご覧のように２直線の描画の間にwait delayステを挿入しました。ところが期待の時間差は２直線の間には現れず、座標軸描画と１本目の直線の描画の間に現れてしまったのです。すなわち、座標軸描画、wait、２直線の描画、交点の描画、というふうに。HTMLじゃあるまいし。　たぶんこれは十進Ｂのエラーではなく、我がポンコツのsony時代のVAIOのWINDOWS XP SP0　機の起こしたエラーでしょう(泣)。今まで全く経験しなかったバグですから。実は今まで愛用してた64BIT 7機が壊れてしまったので最近コイツに乗り換えたものです。7 8 10の64BIT機ならば我が優秀な十進ＢＡＳＩＣでは起こりえないことなのでしょう。お金もないので上位OSの機種に買い換えることもできません(再び泣)。　このオンボロ機でうまくWAITを挿入させる工夫は、無いものでしょうか？ PUBLIC NUMERIC do,sya(4,4) DIM rx(4,4),ry(4,4),cver(4,4),saki(3,4),a(4),v(4),vp(4),vm(4),m(4,4),p(4),c(3,3),p1(3),p2(3) LET DO=3.14159265358979/180 MAT READ cver DATA 0,0,1,0,1,0,0,0,0,1,0,0,0,0,0,1 call yロオテ(ry,20*do) call xロオテ(rx,30*do) MAT sya=cver*ry*rx CALL black SET WINDOW -5,5,-5,5 CLEAR SET TEXT HEIGHT .324 CALL アクシス read p1(1),p1(2),p1(3),x1,y1,z1 data 1,2,4,2,-3,-1 LET p1(1)=p1(1)/3 LET x1=x1/3 CALL 直線(p1(1),p1(2),p1(3),x1,y1,z1) WAIT DELAY .5 !問題の箇所！ READ p2(1),p2(2),p2(3),x2,y2,z2 DATA 5,0,3,4,1,-3 LET p2(3)=p2(3)/2 LET z2=z2/2 CALL 直線(p2(1),p2(2),p2(3),x2,y2,z2) CALL 連立直線xy不含不定 MAT p=p*sya SET AREA COLOR 1 DRAW disk WITH SCALE(.1)*SHIFT(p(1),p(2)) SUB 連立直線xy不含不定 MAT redim p(3) MAT c=ZER LET c(1,1)=y1 LET p11d=y1*p1(1) LET c(1,2)=-x1 LET p12d=-x1*p1(2) LET c(2,1)=y2 LET p21d=y2*p2(1) LET c(2,2)=-x2 LET p22d=-x2*p2(2) LET c(3,2)=z1 LET p32d=z1*p1(2) LET c(3,3)=-y1 LET p33d=-y1*p1(3) LET p(1)=p12d+p11d LET p(2)=p22d+p21d LET p(3)=p33d+p32d call 連立方程式(c,p) MAT PRINT p MAT redim p(4) end sub SUB 直線(x1,y1,z1,l,m,n) LET a(1)=x1 LET a(2)=y1 LET a(3)=z1 LET v(1)=l LET v(2)=m LET v(3)=n SET LINE width 1 MAT vp=10*v MAT vm=(-10)*v MAT vp=a+vp MAT vm=a+vm MAT vp=vp*sya MAT vm=vm*sya PLOT LINES:vm(1),vm(2);vp(1),vp(2) END SUB END EXTERNAL SUB アクシス DIM saki(3,4),v1(4),v2(4),v3(4),z90(4,4),m(4,4) LET v1(1)=8 LET v2(2)=4.5 LET v3(1)=5 MAT READ z90 DATA 0,0,1,0,0,1,0,0,-1,0,0,0,0,0,0,1 MAT READ saki DATA 0,0,0,1,-.112,-.032,0,1,-.112,.032,0,1 SET LINE width 1 DRAW 三線 WITH sya SET TEXT font"ＭＳゴシック",0 SET TEXT COLOR 1 SET TEXT JUSTIFY"left","top" PLOT label,AT .0,-.048:"Ｏ" CALL 位置ベク傾き(v1,saki) IF v1(1)^2+v1(2)^2>1e-2THEN PLOT AREA:saki(1,1),saki(1,2);saki(2,1),saki(2,2);saki(3,1),saki(3,2) MAT READ saki DATA 0,0,0,1,-.112,-.032,0,1,-.112,.032,0,1 CALL 位置ベク傾き(v2,saki) IF v2(1)^2+v2(2)^2>1e-2THEN PLOT AREA:saki(1,1),saki(1,2);saki(2,1),saki(2,2);saki(3,1),saki(3,2) MAT READ saki DATA 0,0,0,1,-.112,-.032,0,1,-.112,.032,0,1 CALL 位置ベク傾き(v3,saki) IF v3(1)^2+v3(2)^2>1e-2THEN PLOT AREA:saki(1,1),saki(1,2);saki(2,1),saki(2,2);saki(3,1),saki(3,2) PICTURE 三線 SET TEXT FONT"Times New Roman Italic",0 SET TEXT COLOR 3 SET AREA COLOR 6 SET TEXT justify"center","half" PLOT 0,0;v1(1),0 PLOT label,AT v1(1)+.36,0:"x" PLOT 0,0;0,v2(2) PLOT label,AT 0,v2(2)+.24:"y" MAT m=TRANSFORM MAT v1=v1*m MAT v2=v2*m DRAW ゼットジク WITH z90 END PICTURE PICTURE ゼットジク PLOT 0,0;v3(1),0 PLOT label,AT v3(1)+.24,0:"z" MAT m=TRANSFORM MAT v3=v3*m END PICTURE END SUB EXTERNAL SUB 位置ベク傾き(v(),a(,)) DIM m(4,4) LET t=angle(v(1),v(2)) MAT m=IDN LET m(1,1)=COS(t) LET m(1,2)=SIN(t) LET m(2,1)=-SIN(t) LET m(2,2)=COS(t) MAT m=m*SHIFT(v(1),v(2)) MAT a=a*m END SUB external sub 連立方程式(m(,),x()) mat m=inv(m) mat x=m*x end sub external sub yロオテ(m(,),t) MAT m=IDN LET m(1,1)=COS(t) LET m(1,3)=SIN(t) LET m(3,1)=-SIN(t) LET m(3,3)=COS(t) end sub external sub xロオテ(m(,),t) MAT m=IDN LET m(2,2)=COS(t) LET m(2,3)=SIN(t) LET m(3,2)=-SIN(t) LET m(3,3)=COS(t) end sub external sub black SET COLOR MIX(0)0,0,0 SET COLOR MIX(1)1,1,1 CLEAR end sub

補足

投稿者：名無しさん投稿日：2020年 2月 6日(木)18時22分36秒

書き忘れです。先刻のソース、有理数モードで実行したものでした。まあもっとも十進１５桁モードで再実行しても結果は同じでしたが。

Re: 相談です

投稿者：SHIRAISHI Kazuo 投稿日：2020年 2月 6日(木)18時38分31秒

> No.4781[元記事へ] 名無しさんさんへのお返事です。 WAIT DELAYの替わりにCHARACTER INPUT TIMEOUTを使うとどうなりますか。 110 WHEN EXCEPTION IN 120 CHARACTER INPUT TIMEOUT 0.5 :dummy$ 130 USE 140 END WHEN 0.5秒だけ待ってキー入力がないと次に進みます。

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

Re: 相談です

投稿者：名無しさん投稿日：2020年 2月 6日(木)19時17分31秒

> No.4783[元記事へ] SHIRAISHI Kazuoさんへのお返事です。お速い対応！！ > 名無しさんさんへのお返事です。 > WAIT DELAYの替わりにCHARACTER INPUT TIMEOUTを使うとどうなりますか。 > > 110 WHEN EXCEPTION IN > 120 CHARACTER INPUT TIMEOUT 0.5 :dummy$ > 130 USE > 140 END WHEN > > 0.5秒だけ待ってキー入力がないと次に進みます。 > inputしないとエラーになっちゃうから例外処理を入れなきゃならないヤツですよね？やってみます

ご心配ありがとうございました

投稿者：名無しさん投稿日：2020年 2月 7日(金)19時43分47秒

　昨日御示教のアルゴ、ポンコツ機に組んでみました。　見事、効果ゼロでした。　ありがとうございました。

Re: ご心配ありがとうございました

投稿者：SHIRAISHI Kazuo 投稿日：2020年 2月 8日(土)10時58分6秒

> No.4785[元記事へ] 名無しさんさんへのお返事です。 > 　昨日御示教のアルゴ、ポンコツ機に組んでみました。 > 　見事、効果ゼロでした。 > 　ありがとうございました。 > PAUSE文で止めると，どうなりますか。その他，INPUT文やCHRACTER INPUT，LOCATE CHIOCEなどではどうなりますか？

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

しばっち様のカレンダーを加筆修正いたしました。後編

投稿者：unもといnuもといgnuutera2012 投稿日：2020年 2月 9日(日)17時19分18秒

unもといnuもといgnuutera2012さんへのお返事です。しばっち様の元のプログラムに手を加えた、月齢カレンダーの新しいバージョンです。九星、干支、二十八宿付き。元号の期間(明治、大正、昭和、平成、令和、以外はつけておりません。)の訂正済み。リンク先を掲載いたします。 https://blog-imgs-129.fc2.com/y/u/t/yutorinonatuyasumi/20200209163157c33.txt 日の出入り、月の出入り、七十二候、十二直については力が及びませんでした。はがゆいです。 gnuutera2012

Re: しばっち様のカレンダーを加筆修正いたしました。後編

投稿者：unもといnuもといgnuutera2012 投稿日：2020年 2月10日(月)10時53分48秒

十二直の実験です。なかなか面倒くさいです。 https://blog-imgs-129.fc2.com/y/u/t/yutorinonatuyasumi/20200210104824ce6.txt

オイラー法

投稿者：しばっち投稿日：2020年 2月16日(日)12時09分39秒

https://ja.wikipedia.org/wiki/オイラー法 https://ja.wikipedia.org/wiki/ルンゲ＝クッタ法 http://www.yamamo10.jp/yamamoto/lecture/2005/5E/test_2/html/node3.html http://www.caero.mech.tohoku.ac.jp/publicData/Daiguji/Chapter7.pdf https://www.ktech.biz/jp/article/10-ode-1/ https://www.ktech.biz/jp/article/10-ode-2/ !' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=0 !'初期値 LET N=65536 !'分割数 LET H=(XE-XS)/N LET NN=8 DIM XX(NN),YY(NN),A(NN) FOR I=1 TO N LET Y=Y+F(X,Y)*H LET X=X+H IF MOD(I,N/NN)=0 THEN LET K=K+1 LET XX(K)=X LET YY(K)=Y PRINT X;Y;X^2 END IF NEXT I CALL CALC(NN,XX,YY,A) CALL DISPLAY(NN-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=2*X END FUNCTION EXTERNAL SUB CALC(N,XX(),YY(),A()) OPTION BASE 0 DIM C(N),X(N),Y(N) REDIM A(N) LET X(1)=1 FOR I=1 TO N MAT Y=ZER LET Y(0)=1 FOR L=1 TO N MAT C=ZER IF I<>L THEN LET X(0)=-XX(L) FOR J=0 TO N FOR K=0 TO N IF J+K<=N THEN LET C(K+J)=C(K+J)+X(K)*Y(J) NEXT K NEXT J MAT Y=C END IF NEXT L LET H=1 FOR J=1 TO N IF I<>J THEN LET H=H*(XX(I)-XX(J)) END IF NEXT J LET H=YY(I)/H MAT Y=(H)*Y MAT A=A+Y NEXT I END SUB EXTERNAL SUB DISPLAY(N,A()) FOR I=0 TO N IF ABS(A(I))<1E-5 THEN LET A(I)=0 ELSE LET A(I)=NUM(A(I)) END IF NEXT I IF N>1 THEN IF A(I)<>0 THEN LET FLG=1 IF A(N)<0 THEN PRINT "-"; IF ABS(A(N))<>1 THEN PRINT STR$(ABS(A(N)));"*X^";STR$(N); ELSE PRINT "X^";STR$(N); END IF END IF END IF FOR I=N-1 TO 2 STEP-1 IF A(I)<>0 THEN IF A(I)<0 THEN PRINT "-"; LET FLG=1 ELSE IF FLG=1 THEN PRINT "+"; END IF IF ABS(A(I))<>1 THEN LET FLG=1 PRINT STR$(ABS(A(I)));"*X^";STR$(I); ELSEIF ABS(A(I))=1 THEN LET FLG=1 PRINT "X^";STR$(I); END IF END IF NEXT I IF A(1)<>0 THEN IF N>1 THEN IF A(1)<0 THEN PRINT "-"; LET FLG=1 ELSE IF FLG=1 THEN PRINT "+"; END IF END IF IF ABS(A(1))<>1 THEN LET FLG=1 PRINT STR$(ABS(A(1)));"*X"; ELSEIF ABS(A(1))=1 THEN LET FLG=1 PRINT "X"; END IF END IF IF A(0)<>0 THEN IF A(0)<0 THEN PRINT "-"; ELSE IF FLG=1 THEN PRINT "+"; END IF PRINT STR$(ABS(A(0))); END IF PRINT END SUB EXTERNAL FUNCTION NUM(X) LET EPS=1E-5 FOR I=0 TO 4 FOR J=1 TO 99 FOR K=0 TO 1 LET XX=J*ABS(X)*10^I+K*EPS IF ABS(XX)-INT(ABS(XX))<EPS THEN LET NUM=SGN(X)*INT(ABS(XX))/10^I/J EXIT FUNCTION END IF NEXT K NEXT J NEXT I LET NUM=X END FUNCTION

修正オイラー法

投稿者：しばっち投稿日：2020年 2月16日(日)12時10分15秒

!' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=0 !'初期値 LET N=8 !'分割数 LET H=(XE-XS)/N DIM XX(N),YY(N),A(N) FOR I=1 TO N LET Y=Y+F(X+H/2,Y+H/2*F(X,Y))*H LET X=X+H LET XX(I)=X LET YY(I)=Y PRINT X;Y;X^2/2 NEXT I CALL CALC(N,XX,YY,A) CALL DISPLAY(N-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=X END FUNCTION 以下略 EXTERNAL SUB CALC(N,XX(),YY(),A()) END SUB EXTERNAL SUB DISPLAY(N,A()) END SUB EXTERNAL FUNCTION NUM(X) END FUNCTION

中点法

投稿者：しばっち投稿日：2020年 2月16日(日)12時10分52秒

!' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=0 !'初期値 LET N=8 !'分割数 LET H=(XE-XS)/N DIM XX(N),YY(N),A(N) FOR I=1 TO N LET K1=F(X,Y)*H LET Y=Y+H*F(X+H/2,Y+K1/2) LET X=X+H LET XX(I)=X LET YY(I)=Y PRINT X;Y;X^3/3 NEXT I CALL CALC(N,XX,YY,A) CALL DISPLAY(N-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=X^2 END FUNCTION 以下略 EXTERNAL SUB CALC(N,XX(),YY(),A()) END SUB EXTERNAL SUB DISPLAY(N,A()) END SUB EXTERNAL FUNCTION NUM(X) END FUNCTION

テイラー法

投稿者：しばっち投稿日：2020年 2月16日(日)12時11分32秒

!' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=0 !'初期値 LET N=8 !'分割数 LET H=(XE-XS)/N DIM XX(N),YY(N),A(N) FOR I=1 TO N LET Y=Y+H*(F(X,Y)+H/2*(FX(X,Y)+FY(X,Y)*F(X,Y))) LET X=X+H LET XX(I)=X LET YY(I)=Y PRINT X;Y;X^4/4 NEXT I CALL CALC(N,XX,YY,A) CALL DISPLAY(N-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=X^3 END FUNCTION EXTERNAL FUNCTION FX(X,Y) LET H=1/256 LET FX=(F(X-2*H,Y)-8*F(X-H,Y)+8*F(X+H,Y)-F(X+2*H,Y))/(12*H) END FUNCTION EXTERNAL FUNCTION FY(X,Y) LET H=1/256 LET FY=(F(X,Y-2*H)-8*F(X,Y-H)+8*F(X,Y+H)-F(X,Y+2*H))/(12*H) END FUNCTION 以下略 EXTERNAL SUB CALC(N,XX(),YY(),A()) END SUB EXTERNAL SUB DISPLAY(N,A()) END SUB EXTERNAL FUNCTION NUM(X) END FUNCTION

3次テイラー法

投稿者：しばっち投稿日：2020年 2月16日(日)12時12分26秒

!' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=0 !'初期値 LET N=8 !'分割数 LET H=(XE-XS)/N DIM XX(N),YY(N),A(N) FOR I=1 TO N LET Y=Y+H*(F(X,Y)+H/2*(FX(X,Y)+H/3*FXX(X,Y))) LET X=X+H LET XX(I)=X LET YY(I)=Y PRINT X;Y;X^3/3+X^2/2+X NEXT I CALL CALC(N,XX,YY,A) CALL DISPLAY(N-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=X^2+X+1 END FUNCTION EXTERNAL FUNCTION FX(X,Y) LET H=1/256 LET FX=(F(X-2*H,Y)-8*F(X-H,Y)+8*F(X+H,Y)-F(X+2*H,Y))/(12*H) END FUNCTION EXTERNAL FUNCTION FXX(X,Y) LET H=1/256 LET FXX=(FX(X-2*H,Y)-8*FX(X-H,Y)+8*FX(X+H,Y)-FX(X+2*H,Y))/(12*H) END FUNCTION 以下略 EXTERNAL SUB CALC(N,XX(),YY(),A()) END SUB EXTERNAL SUB DISPLAY(N,A()) END SUB EXTERNAL FUNCTION NUM(X) END FUNCTION

ホイン法(2次ルンゲクッタ)

投稿者：しばっち投稿日：2020年 2月16日(日)12時13分16秒

!' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=0 !'初期値 LET N=8 !'分割数 LET H=(XE-XS)/N DIM XX(N),YY(N),A(N) FOR I=1 TO N LET K1=F(X,Y) LET K2=F(X+H,Y+H*K1) LET Y=Y+H*(K1+K2)/2 LET X=X+H LET XX(I)=X LET YY(I)=Y PRINT X;Y;X^3 NEXT I CALL CALC(N,XX,YY,A) CALL DISPLAY(N-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=3*X^2 END FUNCTION 以下略 EXTERNAL SUB CALC(N,XX(),YY(),A()) END SUB EXTERNAL SUB DISPLAY(N,A()) END SUB EXTERNAL FUNCTION NUM(X) END FUNCTION

3次ホイン法

投稿者：しばっち投稿日：2020年 2月16日(日)12時14分1秒

!' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=0 !'初期値 LET N=8 !'分割数 LET H=(XE-XS)/N DIM XX(N),YY(N),A(N) FOR I=1 TO N LET K1=F(X,Y) LET K2=F(X+H/3,Y+H*K1/3) LET K3=F(X+2/3*H,Y+2/3*H*K2) LET Y=Y+H*(K1+3*K3)/4 LET X=X+H LET XX(I)=X LET YY(I)=Y PRINT X;Y;X^2 NEXT I CALL CALC(N,XX,YY,A) CALL DISPLAY(N-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=2*X END FUNCTION 以下略 EXTERNAL SUB CALC(N,XX(),YY(),A()) END SUB EXTERNAL SUB DISPLAY(N,A()) END SUB EXTERNAL FUNCTION NUM(X) END FUNCTION

3次ルンゲクッタ法

投稿者：しばっち投稿日：2020年 2月16日(日)12時14分56秒

!' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=1 !'初期値 LET N=8 !'分割数 LET H=(XE-XS)/N DIM XX(N),YY(N),A(N) FOR I=1 TO N LET K1=F(X,Y) LET K2=F(X+H/2,Y+H/2*K1) LET K3=F(X+H,Y+H*(2*K2-K1)) LET Y=Y+H*(K1+4*K2+K3)/6 LET X=X+H LET XX(I)=X LET YY(I)=Y PRINT X;Y;X^3+3*X^2+X+1 NEXT I CALL CALC(N,XX,YY,A) CALL DISPLAY(N-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=3*X^2+6*X+1 END FUNCTION 以下略 EXTERNAL SUB CALC(N,XX(),YY(),A()) END SUB EXTERNAL SUB DISPLAY(N,A()) END SUB EXTERNAL FUNCTION NUM(X) END FUNCTION

4次ルンゲクッタ法

投稿者：しばっち投稿日：2020年 2月16日(日)12時15分44秒

!' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=0 !'初期値 LET N=8 !'分割数 LET H=(XE-XS)/N DIM XX(N),YY(N),A(N) FOR I=1 TO N LET K1=F(X,Y) LET K2=F(X+H/2,Y+H/2*K1) LET K3=F(X+H/2,Y+H/2*K2) LET K4=F(X+H,Y+H*K3) LET Y=Y+H*(K1+2*K2+2*K3+K4)/6 LET X=X+H LET XX(I)=X LET YY(I)=Y PRINT X;Y;TANH(X) NEXT I CALL CALC(N,XX,YY,A) CALL DISPLAY(N-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=1-Y*Y END FUNCTION 以下略 EXTERNAL SUB CALC(N,XX(),YY(),A()) END SUB EXTERNAL SUB DISPLAY(N,A()) END SUB EXTERNAL FUNCTION NUM(X) END FUNCTION

修正ルンゲクッタ法(クッタの3/8公式)

投稿者：しばっち投稿日：2020年 2月16日(日)12時16分27秒

!' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=0 !'初期値 LET N=8 !'分割数 LET H=(XE-XS)/N DIM XX(N),YY(N),A(N) FOR I=1 TO N LET K1=F(X,Y) LET K2=F(X+H/3,Y+H/3*K1) LET K3=F(X+H*2/3,Y-H/3*K2) LET K4=F(X+H,Y-H*K3) LET Y=Y+H*(K1/8+3*K2/8+3*K3/8+K4/8) LET X=X+H LET XX(I)=X LET YY(I)=Y PRINT X;Y;X^2+X NEXT I CALL CALC(N,XX,YY,A) CALL DISPLAY(N-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=2*X+1 END FUNCTION 以下略 EXTERNAL SUB CALC(N,XX(),YY(),A()) END SUB EXTERNAL SUB DISPLAY(N,A()) END SUB EXTERNAL FUNCTION NUM(X) END FUNCTION

ルンゲクッタ・ギル法

投稿者：しばっち投稿日：2020年 2月16日(日)12時17分10秒

!' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=1 !'初期値 LET N=8 !'分割数 LET H=(XE-XS)/N DIM XX(N),YY(N),A(N) FOR I=1 TO N LET K1=F(X,Y) LET K2=F(X+H/2,Y+K1/2) LET K3=F(X+H/2,Y+(SQR(2)-1)/2*K1+(2-SQR(2))/2*K2) LET K4=F(X+H,Y-SQR(2)/2*K2+(2+SQR(2))/2*K3) LET Y=Y+H/6*(K1+(2-SQR(2))*K2+(2+SQR(2))*K3+K4) LET X=X+H LET XX(I)=X LET YY(I)=Y PRINT X;Y;X^2+X+1 NEXT I CALL CALC(N,XX,YY,A) CALL DISPLAY(N-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=2*X+1 END FUNCTION 以下略 EXTERNAL SUB CALC(N,XX(),YY(),A()) END SUB EXTERNAL SUB DISPLAY(N,A()) END SUB EXTERNAL FUNCTION NUM(X) END FUNCTION

ミルン法

投稿者：しばっち投稿日：2020年 2月16日(日)12時17分53秒

!' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=0 !'初期値 LET N=8 !'分割数 LET H=(XE-XS)/N DIM XX(N),YY(N),A(N) LET K1=F(X,Y) LET K2=F(X+H/2,Y+H/2*K1) LET K3=F(X+H/2,Y+H/2*K2) LET K4=F(X+H,Y+H*K3) LET Y1=Y+H*(K1+2*K2+2*K3+K4)/6 LET X1=X+H LET K1=F(X1,Y1) LET K2=F(X1+H/2,Y1+H/2*K1) LET K3=F(X1+H/2,Y1+H/2*K2) LET K4=F(X1+H,Y1+H*K3) LET Y2=Y1+H*(K1+2*K2+2*K3+K4)/6 LET X2=X1+H LET K1=F(X2,Y2) LET K2=F(X2+H/2,Y2+H/2*K1) LET K3=F(X2+H/2,Y2+H/2*K2) LET K4=F(X2+H,Y2+H*K3) LET Y3=Y2+H*(K1+2*K2+2*K3+K4)/6 LET X3=X2+H FOR I=1 TO N LET Y4=Y+4/3*H*(2*F(X1,Y1)-F(X2,Y2)+2*F(X3,Y3)) LET X4=X3+H LET Y4=Y2+H/3*(F(X2,Y2)+4*F(X3,Y3)+F(X4,Y4)) LET X=X1 LET Y=Y1 LET X1=X2 LET Y1=Y2 LET X2=X3 LET Y2=Y3 LET X3=X4 LET Y3=Y4 LET XX(I)=X LET YY(I)=Y PRINT X;Y;ATN(X) NEXT I CALL CALC(N,XX,YY,A) CALL DISPLAY(N-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=1/(X*X+1) END FUNCTION 以下略 EXTERNAL SUB CALC(N,XX(),YY(),A()) END SUB EXTERNAL SUB DISPLAY(N,A()) END SUB EXTERNAL FUNCTION NUM(X) END FUNCTION

3次アダムス・バッシュフォース法

投稿者：しばっち投稿日：2020年 2月16日(日)12時18分36秒

!' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=1 !'初期値 LET N=8 !'分割数 LET H=(XE-XS)/N DIM XX(N),YY(N),A(N) LET K1=F(X,Y) LET K2=F(X+H/2,Y+H/2*K1) LET K3=F(X+H/2,Y+H/2*K2) LET K4=F(X+H,Y+H*K3) LET Y1=Y+H*(K1+2*K2+2*K3+K4)/6 LET X1=X+H LET K1=F(X1,Y1) LET K2=F(X1+H/2,Y1+H/2*K1) LET K3=F(X1+H/2,Y1+H/2*K2) LET K4=F(X1+H,Y1+H*K3) LET Y2=Y1+H*(K1+2*K2+2*K3+K4)/6 LET X2=X1+H FOR I=1 TO N LET Y3=Y2+H/12*(23*F(X2,Y2)-16*F(X1,Y1)+5*F(X,Y)) LET X3=X2+H LET X=X1 LET Y=Y1 LET X1=X2 LET Y1=Y2 LET X2=X3 LET Y2=Y3 LET XX(I)=X LET YY(I)=Y PRINT X;Y;EXP(X) NEXT I CALL CALC(N,XX,YY,A) CALL DISPLAY(N-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=Y END FUNCTION 以下略 EXTERNAL SUB CALC(N,XX(),YY(),A()) END SUB EXTERNAL SUB DISPLAY(N,A()) END SUB EXTERNAL FUNCTION NUM(X) END FUNCTION

4次アダムス・モルトン法

投稿者：しばっち投稿日：2020年 2月16日(日)12時19分20秒

!' y'=F(x,y) OPTION BASE 0 LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=1 !'初期値 LET N=8 !'分割数 LET H=(XE-XS)/N DIM XX(N),YY(N),A(N) LET K1=F(X,Y) LET K2=F(X+H/2,Y+H/2*K1) LET K3=F(X+H/2,Y+H/2*K2) LET K4=F(X+H,Y+H*K3) LET Y1=Y+H*(K1+2*K2+2*K3+K4)/6 LET X1=X+H LET K1=F(X1,Y1) LET K2=F(X1+H/2,Y1+H/2*K1) LET K3=F(X1+H/2,Y1+H/2*K2) LET K4=F(X1+H,Y1+H*K3) LET Y2=Y1+H*(K1+2*K2+2*K3+K4)/6 LET X2=X1+H LET K1=F(X2,Y2) LET K2=F(X2+H/2,Y2+H/2*K1) LET K3=F(X2+H/2,Y2+H/2*K2) LET K4=F(X2+H,Y2+H*K3) LET Y3=Y2+H*(K1+2*K2+2*K3+K4)/6 LET X3=X2+H FOR I=1 TO N LET K1=F(X3,Y3) LET K2=F(X3+H/2,Y3+H/2*K1) LET K3=F(X3+H/2,Y3+H/2*K2) LET K4=F(X3+H,Y3+H*K3) LET Y4=Y3+H*(K1+2*K2+2*K3+K4)/6 LET X4=X3+H LET Y5=Y4+H/720*(251*F(X4,Y4)+646*F(X3,Y3)-264*F(X2,Y2)+106*F(X1,Y1)-19*F(X,Y)) LET X5=X4+H LET X=X1 LET Y=Y1 LET X1=X2 LET Y1=Y2 LET X2=X3 LET Y2=Y3 LET X3=X4 LET Y3=Y4 LET X4=X5 LET Y4=Y5 LET XX(I)=X LET YY(I)=Y PRINT X;Y;EXP(X) NEXT I CALL CALC(N,XX,YY,A) CALL DISPLAY(N-1,A) END EXTERNAL FUNCTION F(X,Y) !' y'=f(x,y) LET F=Y END FUNCTION 以下略 EXTERNAL SUB CALC(N,XX(),YY(),A()) END SUB EXTERNAL SUB DISPLAY(N,A()) END SUB EXTERNAL FUNCTION NUM(X) END FUNCTION

2階常微分方程式(ルンゲクッタ法)

投稿者：しばっち投稿日：2020年 2月16日(日)12時20分9秒

!' y''=F(x,y,y') DY=y' LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=0 !'初期値 y LET DY=0 !'初期値 y' LET N=8 !'分割数 LET H=(XE-XS)/N FOR I=1 TO N LET J1=H*DY LET K1=H*F(X,Y,DY) LET J2=H*(DY+K1/2) LET K2=H*F(X+H/2,Y+J1/2,DY+K1/2) LET J3=H*(DY+K2/2) LET K3=H*F(X+H/2,Y+J2/2,DY+K2/2) LET J4=H*(DY+K3) LET K4=H*F(X+H,Y+J3,DY+K3) LET X=X+H LET Y=Y+(J1+2*J2+2*J3+J4)/6 LET DY=DY+(K1+2*K2+2*K3+K4)/6 PRINT X,Y;9.80665/2*X*X NEXT I END EXTERNAL FUNCTION F(X,Y,DY) !' y''=f(x,y,y') LET F=9.80665 !' y''=9.80665 END FUNCTION

3階常微分方程式(ルンゲクッタ法)

投稿者：しばっち投稿日：2020年 2月16日(日)12時20分46秒

!' y'''=F(x,y,y',y'') DY=y' DY2=y'' LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=0 !'初期値 y LET DY=0 !'初期値 y' LET DY2=0 !'初期値 y'' LET N=8 !'分割数 LET H=(XE-XS)/N FOR I=1 TO N LET J1=H*DY LET K1=H*DY2 LET L1=H*F(X,Y,DY,DY2) LET J2=H*(DY+K1/2) LET K2=H*(DY2+L1/2) LET L2=H*F(X+H/2,Y+J1/2,DY+K1/2,DY2+L1/2) LET J3=H*(DY+K2/2) LET K3=H*(DY2+L2/2) LET L3=H*F(X+H/2,Y+J2/2,DY+K2/2,DY2+L2/2) LET J4=H*(DY+K3) LET K4=H*(DY2+L3) LET L4=H*F(X+H,Y+J3,DY+K3,DY2+L3) LET X=X+H LET Y=Y+(J1+2*J2+2*J3+J4)/6 LET DY=DY+(K1+2*K2+2*K3+K4)/6 LET DY2=DY2+(L1+2*L2+2*L3+L4)/6 PRINT X,Y;-1/3*EXP(-X)+1/16*EXP(-2*X)+1/48*EXP(2*X)-1/4*X+1/4 NEXT I END EXTERNAL FUNCTION F(X,Y,DY,DY2) !' y'''=f(x,y,y',y'') LET F=-DY2+4*DY+4*Y+X !' y'''+y''-4y'-4y-x=0 END FUNCTION

4階常微分方程式(ルンゲクッタ法)

投稿者：しばっち投稿日：2020年 2月16日(日)12時21分29秒

!' y''''=F(x,y,y',y'',y''') DY=y' DY2=y'' DY3=y''' LET XS=0 !' XS～XEまで LET XE=1 LET X=XS LET Y=0 !'初期値 y LET DY= 1 !'初期値 y' LET DY2=0 !'初期値 y'' LET DY3=-1 !'初期値 y''' LET N=8 !'分割数 LET H=(XE-XS)/N FOR I=1 TO N LET J1=H*DY LET K1=H*DY2 LET L1=H*DY3 LET M1=H*F(X,Y,DY,DY2,DY3) LET J2=H*(DY+K1/2) LET K2=H*(DY2+L1/2) LET L2=H*(DY3+M1/2) LET M2=H*F(X+H/2,Y+J1/2,DY+K1/2,DY2+L1/2,DY3+M1/2) LET J3=H*(DY+K2/2) LET K3=H*(DY2+L2/2) LET L3=H*(DY3+M2/2) LET M3=H*F(X+H/2,Y+J2/2,DY+K2/2,DY2+L2/2,DY3+M2/2) LET J4=H*(DY+K3) LET K4=H*(DY2+L3) LET L4=H*(DY3+M3) LET M4=H*F(X+H,Y+J3,DY+K3,DY2+L3,DY3+M3) LET X=X+H LET Y=Y+(J1+2*J2+2*J3+J4)/6 LET DY=DY+(K1+2*K2+2*K3+K4)/6 LET DY2=DY2+(L1+2*L2+2*L3+L4)/6 LET DY3=DY3+(M1+2*M2+2*M3+M4)/6 PRINT X,Y;SIN(X) NEXT I END EXTERNAL FUNCTION F(X,Y,DY,DY2,DY3) !' y''''=f(x,y,y',y'',y''') LET F=-DY3-DY2-DY !' y''''+y'''+y''+y'=0 END FUNCTION

M階常微分方程式(ルンゲクッタ法)

投稿者：しばっち投稿日：2020年 2月16日(日)12時22分12秒

!' dy^m/dx^m=F(x,dy(0),dy(1),dy(2),...,dy(m-1)) OPTION BASE 0 LET M=5 !'常微分方程式の階数 DIM DY(M-1),J1(M),J2(M),J3(M),J4(M) DIM Y1(M-1),Y2(M-1),Y3(M-1) LET XS=0 !' XS～XEまで LET XE=1 LET N=8 !'分割数 LET H=(XE-XS)/N LET X=XS LET DY(0)=0 !'初期値 y FOR I=1 TO N FOR K=1 TO M-1 LET J1(K)=H*DY(K) NEXT K LET J1(M)=H*F(X,DY) FOR K=1 TO M-1 LET J2(K)=H*(DY(K)+J1(K+1)/2) NEXT K FOR K=0 TO M-1 LET Y1(K)=DY(K)+J1(K+1)/2 NEXT K LET J2(M)=H*F(X+H/2,Y1) FOR K=1 TO M-1 LET J3(K)=H*(DY(K)+J2(K+1)/2) NEXT K FOR K=0 TO M-1 LET Y2(K)=DY(K)+J2(K+1)/2 NEXT K LET J3(M)=H*F(X+H/2,Y2) FOR K=1 TO M-1 LET J4(K)=H*(DY(K)+J3(K+1)) NEXT K FOR K=0 TO M-1 LET Y3(K)=DY(K)+J3(K+1) NEXT K LET J4(M)=H*F(X+H,Y3) LET X=X+H FOR K=0 TO M-1 LET DY(K)=DY(K)+(J1(K+1)+2*J2(K+1)+2*J3(K+1)+J4(K+1))/6 NEXT K PRINT X;DY(0);X^M/FACT(M) NEXT I END EXTERNAL FUNCTION F(X,DY()) !' DY(0)=y , DY(1)=y' , DY(2)=y''... LET F=1 END FUNCTION

PLOT LINES がおかしい

投稿者：島村1243 投稿日：2020年 2月27日(木)10時10分17秒

十進BASIC-v7.8.5.4インストーラ版を、Windows2000(32bit)とWindowsXP(32bit)にインストールして使用しています。 PLOT LINES で黒の横軸線を１本引いた後に、黒曲線と赤曲線を描き終わりました。それに続けて、set line colorで緑を設定し緑の曲線を描いたら、前に描いた黒の横軸線１本の色が緑に変化しました。横軸線は２度書きしていません。プログラムを下記に示しますが、BASICの仕様でしょうか？　状況はどちらのOS上でも同じで、Linux版32bitのv8.0.1.5も同様です。 OPTION ARITHMETIC COMPLEX !*** 計算条件の入力 *********** LET Hz =1 !描画する電源のサイクル数[Hz] LET f = 50 !電源周波数[Hz] LET V=1 !電源電圧[p.u] v=Vcos(wt+fai) LET fai=45 !電源投入位相角[度] LET R=10 !抵抗[Ω] LET L=0.5 !インダクタンス[H] LET C=4.946E-4 !コンデンサ静電容量[F] LET bunkatu =1000 !１[Hz]の分割数設定 !*** ここまで **************** !*** 諸量内部算出 LET j=SQR(-1) LET w=2*PI*f LET fai = RAD(fai) LET dt =1/f/bunkatu !計算微分時間[秒]を設定 LET Nmax=Hz*bunkatu !計算点数 SET WINDOW 0,Nmax,-1.8,1.8 LET Zst=SQR(R^2+(w*L-1/w/C)^2) LET Ist=V/Zst LET alfa = -R / 2 /L LET beta = SQR(1/C /L - alfa^2) LET delta1=alfa+j*beta LET delta2=alfa-j*beta LET K1 =delta1/(delta1-delta2)/(delta1-j*w) LET K2 =delta2/(delta2-delta1)/(delta2-j*w) LET K3 =j*w/(j*w-delta1)/(j*w-delta2) LET H1 =delta1/(delta1-j*w)/(delta1-delta2) LET H2 =delta2/(delta2-j*w)/(delta2-delta1) LET H3 =j*w/(j*w-delta1)/(j*w-delta2) LET ipu_=0 LET Hipu_=0 LET vpu_=V*COS(fai) LET ten_=0 SET LINE COLOR "black" PLOT LINES:0,0;Nmax,0 !<---横軸線を黒で描画 FOR n=0 TO Nmax LET ten=n LET t = n * dt LET wt=w*t LET i1 =K1* EXP(delta1*t) LET i2 =K2* EXP(delta2*t) LET i3 =K3*EXP(j*wt) LET i = EXP(j*fai)*V/L*(i1 +i2 + i3) LET ipu=Re(i)/Ist LET vpu=V*COS(wt+fai) !*** 電圧・電流描画指示 *** SET LINE COLOR "black" PLOT LINES: ten_,vpu_;ten,vpu !電源電圧波形 SET LINE COLOR "red" PLOT LINES: ten_,ipu_;ten,ipu !電流波形 LET ten_=ten LET ipu_=ipu LET vpu_=vpu NEXT N PRINT "【２】電源電圧曲線と実電流曲線を描きました。" PRINT "黒色曲線は印加した電源電圧の波形です。" pause "この描画を保持し、演算子法に基づく実電流の厳密解曲線も描きますか？" FOR n=0 TO Nmax LET ten=n LET t = n * dt LET wt=w*t LET Hi1 =H1* EXP(delta1*t) LET Hi2 =H2* EXP(delta2*t) LET Hi3 =H3*EXP(j*wt) LET Hi = EXP(j*fai)*V/L*(Hi1 +Hi2 + Hi3) LET Hipu=Re(Hi)/Ist !*** 電流描画指示 *** SET LINE COLOR "green" PLOT LINES: ten_,Hipu_;ten,Hipu !電流波形 LET ten_=ten LET Hipu_=Hipu NEXT N PRINT "緑色曲線は変換法による実電流波形です。" END

Re: PLOT LINES がおかしい

投稿者：SHIRAISHI Kazuo 投稿日：2020年 2月27日(木)13時01分32秒

SET LINE COLOR "green" と PLOT LINES: ten_,Hipu_;ten,Hipu !電流波形の間に PRINT ten_,Hipu_,ten,Hipu を挿入して調べてみると最初の行が 1000 0 0 1.04170364486623E-16 となるので，正しく動作していると思います。（前のten_が残っているのが原因） PLOT POINTSを使って SET LINE COLOR "black" PLOT LINES:0,0;Nmax,0 !<---横軸線を黒で描画 SET POINT STYLE 1 FOR n=0 TO Nmax LET ten=n LET t = n * dt LET wt=w*t LET i1 =K1* EXP(delta1*t) LET i2 =K2* EXP(delta2*t) LET i3 =K3*EXP(j*wt) LET i = EXP(j*fai)*V/L*(i1 +i2 + i3) LET ipu=Re(i)/Ist LET vpu=V*COS(wt+fai) !*** 電圧・電流描画指示 *** SET POINT COLOR "black" PLOT POINTS: ten,vpu !電源電圧波形 SET POINT COLOR "red" PLOT POINTS:ten,ipu !電流波形 NEXT N PRINT "【２】電源電圧曲線と実電流曲線を描きました。" PRINT "黒色曲線は印加した電源電圧の波形です。" pause "この描画を保持し、演算子法に基づく実電流の厳密解曲線も描きますか？" FOR n=0 TO Nmax LET ten=n LET t = n * dt LET wt=w*t LET Hi1 =H1* EXP(delta1*t) LET Hi2 =H2* EXP(delta2*t) LET Hi3 =H3*EXP(j*wt) LET Hi = EXP(j*fai)*V/L*(Hi1 +Hi2 + Hi3) LET Hipu=Re(Hi)/Ist !*** 電流描画指示 *** SET POINT COLOR "green" PLOT POINTS: ten,Hipu !電流波形 NEXT N PRINT "緑色曲線は変換法による実電流波形です。" としたほうがアルゴリズム的に簡潔に書けると思います。

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

Re: PLOT LINES がおかしい

投稿者：島村1243 投稿日：2020年 2月27日(木)14時43分19秒

> No.4808[元記事へ] SHIRAISHI Kazuo 先生へのお返事です。 > （前のten_が残っているのが原因）先生のご回答を読み、下記のようにLET ten_=0を追加したら、正常になりました。 pause "この描画を保持し、・・・描きますか？" LET ten_=0 <---これを追加した。 FOR n=0 TO Nmax 以下省略素早いご回答・ご教示を賜り有難う御座いました。

Re: M階常微分方程式(ルンゲクッタ法)

投稿者：島村1243 投稿日：2020年 3月16日(月)14時37分25秒

しばっちさんへのお返事です。 > !' dy^m/dx^m=F(x,dy(0),dy(1),dy(2),...,dy(m-1)) しばっちさんが作られたM階常微分方程式のRungeKutta法プログラムを、RLC直列電気回路の過渡現象解析(M=2)に応用し、厳密解との差がどの程度あるかを確認する下記プログラムを書いてRUNしたら、凄い精度（分割数50程度でも一致）であることが分かりました。しばっちさんの書かれたプログラムは汎用として使えるのでとても良いですね！！ -----以下は確認したプログラムコード---- !しばっちさんの投稿プログラム(数値解法)にグラフ表示を追加し !RLC直列回路に交流電圧vs=V*cos(wt+fai)を投入した場合の過渡電流 !計算に適用し、その数値解とラプラス変換に依る厳密解とを比較したもの。 OPTION BASE 0 OPTION ARITHMETIC COMPLEX !--- RungeKutta法を適用する２階常微分方程式の設定 ----- !RLC直列回路の連立微分方程式は、vcをCの端子電圧、icを電流とすると、 ! L*dic/dt+R*ic+vc=vs と ic=C*dvc/dt !となるので、上記連立方程式をvcの２階微分方程式に纏めたものが下記FUNCTION ! di^m/dt^m=F(t,di(0),di(1),di(2),...,di(m-1))の設定 FUNCTION F(t,DY()) !' DY(0)=i , DY(1)=i' , DY(2)=i''... LET F=V*COS(w*t+fai)/CL-R/L*DY(1)-DY(0)/CL END FUNCTION !--- 共通計算定数・条件の設定 ---- LET M=2 !常微分方程式の階数 LET Ts=0 ![msec] Ts～Teまで計算 LET Te=20 ![msec] LET N=100 !Ts～Teまでの分割数 LET V=1 !投入電圧[p.u.] LET fai=45 !Vの投入位相角[度] LET Hz=50 !Vの周波数[Hz] LET R=10 ![Ω] LET L=0.5 ![H] LET C=4.946E-4 ![F] !---定数の内部処理--- LET Ts=Ts/1000 ![sec]に換算 LET Te=Te/1000 LET CL=C*L LET w=2*PI*Hz LET fai=RAD(fai) LET Im=V/SQR(R^2+(w*L-1/w/C)^2) !定常電流の最大値 SET WINDOW 0,N,-1.8,1.8 PLOT LINES:0,0;N,0 DIM DY(M-1),J1(M),J2(M),J3(M),J4(M) DIM Y1(M-1),Y2(M-1),Y3(M-1) LET h=(Te-Ts)/N LET t=Ts LET DY(0)=0 !'iの初期値 pause "最初に、RungeKutta法による数値解を赤色線で表示します。" SET POINT STYLE 7 SET POINT COLOR "black" PLOT POINTS:0,V*COS(fai) SET POINT COLOR "red" PLOT POINTS:0,DY(0) FOR I=1 TO N FOR K=1 TO M-1 LET J1(K)=h*DY(K) NEXT K LET J1(M)=h*F(t,DY) FOR K=1 TO M-1 LET J2(K)=h*(DY(K)+J1(K+1)/2) NEXT K FOR K=0 TO M-1 LET Y1(K)=DY(K)+J1(K+1)/2 NEXT K LET J2(M)=h*F(t+h/2,Y1) FOR K=1 TO M-1 LET J3(K)=h*(DY(K)+J2(K+1)/2) NEXT K FOR K=0 TO M-1 LET Y2(K)=DY(K)+J2(K+1)/2 NEXT K LET J3(M)=h*F(t+h/2,Y2) FOR K=1 TO M-1 LET J4(K)=h*(DY(K)+J3(K+1)) NEXT K FOR K=0 TO M-1 LET Y3(K)=DY(K)+J3(K+1) NEXT K LET J4(M)=h*F(t+h,Y3) LET t=t+h FOR K=0 TO M-1 LET DY(K)=DY(K)+(J1(K+1)+2*J2(K+1)+2*J3(K+1)+J4(K+1))/6 NEXT K SET POINT COLOR "black" PLOT POINTS:i,V*COS(w*t+fai) LET ic=C*DY(1) SET POINT COLOR "red" PLOT POINTS:i,ic/Im NEXT I !--- ラプラス変換法に依る厳密解計算式 --- pause "続けて、厳密解を緑色線で表示しますか？" LET j=SQR(-1) LET dt =(Te-Ts)/N !計算微分時間[秒]を設定 LET Zst=SQR(R^2+(w*L-1/w/C)^2) LET Ist=V/Zst LET alfa = -R / 2 /L LET beta = SQR(1/C /L - alfa^2) LET delta1=alfa+j*beta LET delta2=alfa-j*beta LET K1 =delta1/(delta1-delta2)/(delta1-j*w) LET K2 =delta2/(delta2-delta1)/(delta2-j*w) LET K3 =j*w/(j*w-delta1)/(j*w-delta2) PRINT "【１】ラプラス変換法により得られた定数を表示します。" PRINT "α=";alfa;" , β=";beta PRINT "K1=";K1 PRINT "K2=";K2 PRINT "K3=";K3 PRINT FOR nn=0 TO N LET t = nn * dt LET wt=w*t LET i1 =K1* EXP(delta1*t) LET i2 =K2* EXP(delta2*t) LET i3 =K3*EXP(j*wt) LET i = EXP(j*fai)*V/L*(i1 +i2 + i3) LET ipu=Re(i)/Ist LET vpu=V*COS(wt+fai) !*** 描画指示 *** SET POINT COLOR "black" PLOT POINTS: nn,vpu !電源波形 SET POINT COLOR "green" PLOT POINTS: nn,ipu !電流波形 NEXT nn PRINT "●黒色曲線は、印加電源電圧の波形です。" PRINT "●数値解と厳密解が一致した場合は、赤色線の上に緑色線が上書き" PRINT "され、緑色線のみが見える事に留意してください。" END

感染が話題なので

投稿者：moonlight 投稿日：2020年 3月17日(火)20時13分44秒

https://www.washingtonpost.com/graphics/2020/world/corona-simulator/?itid=hp_hp-top-table-main_virus-simulator520pm%3Ahomepage/story-ans というワシントンポストのコロナ・シミュレータが気になったので適当にプログラムしてみました。手直しするところか「こうする」と早くなるなど色々教えていただけると有難い。割合などは超適当です。 OPTION ANGLE DEGREES !' 感染シミュレータ RANDOMIZE SET POINT STYLE 7 SET COLOR MIX(9) 1,0.4,0.2 SET COLOR MIX(10) 0.4,1,0.2 LET ppls=100 LET wwd=300 LET wwdy=INT(wwd*0.6) LET wwdyy=wwdy+10 SET WINDOW 0,wwd,0,wwd ! 設定 LET ppls=200 ! 人数 DIM ppl(ppls,10) LET pk=0.05 ! 感染率 LET pl=10 ! 感染から発症　未実装 LET pm=10 ! 発症から治癒 LET dm=150 ! 一日の動数 FOR g=1 TO 100 !' 配置と動き FOR i=1 TO ppls LET x=wwd/10+wwd*8/10*RND LET y=wwd/10+wwdy*8/10*RND DO LET chk=0 FOR j=1 TO i-1 IF (x-ppl(j,1))^2+(y-ppl(j,2))^2<=64 THEN LET chk=1 LET x=wwd/10+wwd*8/10*RND LET y=wwd/10+wwdy*8/10*RND EXIT FOR END IF NEXT j LOOP UNTIL chk=0 LET ppl(i,1)=x LET ppl(i,2)=y LET ppl(i,3)=8 LET ppl(i,4)=360*RND LET ppl(i,5)=RND*pm PRINT "."; IF MOD(i , 10) =0 THEN PRINT NEXT i ! 感染者 LET ks=INT(ppls*0.05) FOR k=1 TO ks DO LET i=INT(RND*ppls)+1 LOOP UNTIL i>0 AND ppl(i,3)=8 LET ppl(i,3)=9 NEXT k !' 描画 SET DRAW MODE HIDDEN FOR i=1 TO ppls !' DRAW disk WITH SCALE(1/2)*SHIFT(ppl(i,1),ppl(i,2)) SET POINT COLOR ppl(i,3) PLOT POINTS: ppl(i,1),ppl(i,2) NEXT I SET DRAW MODE EXPLICIT LET t=0 LET cs=0 DO WHILE ks>0 LET t=t+1 LET tt=MOD(t,wwd*12)/18 PRINT ppls-(ks+cs);ks;cs SET LINE COLOR 8 PLOT LINES : tt,wwdyy;tt,wwdyy+ppls/2 SET LINE COLOR 9 PLOT LINES : tt,wwdyy;tt,wwdyy+ks/2 SET LINE COLOR 10 PLOT LINES : tt,wwdyy+(ppls-cs)/2;tt,wwdyy+ppls/2 SET DRAW MODE HIDDEN FOR i=1 TO ppls SET POINT COLOR 0 PLOT POINTS: ppl(i,1),ppl(i,2) IF RND<1/3 THEN LET r=RND*2 IF ppl(i,1)+COS(ppl(i,4))<wwd/20 THEN LET ppl(i,4)=180-ppl(i,4) ELSEIF ppl(i,1)+COS(ppl(i,4))>19*wwd/20 THEN LET ppl(i,4)=180-ppl(i,4) END IF IF ppl(i,2)+SIN(ppl(i,4))<wwd/20 THEN LET ppl(i,4)=-ppl(i,4) ELSEIF ppl(i,2)+SIN(ppl(i,4))>19*wwdy/20 THEN LET ppl(i,4)=-ppl(i,4) END if LET ppl(i,1)=ppl(i,1)+COS(ppl(i,4))*r/3 LET ppl(i,2)=ppl(i,2)+SIN(ppl(i,4))*r/3 END if IF RND<1/3 THEN LET ppl(i,4)=ppl(i,4)+RND*6-3 END IF NEXT I LET ks=0 FOR i=1 TO ppls IF ppl(i,3)=9 THEN LET ppl(i,5)=ppl(i,5)-1/dm IF ppl(i,5)<0 THEN LET ppl(i,3)=10 LET cs=cs+1 ELSE LET ks=ks+1 LET x=ppl(i,1) LET y=ppl(i,2) FOR j=1 TO ppls IF i<>j THEN IF (x-ppl(j,1))^2+(y-ppl(j,2))^2<=4 AND ppl(j,3)=8 THEN LET ppl(j,3)=9 LET ks=ks+1 END if END IF NEXT j END IF END IF NEXT i FOR i=1 TO ppls SET POINT COLOR ppl(i,3) PLOT POINTS: ppl(i,1),ppl(i,2) NEXT I SET DRAW MODE EXPLICIT LOOP CLEAR NEXT g END

勾配の場(方向場、ベクトル場)

投稿者：しばっち投稿日：2020年 3月29日(日)19時39分6秒

関数 f(x,y)を導関数(傾き)として勾配の場を描画します。 LET XS=-5 LET XE=5 LET YS=-5 LET YE=5 SET WINDOW XS,XE,YS,YE SET COLOR MIX(15) 0,0,0 DRAW AXES LET N=40 LET STX=(XE-XS)/N LET STY=(YE-YS)/N SET LINE COLOR "RED" FOR Y=YS TO YE STEP STY FOR X=XS TO XE STEP STX LET THETA=ATN(F(X,Y)) !'LET THETA=MOD(THETA+2*PI,2*PI) PLOT LINES:X,Y;X+STX*COS(THETA)*.6,Y+STY*SIN(THETA)*.6 !'CALL ARROW(X,Y,X+STX*COS(THETA)*.6,Y+STY*SIN(THETA)*.6) NEXT X NEXT Y END EXTERNAL FUNCTION F(X,Y) !' y'=F(X,Y) 傾き WHEN EXCEPTION IN !'LET F=-X/Y !'LET F=X*X-X-2 !'LET F=Y LET F=Y*Y*X !'LET F=Y*X !'LET F=Y*X*X !'LET F=1/(X*X+1) USE LET F=10000 END WHEN END FUNCTION EXTERNAL SUB ARROW(X1,Y1,X2,Y2) OPTION ANGLE DEGREES PLOT LINES:X1,Y1;X2,Y2 LET TH=180-ANGLE(X1-X2,Y1-Y2) LET L=SQR((X2-X1)^2+(Y2-Y1)^2)/2 LET X3=X2+L*COS(TH+160) LET Y3=Y2-L*SIN(TH+160) LET X4=X2+L*COS(TH-160) LET Y4=Y2-L*SIN(TH-160) PLOT LINES:X2,Y2;X3,Y3 PLOT LINES:X2,Y2;X4,Y4 END SUB -------------------------------------------------------------------------------------------------- 上記関数定義をdx/dt=f(x,y) dy/dt=g(x,y)として勾配の場を描画します。 LET XS=-5 LET XE=5 LET YS=-5 LET YE=5 SET WINDOW XS,XE,YS,YE SET COLOR MIX(15) 0,0,0 DRAW AXES LET N=40 LET STX=(XE-XS)/N LET STY=(YE-YS)/N SET LINE COLOR "RED" FOR Y=YS TO YE STEP STY FOR X=XS TO XE STEP STX WHEN EXCEPTION IN LET M=G(X,Y)/F(X,Y) !' 傾き dy/dx USE LET M=10000*SGN(G(X,Y)) END WHEN LET THETA=ATN(M) !'LET THETA=MOD(THETA+2*PI,2*PI) PLOT LINES:X,Y;X+STX*COS(THETA)*.6,Y+STY*SIN(THETA)*.6 !'CALL ARROW(X,Y,X+STX*COS(THETA)*.6,Y+STY*SIN(THETA)*.6) NEXT X NEXT Y END EXTERNAL FUNCTION F(X,Y) !' dx/dt=f(x,y) LET F=Y END FUNCTION EXTERNAL FUNCTION G(X,Y) !' dy/dt=g(x,y) LET G=-X END FUNCTION

解曲線

投稿者：しばっち投稿日：2020年 3月29日(日)19時40分30秒

関数 f(x,y)を導関数としてルンゲクッタ法で解き、その解曲線群を描画します。 LET XS=-5 LET XE=5 LET YS=-5 LET YE=5 SET WINDOW XS,XE,YS,YE DRAW GRID LET N=100 !'分割数 LET H=(XE-XS)/N FOR YY=YS TO XE FOR XX=XS TO XE FOR I=1 TO 2 LET Y=YY !'初期値 Y LET X=XX !'初期値 X WHEN EXCEPTION IN FOR J=1 TO N LET K1=F(X,Y) LET K2=F(X+H/2,Y+H/2*K1) LET K3=F(X+H/2,Y+H/2*K2) LET K4=F(X+H,Y+H*K3) LET Y0=Y+H*(K1+2*K2+2*K3+K4)/6 LET X0=X+H PLOT LINES:X,Y;X0,Y0 LET X=X0 LET Y=Y0 NEXT J USE PLOT LINES END WHEN LET H=-H !'符号を逆にして反対側(初期値より前側)を描画する NEXT I NEXT XX NEXT YY END EXTERNAL FUNCTION F(X,Y) !'dy/dx=f(x,y) !'LET F=Y !'LET F=Y*Y*X !'LET F=Y*X !'LET F=Y*X*X !'LET F=1/(X*X+1) !'LET F=Y*Y !'LET F=Y*Y*Y LET F=2*X !'LET F=3*X*X !'LET F=-Y/(X+1)^2 !'LET F=-X/Y !うまく描けない END FUNCTION

解曲線

投稿者：しばっち投稿日：2020年 3月29日(日)19時44分8秒

dx/dt=f1(t,x,y) dy/dt=f2(t,x,y)として2元連立常微分方程式をルンゲクッタ法で解き、その解曲線群を描画します。 (※とりあえず同心円が描かれます dy/dx=-X/Y) LET XS=-5 LET XE=5 LET YS=-5 LET YE=5 SET WINDOW XS,XE,YS,YE DRAW GRID LET N=50 !'分割数 LET H=(XE-XS)/N FOR YY=YS TO YE FOR XX=XS TO XE ! FOR I=1 TO 2 LET T=0 !'初期値 T ??? いくつでも変わらない? LET X=XX !'初期値 X LET Y=YY !'初期値 Y WHEN EXCEPTION IN FOR J=1 TO N LET K1=F1(T,X,Y) LET L1=F2(T,X,Y) LET K2=F1(T+H/2,X+H/2*K1,Y+H/2*L1) LET L2=F2(T+H/2,X+H/2*K1,Y+H/2*L1) LET K3=F1(T+H/2,X+H/2*K2,Y+H/2*L2) LET L3=F2(T+H/2,X+H/2*K2,Y+H/2*L2) LET K4=F1(T+H,X+H*K3,Y+H*L3) LET L4=F2(T+H,X+H*K3,Y+H*L3) LET T0=T+H LET X0=X+H*(K1+2*K2+2*K3+K4)/6 LET Y0=Y+H*(L1+2*L2+2*L3+L4)/6 PLOT LINES:X,Y;X0,Y0 LET X=X0 LET Y=Y0 LET T=T0 NEXT J USE PLOT LINES END WHEN ! LET H=-H ! NEXT I NEXT XX NEXT YY END EXTERNAL FUNCTION F1(T,X,Y) !'dx/dt=f1(t,x,y) LET F1=Y END FUNCTION EXTERNAL FUNCTION F2(T,X,Y) !'dy/dt=f2(t,x,y) LET F2=-X END FUNCTION ------------------------------------------------------------------------------------------------ LET XS=-5 LET XE=5 LET YS=-5 LET YE=5 SET WINDOW XS,XE,YS,YE DRAW GRID LET N=100 !'分割数 LET H=(XE-XS)/N FOR YY=YS TO YE STEP 3 FOR XX=XS TO XE STEP 3 FOR I=1 TO 2 LET T=0 !'初期値 T LET X=XX !'初期値 X LET Y=YY !'初期値 Y WHEN EXCEPTION IN FOR J=1 TO N LET K1=F1(T,X,Y) LET L1=F2(T,X,Y) LET K2=F1(T+H/2,X+H/2*K1,Y+H/2*L1) LET L2=F2(T+H/2,X+H/2*K1,Y+H/2*L1) LET K3=F1(T+H/2,X+H/2*K2,Y+H/2*L2) LET L3=F2(T+H/2,X+H/2*K2,Y+H/2*L2) LET K4=F1(T+H,X+H*K3,Y+H*L3) LET L4=F2(T+H,X+H*K3,Y+H*L3) LET X0=X+H*(K1+2*K2+2*K3+K4)/6 LET Y0=Y+H*(L1+2*L2+2*L3+L4)/6 LET T0=T+H SET LINE COLOR "RED" PLOT LINES:T,X;T0,X0 SET LINE COLOR "BLUE" PLOT LINES:T,Y;T0,Y0 SET LINE COLOR "GREEN" PLOT LINES:X,Y;X0,Y0 LET X=X0 LET Y=Y0 LET T=T0 NEXT J USE PLOT LINES END WHEN LET H=-H NEXT I NEXT XX NEXT YY END EXTERNAL FUNCTION F1(T,X,Y) !'dx/dt=f1(t,x,y) LET F1=Y END FUNCTION EXTERNAL FUNCTION F2(T,X,Y) !'dy/dt=f2(t,x,y) LET F2=-1 END FUNCTION

解曲線

投稿者：しばっち投稿日：2020年 3月29日(日)19時45分51秒

dx/dt=f1(t,x,y,z) dy/dt=f2(t,x,y,z) dz/dt=f3(t,x,y,z)として3元連立常微分方程式をルンゲクッタ法で解き、その解曲線群を描画します。 RANDOMIZE LET XS=-4 LET XE=4 LET YS=-4 LET YE=4 SET WINDOW XS,XE,YS,YE DRAW GRID LET N=100 !'分割数 LET H=(XE-XS)/N FOR L=1 TO 15 LET XX=INT(RND*10)-5 LET YY=INT(RND*10)-5 LET ZZ=INT(RND*10)-5 FOR I=1 TO 2 LET X=XX !'初期値 X LET Y=YY !'初期値 Y LET Z=ZZ !'初期値 Z LET T=0 FOR J=1 TO N LET K1=F1(T,X,Y,Z) LET L1=F2(T,X,Y,Z) LET M1=F3(T,X,Y,Z) LET K2=F1(T+H/2,X+H/2*K1,Y+H/2*L1,Z+H/2*M1) LET L2=F2(T+H/2,X+H/2*K1,Y+H/2*L1,Z+H/2*M1) LET M2=F3(T+H/2,X+H/2*K1,Y+H/2*L1,Z+H/2*M1) LET K3=F1(T+H/2,X+H/2*K2,Y+H/2*L2,Z+H/2*M2) LET L3=F2(T+H/2,X+H/2*K2,Y+H/2*L2,Z+H/2*M2) LET M3=F3(T+H/2,X+H/2*K2,Y+H/2*L2,Z+H/2*M2) LET K4=F1(T+H,X+H*K3,Y+H*L3,Z+H*M3) LET L4=F2(T+H,X+H*K3,Y+H*L3,Z+H*M3) LET M4=F3(T+H,X+H*K3,Y+H*L3,Z+H*M3) LET T0=T+H LET X0=X+H*(K1+2*K2+2*K3+K4)/6 LET Y0=Y+H*(L1+2*L2+2*L3+L4)/6 LET Z0=Z+H*(M1+2*M2+2*M3+M4)/6 SET LINE COLOR "RED" PLOT LINES:T,X;T0,X0 SET LINE COLOR "BLUE" PLOT LINES:T,Y;T0,Y0 SET LINE COLOR "GREEN" PLOT LINES:T,Z;T0,Z0 LET X=X0 LET Y=Y0 LET Z=Z0 LET T=T0 NEXT J LET H=-H NEXT I NEXT L FUNCTION F1(T,X,Y,Z) !'dx/dt=f1(t,x,y,z) LET F1=X+Y+Z END FUNCTION FUNCTION F2(T,X,Y,Z) !'dy/dt=f2(t,x,y,z) LET F2=-4*X-3*Y-7*Z END FUNCTION FUNCTION F3(T,X,Y,Z) !'dz/dt=f3(t,x,y,z) LET F3=2*X+Y+5*Z END FUNCTION END ---------------------------------------------------------------------------------------- ローレンツの方程式を3元連立常微分方程式としてルンゲクッタ法で解き Lorenzアトラクタを3D描画します。 https://ja.wikipedia.org/wiki/ローレンツ方程式 LET XS=-40 LET XE=40 LET YS=-40 LET YE=40 LET ZTH=0 ! z軸のまわりの回転角 LET XTH=0 ! x軸のまわりの回転角初期値 LET YTH=0 ! y軸のまわりの回転角初期値 DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4) SET WINDOW XS,XE,YS,YE MAT M=ROTATE(ZTH) MAT ROTX=IDN ! x軸のまわりの回転 LET ROTX(2,2)=COS(XTH) LET ROTX(2,3)=SIN(XTH) LET ROTX(3,2)=-SIN(XTH) LET ROTX(3,3)=COS(XTH) MAT ROTY=IDN ! y軸のまわりの回転 LET ROTY(1,1)=COS(YTH) LET ROTY(1,3)=-SIN(YTH) LET ROTY(3,1)=SIN(YTH) LET ROTY(3,3)=COS(YTH) MAT M=M*ROTX*ROTY LET N=4000 LET H=1/128 LET A=10 LET B=28 LET C=8/3 LET X=1 !'初期値 X LET Y=1 !'初期値 Y LET Z=1 !'初期値 Z LET T=0 FOR J=1 TO N LET K1=F1(T,X,Y,Z) LET L1=F2(T,X,Y,Z) LET M1=F3(T,X,Y,Z) LET K2=F1(T+H/2,X+H/2*K1,Y+H/2*L1,Z+H/2*M1) LET L2=F2(T+H/2,X+H/2*K1,Y+H/2*L1,Z+H/2*M1) LET M2=F3(T+H/2,X+H/2*K1,Y+H/2*L1,Z+H/2*M1) LET K3=F1(T+H/2,X+H/2*K2,Y+H/2*L2,Z+H/2*M2) LET L3=F2(T+H/2,X+H/2*K2,Y+H/2*L2,Z+H/2*M2) LET M3=F3(T+H/2,X+H/2*K2,Y+H/2*L2,Z+H/2*M2) LET K4=F1(T+H,X+H*K3,Y+H*L3,Z+H*M3) LET L4=F2(T+H,X+H*K3,Y+H*L3,Z+H*M3) LET M4=F3(T+H,X+H*K3,Y+H*L3,Z+H*M3) LET T=T+H LET X=X+H*(K1+2*K2+2*K3+K4)/6 LET Y=Y+H*(L1+2*L2+2*L3+L4)/6 LET Z=Z+H*(M1+2*M2+2*M3+M4)/6 CALL PLOT(X,Y,Z) NEXT J SUB PLOT(X,Y,Z) LET POINT(1)=X LET POINT(2)=Y LET POINT(3)=Z MAT POINT=POINT*M PLOT LINES:POINT(1),POINT(2); END SUB FUNCTION F1(T,X,Y,Z) !'dx/dt=f1(t,x,y,z) LET F1=A*(Y-X) END FUNCTION FUNCTION F2(T,X,Y,Z) !'dy/dt=f2(t,x,y,z) LET F2=X*(B-Z)-Y END FUNCTION FUNCTION F3(T,X,Y,Z) !'dz/dt=f3(t,x,y,z) LET F3=X*Y-C*Z END FUNCTION END

M元連立常微分方程式

投稿者：しばっち投稿日：2020年 3月29日(日)19時47分33秒

LET TS=0 !' TS～TEまで LET TE=2 LET M=3 !'M元連立常微分方程式 DIM Y(M),Y1(M),Y2(M),Y3(M),K1(M),K2(M),K3(M),K4(M) LET N=20 !'分割数 LET H=(TE-TS)/N LET T=0 LET Y(1)=INT(RND*10)-5 !'初期値 x LET Y(2)=INT(RND*10)-5 !'初期値 y LET Y(3)=INT(RND*10)-5 !'初期値 z FOR I=1 TO N FOR J=1 TO M LET K1(J)=F(J,T,Y) NEXT J FOR J=1 TO M LET Y1(J)=Y(J)+H/2*K1(J) NEXT J FOR J=1 TO M LET K2(J)=F(J,T+H/2,Y1) NEXT J FOR J=1 TO M LET Y2(J)=Y(J)+H/2*K2(J) NEXT J FOR J=1 TO M LET K3(J)=F(J,T+H/2,Y2) NEXT J FOR J=1 TO M LET Y3(J)=Y(J)+H*K3(J) NEXT J FOR J=1 TO M LET K4(J)=F(J,T+H,Y3) NEXT J LET T=T+H FOR J=1 TO M LET Y(J)=Y(J)+H*(K1(J)+2*K2(J)+2*K3(J)+K4(J))/6 NEXT J PRINT T; FOR J=1 TO M PRINT Y(J); NEXT J PRINT NEXT I END EXTERNAL FUNCTION F(NUM,T,Y()) !' x=Y(1) y=Y(2) z=Y(3) ... SELECT CASE NUM CASE 1 LET F=Y(1)+Y(2)+Y(3) !'dx/dt=f1(t,y(1),y(2),y(3))=x+y+z CASE 2 LET F=-4*Y(1)-3*Y(2)-7*Y(3) !'dy/dt=f2(t,y(1),y(2),y(3))=-4*x-3*y-7*z CASE 3 LET F=2*Y(1)+Y(2)+5*Y(3) !'dz/dt=f3(t,y(1),y(2),y(3))=2*x+y+5*z END SELECT END FUNCTION

X^2+Y^2-3XY+1=0のグラフ

投稿者：しばっち投稿日：2020年 4月 5日(日)14時27分39秒

X^2+Y^2-3*X*Y+1=0のグラフ https://hp.vector.co.jp/authors/VA008683/F_GRAPH.htm 導関数 dy/dx=(2*x-3*y)/(3*x-2*y)を求め、dx/dt=3*x-2*y dy/dt=2*x-3*yとして 2元連立常微分方程式をルンゲクッタ法で解く https://www.wolframalpha.com/input/?i=x%5E2%2By%5E2-3*x*y%2B1%3D0%2Cdy/dx&lang=ja 陰関数 F(x,y)=0のグラフはdy/dx=f(x,y)の解曲線とすれば描画できる。 LET XS=-5 LET XE=5 LET YS=-5 LET YE=5 SET WINDOW XS,XE,YS,YE DRAW GRID LET N=100 !'分割数 LET H=(XE-XS)/N FOR L=1 TO 2 READ XX,YY DATA 1,1 DATA -1,-1 FOR I=1 TO 2 LET T=0 LET X=XX !'初期値 LET Y=YY WHEN EXCEPTION IN FOR J=1 TO N LET K1=F1(T,X,Y) LET L1=F2(T,X,Y) LET K2=F1(T+H/2,X+H/2*K1,Y+H/2*L1) LET L2=F2(T+H/2,X+H/2*K1,Y+H/2*L1) LET K3=F1(T+H/2,X+H/2*K2,Y+H/2*L2) LET L3=F2(T+H/2,X+H/2*K2,Y+H/2*L2) LET K4=F1(T+H,X+H*K3,Y+H*L3) LET L4=F2(T+H,X+H*K3,Y+H*L3) LET X0=X+H*(K1+2*K2+2*K3+K4)/6 LET Y0=Y+H*(L1+2*L2+2*L3+L4)/6 LET T0=T+H PLOT LINES:X,Y;X0,Y0 LET X=X0 LET Y=Y0 LET T=T0 NEXT J USE PLOT LINES END WHEN LET H=-H NEXT I NEXT L END EXTERNAL FUNCTION F1(T,X,Y) !'dx/dt=f1(t,x,y) LET F1=3*X-2*Y END FUNCTION EXTERNAL FUNCTION F2(T,X,Y) !'dy/dt=f2(t,x,y) LET F2=2*X-3*Y END FUNCTION -------------------------------------------------------------------------------- 1/(X-Y)-X+3*Y=0のグラフ dy/dx=((x-y)^2+1)/(3*(x-y)^2+1) https://www.wolframalpha.com/input/?i=1/%28x-y%29-x%2B3*y%3D0%2Cdy/dx&lang=ja LET XS=-5 LET XE=5 LET YS=-5 LET YE=5 SET WINDOW XS,XE,YS,YE DRAW GRID LET N=100 !'分割数 LET H=(XE-XS)/N FOR L=1 TO 2 READ XX,YY DATA 1,0 DATA -1,0 FOR I=1 TO 2 LET T=0 LET X=XX !'初期値 LET Y=YY WHEN EXCEPTION IN FOR J=1 TO N LET K1=F1(T,X,Y) LET L1=F2(T,X,Y) LET K2=F1(T+H/2,X+H/2*K1,Y+H/2*L1) LET L2=F2(T+H/2,X+H/2*K1,Y+H/2*L1) LET K3=F1(T+H/2,X+H/2*K2,Y+H/2*L2) LET L3=F2(T+H/2,X+H/2*K2,Y+H/2*L2) LET K4=F1(T+H,X+H*K3,Y+H*L3) LET L4=F2(T+H,X+H*K3,Y+H*L3) LET X0=X+H*(K1+2*K2+2*K3+K4)/6 LET Y0=Y+H*(L1+2*L2+2*L3+L4)/6 LET T0=T+H PLOT LINES:X,Y;X0,Y0 LET X=X0 LET Y=Y0 LET T=T0 NEXT J USE PLOT LINES END WHEN LET H=-H NEXT I NEXT L END EXTERNAL FUNCTION F1(T,X,Y) !'dx/dt=f1(t,x,y) LET F1=3*(X-Y)^2+1 END FUNCTION EXTERNAL FUNCTION F2(T,X,Y) !'dy/dt=f2(t,x,y) LET F2=(X-Y)^2+1 END FUNCTION

Re: X^2+Y^2-3XY+1=0のグラフ

投稿者：しばっち投稿日：2020年 4月 8日(水)20時36分41秒

> No.4817[元記事へ] 陰関数 F(x,y)=0 の導関数 dy/dx=f(x,y) は数値微分でも代用できるようです。 LET XS=-5 LET XE=5 LET YS=-5 LET YE=5 SET WINDOW XS,XE,YS,YE DRAW GRID LET N=100 !'分割数 LET H=(XE-XS)/N FOR L=1 TO 2 READ XX,YY DATA 1,1 DATA -1,-1 FOR I=1 TO 2 LET T=0 LET X=XX !'初期値 LET Y=YY WHEN EXCEPTION IN FOR J=1 TO N LET K1=F1(T,X,Y) LET L1=F2(T,X,Y) LET K2=F1(T+H/2,X+H/2*K1,Y+H/2*L1) LET L2=F2(T+H/2,X+H/2*K1,Y+H/2*L1) LET K3=F1(T+H/2,X+H/2*K2,Y+H/2*L2) LET L3=F2(T+H/2,X+H/2*K2,Y+H/2*L2) LET K4=F1(T+H,X+H*K3,Y+H*L3) LET L4=F2(T+H,X+H*K3,Y+H*L3) LET X0=X+H*(K1+2*K2+2*K3+K4)/6 LET Y0=Y+H*(L1+2*L2+2*L3+L4)/6 LET T0=T+H PLOT LINES:X,Y;X0,Y0 LET X=X0 LET Y=Y0 LET T=T0 IF X>XE OR X<XS OR Y<YS OR Y>YE THEN EXIT FOR NEXT J USE PLOT LINES END WHEN LET H=-H NEXT I NEXT L END EXTERNAL FUNCTION F1(T,X,Y) !'dx/dt=f1(t,x,y) LET F1=FY(X,Y) END FUNCTION EXTERNAL FUNCTION F2(T,X,Y) !'dy/dt=f2(t,x,y) LET F2=-FX(X,Y) END FUNCTION EXTERNAL FUNCTION F(X,Y) !'陰関数 F(x,y)=0 LET F=X^2+Y^2-3*X*Y+1 END FUNCTION EXTERNAL FUNCTION FX(X,Y) !' ∂/∂x F(x,y) LET H=1/256 LET FX=(F(X-2*H,Y)-8*F(X-H,Y)+8*F(X+H,Y)-F(X+2*H,Y))/(12*H) END FUNCTION EXTERNAL FUNCTION FY(X,Y) !' ∂/∂y F(x,y) LET H=1/256 LET FY=(F(X,Y-2*H)-8*F(X,Y-H)+8*F(X,Y+H)-F(X,Y+2*H))/(12*H) END FUNCTION

Re: X^2+Y^2-3XY+1=0のグラフ

投稿者：しばっち投稿日：2020年 4月12日(日)14時46分5秒

> No.4818[元記事へ] 下記のようにしても陰関数のグラフが描画できます。 LET LEFT=-5 LET RIGHT=5 LET BOTTOM=-5 LET TOP=5 SET POINT STYLE 1 SET WINDOW LEFT,RIGHT,BOTTOM,TOP ASK PIXEL SIZE XSIZE,YSIZE DRAW GRID FOR YY=0 TO YSIZE-1 FOR XX=0 TO YSIZE-1 LET X=WORLDX(XX) LET Y=WORLDY(YY) WHEN EXCEPTION IN LET L=ABS(F(X,Y)) IF L<1 AND L/SQR(FX(X,Y)^2+FY(X,Y)^2)<.01 THEN PLOT POINTS: X,Y USE END WHEN NEXT XX NEXT YY END EXTERNAL FUNCTION F(X,Y) !'陰関数 F(X,Y)=0 LET F=X*X+Y*Y-3*X*Y+1 !'LET F=1/(X-Y)-X+3*Y !'LET F=SIN(X)+SIN(2*Y)+SIN(3*X)+SIN(4*Y)+SIN(5*X) !'LET F=(FF(Y)^2-FF(X)^4+FF(X)^6)*(FF(X)^2-FF(Y)^4+FF(Y)^6) !'LET F=(FF(X)^2+FF(Y)^2-3)*(1.5*FF(X)^4-FF(X)^6-1.5*FF(Y)^4) !'LET F=(FF(X)^2+FF(Y)^2)^3-4*FF(X)^2*FF(Y)^2 END FUNCTION EXTERNAL FUNCTION FF(X) LET FF=X-2.6*INT((X+1.3)/2.6) END FUNCTION EXTERNAL FUNCTION FX(X,Y) !' ∂/∂x F(x,y) LET H=1/256 !'LET FX=(-F(X-H,Y)+F(X+H,Y))/(2*H) LET FX=(F(X-2*H,Y)-8*F(X-H,Y)+8*F(X+H,Y)-F(X+2*H,Y))/(12*H) !'LET FX=(-F(X-3*H,Y)+9*F(X-2*H,Y)-45*F(X-H,Y)+45*F(X+H,Y)-9*F(X+2*H,Y)+F(X+3*H,Y))/(60*H) !'LET FX=(3*F(X-4*H,Y)-32*F(X-3*H,Y)+168*F(X-2*H,Y)-672*F(X-H,Y)+672*F(X+H,Y)-168*F(X+2*H,Y)+32*F(X+3*H,Y)-3*F(X+4*H,Y))/(840*H) END FUNCTION EXTERNAL FUNCTION FY(X,Y) !' ∂/∂y F(x,y) LET H=1/256 !'LET FY=(-F(X,Y-H)+F(X,Y+H))/(2*H) LET FY=(F(X,Y-2*H)-8*F(X,Y-H)+8*F(X,Y+H)-F(X,Y+2*H))/(12*H) !'LET FY=(-F(X,Y-3*H)+9*F(X,Y-2*H)-45*F(X,Y-H)+45*F(X,Y+H)-9*F(X,Y+2*H)+F(X,Y+3*H))/(60*H) !'LET FY=(3*F(X,Y-4*H)-32*F(X,Y-3*H)+168*F(X,Y-2*H)-672*F(X,Y-H)+672*F(X,Y+H)-168*F(X,Y+2*H)+32*F(X,Y+3*H)-3*F(X,Y+4*H))/(840*H) END FUNCTION

複素関数のグラフ

投稿者：しばっち投稿日：2020年 4月26日(日)19時02分16秒

複素関数のグラフ(色関数) https://ja.wikipedia.org/wiki/定義域の着色 (※クリックではなくマウスで選択コピーしてブラウザのアドレスバーに貼り付け移動してください) ※残念ながら上記URLのサンプルと同じ画像にはなりません。 OPTION ARITHMETIC COMPLEX SET COLOR MIX(0) 0,0,0 SET COLOR MODE "NATIVE" CLEAR SET POINT STYLE 1 LET XS,YS=-10 LET XE,YE=10 ASK BITMAP SIZE XSIZE,YSIZE LET ZMIN=1E+10 FOR Y=0 TO YSIZE-1 FOR X=0 TO XSIZE-1 LET XX=WORLDX(X) LET YY=WORLDY(Y) LET Z=F(COMPLEX(XX,YY)) IF ABS(Z)<>0 THEN LET ZZ=LOG10(ABS(Z)) ELSE LET ZZ=0 LET ZMAX=MAX(ZMAX,ZZ) LET ZMIN=MIN(ZMIN,ZZ) NEXT X NEXT Y DO SET WINDOW XS,XE,YS,YE FOR Y=0 TO YSIZE-1 FOR X=0 TO XSIZE-1 LET XX=WORLDX(X) LET YY=WORLDY(Y) LET Z=F(COMPLEX(XX,YY)) IF RE(Z)<>0 OR IM(Z)<>0 THEN LET ARG=ANGLE(RE(Z),IM(Z)) ELSE LET ARG=0 IF ABS(Z)=0 THEN LET ZZ=0 ELSE LET ZZ=LOG10(ABS(Z)) LET ZZ=(ZZ-ZMIN)/(ZMAX-ZMIN) CALL HSL2RGB(DEG(ARG),255,(1-2^(-ZZ))*255,R,G,B) CALL PSET(XX,YY,R,G,B) NEXT X NEXT Y PAUSE "拡大する範囲を指定してください" CALL GETSQUARE(XS,YS,XE,YE) IF XS=XE THEN EXIT DO IF XS>XE THEN SWAP XS,XE IF YS>YE THEN SWAP YS,YE LOOP END EXTERNAL FUNCTION F(X) OPTION ARITHMETIC COMPLEX LET I=SQR(-1) LET F=(X^2-1)*(X-2-I)^2/(X^2+2+2*I) END FUNCTION EXTERNAL SUB HSL2RGB(H,S,L,R,G,B) OPTION ARITHMETIC COMPLEX IF S<0 THEN LET S=0 IF S>255 THEN LET S=255 IF L<0 THEN LET L=0 IF L>255 THEN LET L=255 LET SS=S/255 LET LL=L/255 LET H=MOD(INT(H),360) IF H<0 THEN LET H=H+360 IF LL<=.5 THEN LET CMIN=LL*(1-SS) LET CMAX=2*LL-CMIN ELSE LET CMAX=LL*(1-SS)+SS LET CMIN=2*LL-CMAX END IF LET R=H2V(H+120,CMIN,CMAX)*255 LET G=H2V(H,CMIN,CMAX)*255 LET B=H2V(H-120,CMIN,CMAX)*255 LET R=INT(R+.5) LET B=INT(B+.5) LET G=INT(G+.5) IF R<0 THEN LET R=0 IF G<0 THEN LET G=0 IF B<0 THEN LET B=0 IF R>255 THEN LET R=255 IF G>255 THEN LET G=255 IF B>255 THEN LET B=255 END SUB EXTERNAL FUNCTION H2V(H,CMIN,CMAX) OPTION ARITHMETIC COMPLEX IF H<0 THEN LET H=H+360 LET H=MOD(H,360) IF H<60 THEN LET H2V=CMIN+(CMAX-CMIN)*H/60 EXIT FUNCTION END IF IF H>=60 AND H<180 THEN LET H2V=CMAX EXIT FUNCTION END IF IF H>=180 AND H<240 THEN LET H2V=CMIN+(CMAX-CMIN)*(240-H)/60 EXIT FUNCTION END IF IF H>=240 THEN LET H2V=CMIN END FUNCTION EXTERNAL SUB PSET(X,Y,R,G,B) OPTION ARITHMETIC COMPLEX LET RR=MIN(255,MAX(0,INT(R))) LET GG=MIN(255,MAX(0,INT(G))) LET BB=MIN(255,MAX(0,INT(B))) SET COLOR COLORINDEX(RR/255,GG/255,BB/255) PLOT POINTS:X,Y END SUB EXTERNAL SUB GETSQUARE(L,T,R,B) OPTION ARITHMETIC COMPLEX SET COLOR MODE "REGULAR" ASK LINE STYLE LSTYLE SET DRAW MODE NOTXOR SET LINE STYLE 2 DO MOUSE POLL L,T,I,J LOOP WHILE I=0 LET L0=L LET T0=T LET R0=L0 LET B0=T0 PLOT LINES:L0,T0;L0,B0;R0,B0;R0,T0;L0,T0 DO WHILE I=1 MOUSE POLL R,B,I,J LET W=R-L LET H=T-B IF ABS(H)<ABS(W) THEN LET B=T-SGN(H)*ABS(W) ELSE LET R=L+SGN(W)*ABS(H) END IF IF L0<>L OR R0<>R OR B0<>B OR T0<>T THEN PLOT LINES:L0,T0;L0,B0;R0,B0;R0,T0;L0,T0 PLOT LINES:L,T;L,B;R,B;R,T;L,T LET L0=L LET T0=T LET R0=R LET B0=B END IF LOOP WAIT DELAY 1 PLOT LINES:L,T;L,B;R,B;R,T;L,T SET DRAW MODE OVERWRITE SET LINE STYLE LSTYLE IF L>R THEN SWAP L,R IF B>T THEN SWAP B,T SET COLOR MODE "NATIVE" END SUB

バージョンの修正をお願いします

投稿者：名無しさん投稿日：2020年 5月 9日(土)00時23分51秒

　PLOT AREAの仕様についてなんですが(VER 7.6.6の話ですが)。　LINE STYLEを２や３に設定してPLOT AREAを実行すると、塗りつぶしの輪郭にもLINE STYLEが適用され、模様がギザギザになってしまいます(組み込み絵定義DRAW DISKも含む)。　これ、汚らしいし知らないでやった人はバグだと思うし直前に1以外のLINE STYLEで線を描いた後にいちいちSET LINE STYLE 1　と書いてからPLOT AREAするのがめんどうくさいです。　そもそもLINE STYLEは曲直線に適用するためのものであり、塗りつぶしのステエトメントであるPLOT AREAとは関係ないと思うのですが。　これは、バージョンの修正を検討すべきだと思いますが。　白石先生、検討をお願いします。

Re: バージョンの修正をお願いします

投稿者：SHIRAISHI Kazuo 投稿日：2020年 5月10日(日)08時20分33秒

> No.4821[元記事へ] Ver. 7.8.5.4ですが，支障ないようです。 10 SET LINE STYLE 2 20 PLOT LINES:0,0; 0,1 30 SET AREA COLOR 2 40 PLOT AREA : 0,0;1,0;0.5,1 50 END

PLOT POINTS文とMAT PLOT CELLS文との速度比較について

投稿者：しばっち投稿日：2020年 5月24日(日)14時26分44秒

これはWindows版BASICの場合ですが PLOT POINTS文とMAT PLOT CELLS文とでは動作モードにもよるがMAT PLOT CELLS文で描画するほうが断然速い。 2進モードでは30倍も速い LET XSIZE=800 LET YSIZE=800 CALL GINIT(XSIZE,YSIZE) LET T=TIME !!!SET DRAW MODE HIDDEN !ここの注釈を外すと5倍程速くなる FOR Y=0 TO YSIZE-1 FOR X=0 TO XSIZE-1 LET C=INT(RND*255) SET POINT COLOR C PLOT POINTS:X,Y NEXT X NEXT Y !!!SET DRAW MODE EXPLICIT LET L=TIME-T PRINT L OPTION BASE 0 DIM M(XSIZE-1,YSIZE-1) CLEAR LET T=TIME FOR Y=0 TO YSIZE-1 FOR X=0 TO XSIZE-1 LET C=INT(RND*255) LET M(X,Y)=C NEXT X NEXT Y MAT PLOT CELLS,IN 0,0; XSIZE-1,YSIZE-1 :M LET P=TIME-T PRINT P PRINT L/P END EXTERNAL SUB GINIT(XSIZE,YSIZE) SET BITMAP SIZE XSIZE,YSIZE SET WINDOW 0,XSIZE-1,YSIZE-1,0 SET POINT STYLE 1 SET COLOR MODE "REGULAR" FOR I=0 TO 7 SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1) NEXT I CLEAR END SUB 実行結果 5.38999999999942 .160000000003492 33.687499999261 MAT PLOT CELLS文を使用して下記のようにスクロールアニメができます。 RANDOMIZE FILE GETNAME F$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG" CALL PICTURELOAD(F$,XSIZE,YSIZE) LET WIDTH=600 !'ウィンドゥサイズ LET HEIGHT=600 OPTION BASE 0 DIM MM(WIDTH,HEIGHT),M(XSIZE,YSIZE) ASK PIXEL ARRAY (0,0) M CALL GINIT(WIDTH,HEIGHT) DO LET N=INT(RND*50)+10 LET XR=INT(RND*30-15) LET YR=INT(RND*30-15) FOR I=1 TO N FOR Y=0 TO HEIGHT-1 FOR X=0 TO WIDTH-1 LET MM(X,Y)=M(MOD(X+XX,XSIZE),MOD(Y+YY,YSIZE)) NEXT X NEXT Y MAT PLOT CELLS,IN 0,0; WIDTH-1,HEIGHT-1:MM LET XX=MOD(XX+XR,XSIZE) LET YY=MOD(YY+YR,YSIZE) NEXT I LOOP END 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

画像色調

投稿者：しばっち投稿日：2020年 5月24日(日)14時28分11秒

R,G,Bをスライドバーで指定して色調を変更します。リアルタイム処理はできないのでウェイトを入れています。スライドバーを動かした後、グラフィックウィンドゥ内をマウスでクリックしてください。 OPTION BASE 0 FILE GETNAME F$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG" CALL PICTURELOAD(F$,XSIZE,YSIZE) DIM M(XSIZE-1,YSIZE-1),MM(XSIZE-1,YSIZE-1) ASK PIXEL ARRAY(0,0) M LOCATE VALUE NOWAIT(1),RANGE 0 TO 255,AT 240:R0 !'セピア調 LOCATE VALUE NOWAIT(2),RANGE 0 TO 255,AT 200:G0 LOCATE VALUE NOWAIT(3),RANGE 0 TO 255,AT 145:B0 DO CLEAR SET TEXT HEIGHT YSIZE/10 SET COLOR COLORINDEX(0,0,0) SET TEXT BACKGROUND "OPAQUE" SET TEXT JUSTIFY "CENTER" , "TOP" PLOT TEXT ,AT XSIZE/2,YSIZE/2 :"処理中" LET R0=INT(R0) LET G0=INT(G0) LET B0=INT(B0) FOR Y=0 TO YSIZE-1 SET TEXT JUSTIFY "LEFT" , "TOP" PLOT TEXT ,AT 0,0 :USING$("###.#",Y/(YSIZE-1)*100)&"%" FOR X=0 TO XSIZE-1 IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP LET C=M(X,Y) CALL RGB(C,R,G,B) !' LET V=(R+G+B)/3 LET V=R * 0.298912 + G * 0.586611 + B * 0.114478 LET RR=R0*V/255 LET GG=G0*V/255 LET BB=B0*V/255 LET MM(X,Y)=SETRGB(INT(RR),INT(GG),INT(BB)) NEXT X NEXT Y MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:MM DO !'ウェイト。マウスでウィンドゥ内をクリックする。 IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP MOUSE POLL X,Y,LL,RR LOCATE VALUE NOWAIT(1):R0 LOCATE VALUE NOWAIT(2):G0 LOCATE VALUE NOWAIT(3):B0 LOOP WHILE LL=0 AND RR=0 LOOP END EXTERNAL FUNCTION SETRGB(R,G,B) LET R=MIN(255,MAX(R,0)) LET G=MAX(0,MIN(G,255)) LET B=MAX(0,MIN(B,255)) LET SETRGB=B*65536+G*256+R END FUNCTION EXTERNAL SUB RGB(X,R,G,B) LET B=MOD(INT(X/65536),256) LET G=MOD(INT(X/256),256) LET R=MOD(X,256) END SUB 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

画像ぼかし

投稿者：しばっち投稿日：2020年 5月24日(日)14時29分12秒

長さと角度をスライドバーで指定します。スライドバーを動かした後、グラフィックウィンドゥ内をマウスでクリックしてください。 OPTION BASE 0 FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG" CALL PICTURELOAD(N$,XSIZE,YSIZE) DIM M(XSIZE-1,YSIZE-1),MM(XSIZE-1,YSIZE-1) ASK PIXEL ARRAY(0,0) M LOCATE VALUE NOWAIT(1),RANGE 1 TO MIN(XSIZE,YSIZE)/5,AT 10:LENGTH LOCATE VALUE NOWAIT(2),RANGE 0 TO 89,AT 45:TH DO LET LENGTH=INT(LENGTH) LET TH=INT(TH) CLEAR SET TEXT HEIGHT YSIZE/10 SET COLOR COLORINDEX(0,0,0) SET TEXT BACKGROUND "OPAQUE" SET TEXT JUSTIFY "CENTER" , "TOP" PLOT TEXT ,AT XSIZE/2,YSIZE/2 :"処理中" FOR Y=0 TO YSIZE-1 SET TEXT JUSTIFY "LEFT" , "TOP" PLOT TEXT ,AT 0,0 :USING$("###.#",Y/(YSIZE-1)*100)&"%" FOR X=0 TO XSIZE-1 IF GETKEYSTATE(32)<0 OR GETKEYSTATE(13)<0 OR GETKEYSTATE(27)<0 THEN STOP LET R=0 LET G=0 LET B=0 FOR L=0 TO LENGTH-1 IF GETKEYSTATE(32)<0 OR GETKEYSTATE(13)<0 OR GETKEYSTATE(27)<0 THEN STOP LET XX=X+COS(TH*PI/180)*L LET YY=Y+SIN(TH*PI/180)*L IF XX>=0 AND XX<=XSIZE-1 AND YY>=0 AND YY<=YSIZE-1 THEN LET CC=M(INT(XX),INT(YY)) ELSE EXIT FOR CALL RGB(CC,R0,G0,B0) LET R=R+R0 LET G=G+G0 LET B=B+B0 NEXT L LET R=INT(R/(L+1)) LET G=INT(G/(L+1)) LET B=INT(B/(L+1)) LET MM(X,Y)=SETRGB(R,G,B) NEXT X NEXT Y MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:MM DO !'ウェイト。マウスでウィンドゥ内をクリックする。 IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP MOUSE POLL X,Y,LL,RR LOCATE VALUE NOWAIT(1):LENGTH LOCATE VALUE NOWAIT(2):TH LOOP WHILE LL=0 AND RR=0 LOOP END EXTERNAL FUNCTION SETRGB(R,G,B) LET R=MIN(255,MAX(R,0)) LET G=MAX(0,MIN(G,255)) LET B=MAX(0,MIN(B,255)) LET SETRGB=B*65536+G*256+R END FUNCTION EXTERNAL SUB RGB(X,R,G,B) LET B=MOD(INT(X/65536),256) LET G=MOD(INT(X/256),256) LET R=MOD(X,256) END SUB EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE) CLEAR SET COLOR MODE "NATIVE" 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

画像ぼかし2

投稿者：しばっち投稿日：2020年 5月24日(日)14時29分58秒

ボカシ処理をします。スライドバーを動かした後、グラフィックウィンドゥ内をマウスでクリックしてください。 OPTION BASE 0 FILE GETNAME F$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG" CALL PICTURELOAD(F$,XSIZE,YSIZE) DIM M(XSIZE-1,YSIZE-1),MM(XSIZE-1,YSIZE-1) ASK PIXEL ARRAY(0,0) M LOCATE VALUE NOWAIT(1),RANGE 1 TO 9,AT 1:N DO CLEAR SET TEXT HEIGHT YSIZE/10 SET COLOR COLORINDEX(0,0,0) SET TEXT BACKGROUND "OPAQUE" SET TEXT JUSTIFY "CENTER" , "TOP" PLOT TEXT ,AT XSIZE/2,YSIZE/2 :"処理中" LET N=INT(N) FOR Y=0 TO YSIZE-1 SET TEXT JUSTIFY "LEFT" , "TOP" PLOT TEXT ,AT 0,0 :USING$("###.#",Y/(YSIZE-1)*100)&"%" FOR X=0 TO XSIZE-1 LET RR=0 LET GG=0 LET BB=0 LET K=0 FOR J=-N TO N FOR I=-N TO N IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP IF X+I>=0 AND X+I<=XSIZE-1 AND Y+J>=0 AND Y+J<=YSIZE-1 THEN LET C=M(X+I,Y+J) CALL RGB(C,R,G,B) LET RR=RR+R LET GG=GG+G LET BB=BB+B LET K=K+1 END IF NEXT I NEXT J LET MM(X,Y)=SETRGB(INT(RR/K),INT(GG/K),INT(BB/K)) NEXT X NEXT Y MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:MM DO !'ウェイト。マウスでウィンドゥ内をクリックする。 IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP MOUSE POLL X,Y,LL,RR LOCATE VALUE NOWAIT(1):N LOOP WHILE LL=0 AND RR=0 LOOP END EXTERNAL FUNCTION SETRGB(R,G,B) LET R=MIN(255,MAX(R,0)) LET G=MAX(0,MIN(G,255)) LET B=MAX(0,MIN(B,255)) LET SETRGB=B*65536+G*256+R END FUNCTION EXTERNAL SUB RGB(X,R,G,B) LET B=MOD(INT(X/65536),256) LET G=MOD(INT(X/256),256) LET R=MOD(X,256) END SUB EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE) CLEAR SET COLOR MODE "NATIVE" 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

画像回転ぼかし

投稿者：しばっち投稿日：2020年 5月24日(日)14時31分9秒

回転角度と楕円領域の大きさとその中心座標をスライドバーで指定します。スライドバーを動かした後、グラフィックウィンドゥ内をマウスでクリックしてください。 OPTION BASE 0 FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG" CALL PICTURELOAD(N$,XSIZE,YSIZE) DIM M(XSIZE-1,YSIZE-1),MM(XSIZE-1,YSIZE-1) ASK PIXEL ARRAY(0,0) M LOCATE VALUE NOWAIT(1),RANGE 1 TO 90,AT 10:ALPHA LOCATE VALUE NOWAIT(2),RANGE 0 TO XSIZE-1,AT XSIZE/2:X0 LOCATE VALUE NOWAIT(3),RANGE 0 TO YSIZE-1,AT YSIZE/2:Y0 LOCATE VALUE NOWAIT(4),RANGE 1 TO XSIZE/2,AT XSIZE/10:XR LOCATE VALUE NOWAIT(5),RANGE 1 TO YSIZE/2,AT YSIZE/10:YR DO CLEAR SET TEXT HEIGHT YSIZE/10 SET COLOR COLORINDEX(0,0,0) SET TEXT BACKGROUND "OPAQUE" SET TEXT JUSTIFY "CENTER" , "TOP" PLOT TEXT ,AT XSIZE/2,YSIZE/2 :"処理中" LET ALPHA=INT(ALPHA) LET X0=INT(X0) LET Y0=INT(Y0) LET XR=INT(XR) LET YR=INT(YR) FOR Y=0 TO YSIZE-1 SET TEXT JUSTIFY "LEFT" , "TOP" PLOT TEXT ,AT 0,0 :USING$("###.#",Y/(YSIZE-1)*100)&"%" FOR X=0 TO XSIZE-1 IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP IF ((X-X0)/XR)^2+((Y-Y0)/YR)^2>1 THEN LET RX=SQR((X-X0)^2+(Y-Y0)^2) IF X-X0=0 THEN IF Y-Y0>0 THEN LET TH=PI/2 ELSE LET TH=1.5*PI ELSE LET TH=ANGLE(X-X0,Y-Y0) END IF LET RR=0 LET GG=0 LET BB=0 FOR I=0 TO ALPHA-1 IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP LET XX=INT(RX*COS(TH+I*PI/180))+X0 LET YY=INT(RX*SIN(TH+I*PI/180))+Y0 IF XX>=0 AND XX<=XSIZE-1 AND YY>=0 AND YY<=YSIZE-1 THEN LET CC=M(XX,YY) ELSE EXIT FOR CALL RGB(CC,R,G,B) LET RR=RR+R LET GG=GG+G LET BB=BB+B NEXT I LET RR=INT(RR/(I+1)) LET GG=INT(GG/(I+1)) LET BB=INT(BB/(I+1)) LET MM(X,Y)=SETRGB(RR,GG,BB) ELSE LET CC=M(X,Y) CALL RGB(CC,R,G,B) LET MM(X,Y)=SETRGB(R,G,B) END IF NEXT X NEXT Y MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:MM DO !'ウェイト。マウスでウィンドゥ内をクリックする。 IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP MOUSE POLL X,Y,LL,RR LOCATE VALUE NOWAIT(1):ALPHA LOCATE VALUE NOWAIT(2):X0 LOCATE VALUE NOWAIT(3):Y0 LOCATE VALUE NOWAIT(4):XR LOCATE VALUE NOWAIT(5):YR LOOP WHILE LL=0 AND RR=0 LOOP END EXTERNAL FUNCTION SETRGB(R,G,B) LET R=MIN(255,MAX(R,0)) LET G=MAX(0,MIN(G,255)) LET B=MAX(0,MIN(B,255)) LET SETRGB=B*65536+G*256+R END FUNCTION EXTERNAL SUB RGB(X,R,G,B) LET B=MOD(INT(X/65536),256) LET G=MOD(INT(X/256),256) LET R=MOD(X,256) END SUB EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE) CLEAR SET COLOR MODE "NATIVE" 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

画像放射ぼかし

投稿者：しばっち投稿日：2020年 5月24日(日)14時32分24秒

長さと楕円領域の大きさとその中心座標をスライドバーで指定します。スライドバーを動かした後、グラフィックウィンドゥ内をマウスでクリックしてください。 OPTION BASE 0 FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG" CALL PICTURELOAD(N$,XSIZE,YSIZE) DIM M(XSIZE-1,YSIZE-1),MM(XSIZE-1,YSIZE-1) ASK PIXEL ARRAY(0,0) M LOCATE VALUE NOWAIT(1),RANGE 1 TO MIN(XSIZE,YSIZE)/5,AT 10:LENGTH LOCATE VALUE NOWAIT(2),RANGE 0 TO XSIZE-1,AT XSIZE/2:X0 LOCATE VALUE NOWAIT(3),RANGE 0 TO YSIZE-1,AT YSIZE/2:Y0 LOCATE VALUE NOWAIT(4),RANGE 1 TO XSIZE/2,AT XSIZE/10:XR LOCATE VALUE NOWAIT(5),RANGE 1 TO YSIZE/2,AT YSIZE/10:YR DO CLEAR SET TEXT HEIGHT YSIZE/10 SET COLOR COLORINDEX(0,0,0) SET TEXT BACKGROUND "OPAQUE" SET TEXT JUSTIFY "CENTER" , "TOP" PLOT TEXT ,AT XSIZE/2,YSIZE/2 :"処理中" LET LENGTH=INT(LENGTH) LET X0=INT(X0) LET Y0=INT(Y0) LET XR=INT(XR) LET YR=INT(YR) FOR Y=0 TO YSIZE-1 SET TEXT JUSTIFY "LEFT" , "TOP" PLOT TEXT ,AT 0,0 :USING$("###.#",Y/(YSIZE-1)*100)&"%" FOR X=0 TO XSIZE-1 IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP IF ((X-X0)/XR)^2+((Y-Y0)/YR)^2>1 THEN LET RR=INT(SQR((X-X0)^2+(Y-Y0)^2)) IF X+X0-XS=0 THEN IF Y-Y0>0 THEN LET TH=PI/2 ELSE LET TH=1.5*PI ELSE LET TH=ANGLE(X-X0,Y-Y0) END IF LET R1=0 LET G1=0 LET B1=0 LET N=0 FOR I=0 TO LENGTH-1 IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP LET XX=X0+INT((RR+I)*COS(TH)) LET YY=Y0+INT((RR+I)*SIN(TH)) IF XX>=0 AND XX<=XSIZE-1 AND YY>=0 AND YY<=YSIZE-1 THEN LET CC=M(XX,YY) CALL RGB(CC,R,G,B) LET R1=R1+R LET G1=G1+G LET B1=B1+B LET N=N+1 ELSE EXIT FOR END IF NEXT I IF N>0 THEN LET MM(X,Y)=SETRGB(INT(R1/N),INT(G1/N),INT(B1/N)) ELSE LET MM(X,Y)=M(X,Y) END IF NEXT X NEXT Y MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:MM DO !'ウェイト。マウスでウィンドゥ内をクリックする。 IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP MOUSE POLL X,Y,LL,RR LOCATE VALUE NOWAIT(1):LENGTH LOCATE VALUE NOWAIT(2):X0 LOCATE VALUE NOWAIT(3):Y0 LOCATE VALUE NOWAIT(4):XR LOCATE VALUE NOWAIT(5):YR LOOP WHILE LL=0 AND RR=0 LOOP END EXTERNAL SUB RGB(X,R,G,B) LET B=MOD(INT(X/65536),256) LET G=MOD(INT(X/256),256) LET R=MOD(X,256) END SUB EXTERNAL FUNCTION SETRGB(R,G,B) LET R=MIN(255,MAX(R,0)) LET G=MAX(0,MIN(G,255)) LET B=MAX(0,MIN(B,255)) LET SETRGB=B*65536+G*256+R END FUNCTION EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE) CLEAR SET COLOR MODE "NATIVE" 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

画像イコライザー

投稿者：しばっち投稿日：2020年 5月24日(日)14時34分14秒

画像に対してグラフィックイコライザー風な(DCT係数を0～2倍します)処理を行います。スライドバーを動かした後、グラフィックウィンドゥ内をマウスでクリックしてください。 OPTION BASE 0 DIM R(16,16),G(16,16),B(16,16) FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG" CALL PICTURELOAD(N$,XSIZE,YSIZE) DIM M(XSIZE-1,YSIZE-1),MM(XSIZE-1,YSIZE-1),V(16) LET SW=0 !' 0 OR 1 LET BAND=8 !' 8 OR 16 ASK PIXEL ARRAY(0,0) M LOCATE VALUE NOWAIT(1),RANGE -8 TO 8,AT 0:L LOCATE VALUE NOWAIT(2),RANGE -8 TO 8,AT 0:H1 LOCATE VALUE NOWAIT(3),RANGE -8 TO 8,AT 0:H2 LOCATE VALUE NOWAIT(4),RANGE -8 TO 8,AT 0:H3 LOCATE VALUE NOWAIT(5),RANGE -8 TO 8,AT 0:H4 LOCATE VALUE NOWAIT(6),RANGE -8 TO 8,AT 0:H5 LOCATE VALUE NOWAIT(7),RANGE -8 TO 8,AT 0:H6 LOCATE VALUE NOWAIT(8),RANGE -8 TO 8,AT 0:H7 IF BAND=16 THEN LOCATE VALUE NOWAIT(9),RANGE -8 TO 8,AT 0:H8 LOCATE VALUE NOWAIT(10),RANGE -8 TO 8,AT 0:H9 LOCATE VALUE NOWAIT(11),RANGE -8 TO 8,AT 0:H10 LOCATE VALUE NOWAIT(12),RANGE -8 TO 8,AT 0:H11 LOCATE VALUE NOWAIT(13),RANGE -8 TO 8,AT 0:H12 LOCATE VALUE NOWAIT(14),RANGE -8 TO 8,AT 0:H13 LOCATE VALUE NOWAIT(15),RANGE -8 TO 8,AT 0:H14 LOCATE VALUE NOWAIT(16),RANGE -8 TO 8,AT 0:H15 END IF DO DO !'ウェイト。マウスでウィンドゥ内をクリックする。 IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP MOUSE POLL X,Y,LL,RR LOCATE VALUE NOWAIT(1):L LOCATE VALUE NOWAIT(2):H1 LOCATE VALUE NOWAIT(3):H2 LOCATE VALUE NOWAIT(4):H3 LOCATE VALUE NOWAIT(5):H4 LOCATE VALUE NOWAIT(6):H5 LOCATE VALUE NOWAIT(7):H6 LOCATE VALUE NOWAIT(8):H7 IF BAND=16 THEN LOCATE VALUE NOWAIT(9):H8 LOCATE VALUE NOWAIT(10):H9 LOCATE VALUE NOWAIT(11):H10 LOCATE VALUE NOWAIT(12):H11 LOCATE VALUE NOWAIT(13):H12 LOCATE VALUE NOWAIT(14):H13 LOCATE VALUE NOWAIT(15):H14 LOCATE VALUE NOWAIT(16):H15 END IF LOOP WHILE LL=0 AND RR=0 CLEAR LET V(0)=L LET V(1)=H1 LET V(2)=H2 LET V(3)=H3 LET V(4)=H4 LET V(5)=H5 LET V(6)=H6 LET V(7)=H7 LET V(8)=H8 LET V(9)=H9 LET V(10)=H10 LET V(11)=H11 LET V(12)=H12 LET V(13)=H13 LET V(14)=H14 LET V(15)=H15 SET TEXT HEIGHT YSIZE/10 SET COLOR COLORINDEX(0,0,0) SET TEXT BACKGROUND "OPAQUE" SET TEXT JUSTIFY "CENTER" , "TOP" PLOT TEXT ,AT XSIZE/2,YSIZE/2 :"処理中" FOR Y=0 TO YSIZE-1 STEP BAND SET TEXT JUSTIFY "LEFT" , "TOP" PLOT TEXT ,AT 0,0 :USING$("###.#",Y/(YSIZE-1)*100)&"%" FOR X=0 TO XSIZE-1 STEP BAND FOR J=SW TO BAND-1+SW FOR I=SW TO BAND-1+SW IF X+I-SW<=XSIZE-1 AND Y+J-SW<=YSIZE-1 THEN LET CC=M(X+I-SW,Y+J-SW) ELSE LET CC=0 END IF CALL RGB(CC,R(I,J),G(I,J),B(I,J)) NEXT I NEXT J IF SW=0 THEN CALL DCT(R,BAND) CALL DCT(G,BAND) CALL DCT(B,BAND) ELSEIF SW=1 THEN CALL DST(R,BAND) CALL DST(G,BAND) CALL DST(B,BAND) END IF FOR I=SW TO BAND-1+SW FOR J=SW TO BAND-1+SW LET R(I,J)=R(I,J)*(8+V(I))/8*(V(J)+8)/8 !'係数を掛ける。縦横で最大4倍する LET G(I,J)=G(I,J)*(8+V(I))/8*(V(J)+8)/8 LET B(I,J)=B(I,J)*(8+V(I))/8*(V(J)+8)/8 NEXT J NEXT I IF SW=0 THEN CALL IDCT(R,BAND) CALL IDCT(G,BAND) CALL IDCT(B,BAND) ELSEIF SW=1 THEN CALL IDST(R,BAND) CALL IDST(G,BAND) CALL IDST(B,BAND) END IF FOR J=SW TO BAND-1+SW FOR I=SW TO BAND-1+SW IF B(I,J)<0 THEN LET B(I,J)=0 IF G(I,J)<0 THEN LET G(I,J)=0 IF R(I,J)<0 THEN LET R(I,J)=0 IF B(I,J)>255 THEN LET B(I,J)=255 IF G(I,J)>255 THEN LET G(I,J)=255 IF R(I,J)>255 THEN LET R(I,J)=255 IF X+I-SW<=XSIZE-1 AND Y+J-SW<=YSIZE-1 THEN LET MM(X+I-SW,Y+J-SW)=SETRGB(INT(R(I,J)),INT(G(I,J)),INT(B(I,J))) NEXT I NEXT J NEXT X NEXT Y MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:MM LOOP END EXTERNAL FUNCTION C(X,N) IF X=0 OR X=N THEN LET C=SQR(.5) ELSE LET C=1 END FUNCTION EXTERNAL SUB DCT(S(,),N) OPTION BASE 0 DIM X(N),Y(N) FOR J=0 TO N-1 FOR I=0 TO N-1 LET X(I)=S(I,J) NEXT I CALL DCT2(X,N,Y) FOR I=0 TO N-1 LET S(I,J)=Y(I) NEXT I NEXT J FOR J=0 TO N-1 FOR I=0 TO N-1 LET X(I)=S(J,I) NEXT I CALL DCT2(X,N,Y) FOR I=0 TO N-1 LET S(J,I)=Y(I) NEXT I NEXT J END SUB EXTERNAL SUB DCT2(A(),N,B()) FOR I=0 TO N-1 LET S=0 FOR K=0 TO N-1 LET S=S+A(K)*COS((2*K+1)*I*PI/2/N) NEXT K LET B(I)=S*SQR(2/N)*C(I,N) NEXT I END SUB EXTERNAL SUB DCT3(A(),N,B()) FOR I=0 TO N-1 LET S=0 FOR K=0 TO N-1 LET S=S+C(K,N)*A(K)*COS((2*I+1)*K*PI/2/N) NEXT K LET B(I)=INT(S*SQR(2/N)+.5) NEXT I END SUB EXTERNAL SUB IDCT(S(,),N) OPTION BASE 0 DIM X(N),Y(N) FOR J=0 TO N-1 FOR I=0 TO N-1 LET X(I)=S(I,J) NEXT I CALL DCT3(X,N,Y) FOR I=0 TO N-1 LET S(I,J)=Y(I) NEXT I NEXT J FOR J=0 TO N-1 FOR I=0 TO N-1 LET X(I)=S(J,I) NEXT I CALL DCT3(X,N,Y) FOR I=0 TO N-1 LET S(J,I)=Y(I) NEXT I NEXT J END SUB EXTERNAL SUB DST(S(,),N) OPTION BASE 0 DIM X(N),Y(N) FOR J=1 TO N FOR I=1 TO N LET X(I)=S(I,J) NEXT I CALL DST2(X,N,Y) FOR I=1 TO N LET S(I,J)=Y(I) NEXT I NEXT J FOR J=1 TO N FOR I=1 TO N LET X(I)=S(J,I) NEXT I CALL DST2(X,N,Y) FOR I=1 TO N LET S(J,I)=Y(I) NEXT I NEXT J END SUB EXTERNAL SUB DST2(A(),N,B()) FOR K=1 TO N LET S=0 FOR I=1 TO N LET S=S+A(I)*SIN((2*I-1)*K*PI/2/N) NEXT I LET B(K)=S*SQR(2/N)*C(K,N) NEXT K END SUB EXTERNAL SUB DST3(A(),N,B()) FOR K=1 TO N LET S=0 FOR I=1 TO N LET S=S+C(I,N)*A(I)*SIN((2*K-1)*I*PI/2/N) NEXT I LET B(K)=INT(S*SQR(2/N)+.5) NEXT K END SUB EXTERNAL SUB IDST(S(,),N) OPTION BASE 0 DIM X(N),Y(N) FOR J=1 TO N FOR I=1 TO N LET X(I)=S(I,J) NEXT I CALL DST3(X,N,Y) FOR I=1 TO N LET S(I,J)=Y(I) NEXT I NEXT J FOR J=1 TO N FOR I=1 TO N LET X(I)=S(J,I) NEXT I CALL DST3(X,N,Y) FOR I=1 TO N LET S(J,I)=Y(I) NEXT I NEXT J END SUB EXTERNAL SUB RGB(X,R,G,B) LET B=MOD(INT(X/65536),256) LET G=MOD(INT(X/256),256) LET R=MOD(X,256) END SUB EXTERNAL FUNCTION SETRGB(R,G,B) LET R=MIN(255,MAX(R,0)) LET G=MAX(0,MIN(G,255)) LET B=MAX(0,MIN(B,255)) LET SETRGB=B*65536+G*256+R END FUNCTION EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE) CLEAR SET COLOR MODE "NATIVE" 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

画像ヒストグラム平坦化

投稿者：しばっち投稿日：2020年 5月24日(日)14時36分5秒

ヒストグラムを平坦化しコンストラストを改善します。モノクロ画像では濃度値に対して平坦化しますがカラー画像では、R,G,B各々に対してではなくHSVに変換して彩度(S)又は明度(V)に対して平坦化します。 https://qiita.com/Dason08/items/1b28e24d12630182fd69 https://algorithm.joho.info/image-processing/histogram-equalization/ PUBLIC NUMERIC XSIZE,YSIZE OPTION BASE 0 DIM HIST(255) FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG" CALL PICTURELOAD(N$,XSIZE,YSIZE) DIM M(XSIZE-1,YSIZE-1) ASK PIXEL ARRAY(0,0) M DIM OUT(XSIZE,YSIZE),IN(XSIZE,YSIZE) LET MODE=0 FOR Y=0 TO YSIZE-1 FOR X=0 TO XSIZE-1 CALL RGB(M(X,Y),R,G,B) CALL RGB2HSV(R,G,B,H,S,V) SELECT CASE MODE CASE 0 LET IN(X,Y)=S LET HIST(S)=HIST(S)+1 CASE 1 LET IN(X,Y)=V LET HIST(V)=HIST(V)+1 END SELECT NEXT X NEXT Y CALL PLANE(OUT,IN,HIST,XSIZE,YSIZE) FOR Y=0 TO YSIZE-1 FOR X=0 TO XSIZE-1 CALL RGB(M(X,Y),R,G,B) CALL RGB2HSV(R,G,B,H,S,V) SELECT CASE MODE CASE 0 CALL HSV2RGB(R,G,B,H,OUT(X,Y),V) CASE 1 CALL HSV2RGB(R,G,B,H,S,OUT(X,Y)) END SELECT LET M(X,Y)=SETRGB(R,G,B) NEXT X NEXT Y MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:M END EXTERNAL SUB PLANE(OUT(,),IN(,),HIST(),XSIZE,YSIZE) FOR Y=0 TO YSIZE-1 FOR X=0 TO XSIZE-1 FOR I=0 TO IN(X,Y) LET OUT(X,Y)=OUT(X,Y)+HIST(I) NEXT I LET OUT(X,Y)=INT(OUT(X,Y)*255/XSIZE/YSIZE) NEXT X NEXT Y END SUB EXTERNAL FUNCTION SETRGB(R,G,B) LET R=MIN(255,MAX(R,0)) LET G=MAX(0,MIN(G,255)) LET B=MAX(0,MIN(B,255)) LET SETRGB=B*65536+G*256+R END FUNCTION EXTERNAL SUB RGB(X,R,G,B) LET B=MOD(INT(X/65536),256) LET G=MOD(INT(X/256),256) LET R=MOD(X,256) END SUB 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 HSV2RGB(R,G,B,H,S,V) IF S=0 THEN LET R=V LET G=V LET B=V EXIT SUB END IF LET T=V-S*V/255 LET HH=H IF H>=300 OR H<60 THEN IF H>=300 THEN LET HH=360-HH IF H<60 THEN LET HH=-HH LET HH=HH/60 LET RR=0 IF HH<0 THEN LET BB=1 LET GG=HH+BB ELSE LET GG=1 LET BB=GG-HH END IF ELSEIF H>=60 AND H<180 THEN LET HH=HH-120 LET HH=HH/60 LET GG=0 IF HH<0 THEN LET BB=1 LET RR=HH+BB ELSE LET RR=1 LET BB=RR-HH END IF ELSEIF H>=180 AND H<300 THEN LET HH=HH-240 LET HH=HH/60 LET BB=0 IF HH<0 THEN LET RR=1 LET GG=HH+RR ELSE LET GG=1 LET RR=GG-HH END IF END IF LET R=-RR*(V-T)+V LET R=INT(R) LET G=-GG*(V-T)+V LET G=INT(G) LET B=-BB*(V-T)+V LET B=INT(B) END SUB EXTERNAL SUB RGB2HSV(R,G,B,H,S,V) LET V=MAX(MAX(R,G),B) LET T=MIN(MIN(R,G),B) IF V=0 THEN LET S=0 ELSE LET S=((V-T)*255)/V END IF IF S=0 THEN LET H=0 ELSE LET RR=(V-R)/(V-T) LET GG=(V-G)/(V-T) LET BB=(V-B)/(V-T) IF V=R THEN LET H=BB-GG ELSEIF V=G THEN LET H=2+RR-BB ELSEIF V=B THEN LET H=4+GG-RR END IF LET H=H*60 END IF IF H<0 THEN LET H=H+360 END SUB

Re: Reバージョンの修正をお願いします

投稿者：名無しさん投稿日：2020年 5月27日(水)16時32分12秒

> No.4821[元記事へ] Ver. 7.8.5.4ですが，支障ないようです。 10 SET LINE STYLE 2 20 PLOT LINES:0,0; 0,1 30 SET AREA COLOR 2 40 PLOT AREA : 0,0;1,0;0.5,1 50 END 　最新verをDLしたら直ってましたね(ver7.6.6では元のまま) 　この7.8.5.4と7.6.6の間に、修正したご記憶は持っていらっしゃるのですか？

ハノイの塔

投稿者：kikiriri 投稿日：2020年 5月28日(木)08時13分54秒

2＾ｎ-1 ｎ枚の円盤の時の最短移動回数です。

ハノイの塔の２

投稿者：kikiriri 投稿日：2020年 5月28日(木)08時20分0秒

なので、円盤の数が３枚の時 2＾３＝８８-1＝7 ７回これは、あっています。円盤の数が、１まいのとき、２＾１＝２２-1＝１これもあっています。円盤の数が２枚の時２＾２＝４４-１＝３これもあっています。４枚を超えると暗算では難しいですが。一般の式　2＾ｎ　　-　　1　　を使うと。２＾４＝１６１６-１は１５より１５回だと思われます。

Re: Reバージョンの修正をお願いします

投稿者：nagram 投稿日：2020年 5月28日(木)14時50分27秒

名無しさんさんへのお返事です。 > > No.4821[元記事へ] > > Ver. 7.8.5.4ですが，支障ないようです。 > > 10 SET LINE STYLE 2 > 20 PLOT LINES:0,0; 0,1 > 30 SET AREA COLOR 2 > 40 PLOT AREA : 0,0;1,0;0.5,1 > 50 END > > 　最新verをDLしたら直ってましたね(ver7.6.6では元のまま) > 　この7.8.5.4と7.6.6の間に、修正したご記憶は持っていらっしゃるのですか？ > 十進BASICに添付するファイル C:¥Program Files (x86)¥Decimal BASIC¥BASICw32¥REVISION.TXT の　[修正・変更の履歴]　に「Ver.7.8.5.2 PLOT AREA文がLINE STYLEの影響を受ける誤りを修正。」とあります。

不自由なハノイの塔

投稿者：しばっち投稿日：2020年 6月 3日(水)20時44分45秒

不自由なハノイの塔不自由なハノイの塔ではハノイの塔のルールに次の条件を加えます。 ●条件 1番上の1枚目の円盤は3本ある棒のうち、真ん中(の棒)には置いてはいけない。この条件を適用すると1枚目の円盤は奇数回毎に棒Aと棒Cを繰り返し移動します。すると偶数回で移動できる円盤は1通りしかありません。移動回数は 1枚の時、 1回 2枚の時、 5回 3枚の時、17回 4枚の時、53回となり、よって円盤がn枚の時は 2*3^(n-1)-1回となります。円盤が3枚の場合ですが、下記の実行結果を見ても1枚目の円盤は真ん中(の棒)にはありません。ちなみにNo.1までが円盤1枚の時の No.5までが円盤2枚の時の解答となります。その他棒の数を4本、5本と増やす流儀もあるようです。 LET N=3 DIM S(N,3),A$(N) MAT READ A$ PRINT "円盤";N;"枚" PRINT "No. 0" FOR K=1 TO N LET S(K,1)=1 PRINT A$(K) NEXT K FOR I=1 TO 2*3^(N-1)-1 IF MOD(I,2)=1 THEN LET J=1 SWAP S(1,1),S(1,3) ELSE FOR J=2 TO N IF S(1,1)=0 AND S(J-1,1)=0 AND S(J,1)=1 AND S(J,2)=0 OR S(1,1)=0 AND S(J-1,2)=0 AND S(J,2)=1 AND S(J,1)=0 THEN SWAP S(J,1),S(J,2) EXIT FOR END IF IF S(1,1)=0 AND S(J-1,1)=0 AND S(J,1)=1 AND S(J,3)=0 OR S(1,3)=0 AND S(1,1)=0 AND S(J-1,3)=0 AND S(J,3)=1 AND S(J,1)=0 THEN SWAP S(J,1),S(J,3) EXIT FOR END IF IF S(1,3)=0 AND S(J-1,3)=0 AND S(J,3)=1 AND S(J,2)=0 OR S(J,2)=1 AND S(J,3)=0 AND S(J-1,2)=0 THEN SWAP S(J,3),S(J,2) EXIT FOR END IF NEXT J END IF PRINT REPEAT$("-",78) PRINT "No.";I FOR J=1 TO N FOR K=1 TO 3 IF S(J,K)=1 THEN PRINT A$(J) EXIT FOR END IF PRINT REPEAT$(" ",26); NEXT K NEXT J NEXT I DATA " ■ " DATA " ■■■ " DATA " ■■■■■ " DATA " ■■■■■■■ " DATA " ■■■■■■■■■ " DATA " ■■■■■■■■■■■ " END 実行結果円盤 3 枚 No. 0 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 1 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 2 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 3 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 4 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 5 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 6 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 7 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 8 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 9 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 10 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 11 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 12 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 13 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 14 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 15 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 16 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 17 ■ ■■■ ■■■■■

不自由なハノイの塔

投稿者：kikiriri 投稿日：2020年 6月 4日(木)06時53分30秒

しばっち様へいいですね。

Re: 不自由なハノイの塔

投稿者：しばっち投稿日：2020年 6月 7日(日)14時28分53秒

> No.4835[元記事へ] 不自由なハノイの塔 ●条件 2枚目は真ん中(の棒)には置けない (N>=2) LET N=3 !' N>=2 DIM S(N,3),A$(0 TO N) MAT READ A$ PRINT "円盤";N;"枚" PRINT "No. 0" FOR K=1 TO N LET S(K,1)=1 PRINT A$(K) NEXT K FOR I=1 TO 4*3^(N-2)-1 IF MOD(I,2)=1 THEN LET S(1,1)=0 LET S(1,2)=0 LET S(1,3)=0 LET L=MOD(L,4)+1 SELECT CASE L CASE 1 LET S(1,2)=1 CASE 2 LET S(1,3)=1 CASE 3 LET S(1,2)=1 CASE 4 LET S(1,1)=1 END SELECT ELSEIF MOD(I,4)=2 THEN SWAP S(2,1),S(2,3) ELSE FOR J=3 TO N IF S(J-1,1)=0 AND S(J,1)=1 AND S(J-1,2)=0 OR S(J-1,2)=0 AND S(J,2)=1 AND S(J-1,1)=0 THEN SWAP S(J,1),S(J,2) EXIT FOR END IF IF S(J-1,1)=0 AND S(J,1)=1 AND S(J-1,3)=0 OR S(J-1,3)=0 AND S(J,3)=1 AND S(J-1,1)=0 THEN SWAP S(J,1),S(J,3) EXIT FOR END IF IF S(J-1,3)=0 AND S(J,3)=1 AND S(J-1,2)=0 OR S(J-1,3)=0 AND S(J-1,2)=0 AND S(J,2)=1 THEN SWAP S(J,3),S(J,2) EXIT FOR END IF NEXT J END IF PRINT REPEAT$("-",LEN(A$(0))*3) PRINT "No.";I FOR J=1 TO N FOR K=1 TO 3 IF S(J,K)=1 THEN PRINT A$(J) EXIT FOR END IF PRINT A$(0); NEXT K NEXT J NEXT I DATA " " DATA " ■ " DATA " ■■■ " DATA " ■■■■■ " DATA " ■■■■■■■ " DATA " ■■■■■■■■■ " DATA " ■■■■■■■■■■■ " DATA " ■■■■■■■■■■■■■ " END 実行結果円盤 3 枚 No. 0 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------------------ No. 1 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------------------ No. 2 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------------------ No. 3 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------------------ No. 4 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------------------ No. 5 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------------------ No. 6 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------------------ No. 7 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------------------ No. 8 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------------------ No. 9 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------------------ No. 10 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------------------ No. 11 ■ ■■■ ■■■■■

Re: 不自由なハノイの塔

投稿者：しばっち投稿日：2020年 6月 7日(日)14時29分41秒

> No.4835[元記事へ] 不自由なハノイの塔 ●条件 3枚目は真ん中(の棒)には置けない (N>=3) LET N=4 !'N>=3 DIM S(N,3),A$(0 TO N) MAT READ A$ PRINT "円盤";N;"枚" PRINT "No. 0" FOR K=1 TO N LET S(K,1)=1 PRINT A$(K) NEXT K FOR I=1 TO 8*3^(N-3)-1 IF MOD(I,2)=1 THEN IF MOD(I,16)<=8 THEN LET L2=0 LET S(1,1)=0 LET S(1,2)=0 LET S(1,3)=0 LET L1=MOD(L1,3)+1 SELECT CASE L1 CASE 1 LET S(1,3)=1 CASE 2 LET S(1,2)=1 CASE 3 LET S(1,1)=1 END SELECT ELSE LET L1=0 LET S(1,1)=0 LET S(1,2)=0 LET S(1,3)=0 LET L2=MOD(L2,3)+1 SELECT CASE L2 CASE 1 LET S(1,1)=1 CASE 2 LET S(1,2)=1 CASE 3 LET S(1,3)=1 END SELECT END IF ELSEIF MOD(I,8)=4 THEN SWAP S(3,1),S(3,3) ELSEIF MOD(I,4)=2 THEN LET S(2,1)=0 LET S(2,2)=0 LET S(2,3)=0 LET L3=MOD(L3,4)+1 SELECT CASE L3 CASE 1 LET S(2,2)=1 CASE 2 LET S(2,3)=1 CASE 3 LET S(2,2)=1 CASE 4 LET S(2,1)=1 END SELECT ELSE FOR J=4 TO N IF S(J-1,1)=0 AND S(J,1)=1 AND S(J-1,2)=0 OR S(J-1,2)=0 AND S(J,2)=1 AND S(J-1,1)=0 THEN SWAP S(J,1),S(J,2) EXIT FOR END IF IF S(J-1,1)=0 AND S(J,1)=1 AND S(J-1,3)=0 OR S(J-1,3)=0 AND S(J,3)=1 AND S(J-1,1)=0 THEN SWAP S(J,1),S(J,3) EXIT FOR END IF IF S(J-1,3)=0 AND S(J,3)=1 AND S(J-1,2)=0 OR S(J-1,3)=0 AND S(J-1,2)=0 AND S(J,2)=1 THEN SWAP S(J,3),S(J,2) EXIT FOR END IF NEXT J END IF PRINT REPEAT$("-",LEN(A$(0))*3) PRINT "No.";I FOR J=1 TO N FOR K=1 TO 3 IF S(J,K)=1 THEN PRINT A$(J) EXIT FOR END IF PRINT A$(0); NEXT K NEXT J NEXT I DATA " " DATA " ■ " DATA " ■■■ " DATA " ■■■■■ " DATA " ■■■■■■■ " DATA " ■■■■■■■■■ " DATA " ■■■■■■■■■■■ " DATA " ■■■■■■■■■■■■■ " END 実行結果円盤 4 枚 No. 0 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 1 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 2 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 3 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 4 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 5 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 6 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 7 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 8 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 9 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 10 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 11 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 12 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 13 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 14 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 15 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 16 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 17 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 18 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 19 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 20 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 21 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 22 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------------------------ No. 23 ■ ■■■ ■■■■■ ■■■■■■■

不自由なハノイの塔(再帰版)

投稿者：しばっち投稿日：2020年 6月11日(木)19時25分12秒

不自由なハノイの塔(再帰版) ●条件 1枚目は真ん中に置けない移動回数 2*3^(N-1)-1 PUBLIC NUMERIC COUNT LET N=3 CALL HANOI(N,1,2,3) END EXTERNAL SUB HANOI(N,A,B,C) !' N>=1 IF N=1 THEN CALL DISPLAY(N,A,C) ELSE CALL HANOI(N-1,A,B,C) CALL DISPLAY(N,A,B) CALL HANOI(N-1,C,B,A) CALL DISPLAY(N,B,C) CALL HANOI(N-1,A,B,C) END IF END SUB EXTERNAL SUB DISPLAY(N,A,B) LET COUNT=COUNT+1 PRINT "No.";COUNT;N;"枚目を ";MID$("ABC",A,1);" から ";MID$("ABC",B,1);" へ" END SUB 実行結果 No. 1 1 枚目を A から C へ No. 2 2 枚目を A から B へ No. 3 1 枚目を C から A へ No. 4 2 枚目を B から C へ No. 5 1 枚目を A から C へ No. 6 3 枚目を A から B へ No. 7 1 枚目を C から A へ No. 8 2 枚目を C から B へ No. 9 1 枚目を A から C へ No. 10 2 枚目を B から A へ No. 11 1 枚目を C から A へ No. 12 3 枚目を B から C へ No. 13 1 枚目を A から C へ No. 14 2 枚目を A から B へ No. 15 1 枚目を C から A へ No. 16 2 枚目を B から C へ No. 17 1 枚目を A から C へ

不自由なハノイの塔(再帰版)

投稿者：しばっち投稿日：2020年 6月11日(木)19時26分0秒

不自由なハノイの塔(再帰版) ●条件 2枚目は真ん中に置けない(n>=2) 移動回数 4*3^(N-2)-1 PUBLIC NUMERIC COUNT,S(7,3),NN PUBLIC STRING D$(0 TO 7) LET NN=3 !' NN>=2 MAT READ D$ PRINT "円盤";NN;"枚" PRINT "No. 0" FOR K=1 TO NN LET S(K,1)=1 PRINT D$(K) NEXT K CALL HANOI(NN,1,2,3) DATA " " DATA " ■ " DATA " ■■■ " DATA " ■■■■■ " DATA " ■■■■■■■ " DATA " ■■■■■■■■■ " DATA " ■■■■■■■■■■■ " DATA " ■■■■■■■■■■■■■ " END EXTERNAL SUB HANOI(N,A,B,C) !' N>=2 IF N=2 THEN CALL DISPLAY(1,A,B) CALL DISPLAY(2,A,C) CALL DISPLAY(1,B,C) ELSE CALL HANOI(N-1,A,B,C) CALL DISPLAY(N,A,B) CALL HANOI(N-1,C,B,A) CALL DISPLAY(N,B,C) CALL HANOI(N-1,A,B,C) END IF END SUB EXTERNAL SUB DISPLAY(N,A,B) LET S(N,A)=0 LET S(N,B)=1 PRINT REPEAT$("-",LEN(D$(0))*3) LET COUNT=COUNT+1 PRINT "No.";COUNT FOR J=1 TO NN FOR K=1 TO 3 IF S(J,K)=1 THEN PRINT D$(J) EXIT FOR END IF PRINT D$(0); NEXT K NEXT J END SUB 実行結果円盤 3 枚 No. 0 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 1 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 2 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 3 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 4 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 5 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 6 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 7 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 8 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 9 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 10 ■ ■■■ ■■■■■ ------------------------------------------------------------------------------ No. 11 ■ ■■■ ■■■■■

不自由なハノイの塔(再帰版)

投稿者：しばっち投稿日：2020年 6月11日(木)19時26分49秒

不自由なハノイの塔(再帰版) ●条件 m枚目は真ん中に置けない(n>=m) 移動回数 2^m*3^(n-m)-1 PUBLIC NUMERIC COUNT,INIT,NN CALL GINIT(800,400) INPUT PROMPT "枚数=":NN INPUT PROMPT "真ん中に置けない円盤 No.=":M FOR I=1 TO NN CALL DISPLAY(I,2,1) NEXT I LET INIT=1 WAIT DELAY .5 CALL HANOI(NN,M,1,2,3) END EXTERNAL SUB HANOI(N,M,A,B,C) !' N>=M IF N<=M THEN CALL HANOI_SUB(N,A,B,C) ELSE CALL HANOI(N-1,M,A,B,C) CALL DISPLAY(N,A,B) CALL HANOI(N-1,M,C,B,A) CALL DISPLAY(N,B,C) CALL HANOI(N-1,M,A,B,C) END IF END SUB EXTERNAL SUB HANOI_SUB(N,A,B,C) IF N>0 THEN CALL HANOI_SUB(N-1,A,C,B) CALL DISPLAY(N,A,C) CALL HANOI_SUB(N-1,B,A,C) END IF END SUB EXTERNAL SUB DISPLAY(N,A,B) IF INIT=1 THEN LET COUNT=COUNT+1 PLOT TEXT,AT 30,0:"No."&STR$(COUNT) WAIT DELAY 1/10 END IF LET HEIGHT=INT(330/NN) LET WIDTH=INT(180/NN) CALL BOXFULL(200*A-WIDTH/2*N,50+HEIGHT*(N-1),200*A+WIDTH/2*N,50+HEIGHT*N,0) CALL BOXFULL(200*B-WIDTH/2*N,50+HEIGHT*(N-1),200*B+WIDTH/2*N,50+HEIGHT*N,7) END SUB EXTERNAL SUB GINIT(XSIZE,YSIZE) SET BITMAP SIZE XSIZE,YSIZE SET WINDOW 0,XSIZE-1,YSIZE-1,0 SET POINT STYLE 1 SET COLOR MODE "REGULAR" SET COLOR MIX(0) 0,0,0 SET COLOR MIX(1) 0,0,1 SET COLOR MIX(2) 1,0,0 SET COLOR MIX(3) 1,0,1 SET COLOR MIX(4) 0,1,0 SET COLOR MIX(5) 0,1,1 SET COLOR MIX(6) 1,1,0 SET COLOR MIX(7) 1,1,1 SET TEXT HEIGHT 20 SET TEXT JUSTIFY "LEFT" , "TOP" SET TEXT BACKGROUND "OPAQUE" SET TEXT COLOR 7 CLEAR END SUB EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C) SET COLOR C PLOT AREA:X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1 END SUB

ソースファイル分割

投稿者：Bsitumonn 投稿日：2020年 6月15日(月)17時51分15秒

C言語のように、十進BASICでソースファイルを分割し、ソースファイルAで用意した配列に対して、ソースファイルBでその要素を検査(行列の階数を調べる)ことはできないのでしょうか？できるかできないかお返事お願いします。下に自分の作ったhakidasi.BASからkaidan.BASが呼び出せるか試した、2つのソースファイルを掲載します。 !hakidasi.BAS REM SET ZONEWIDTH 3 INPUT PROMPT "行の長さ":a INPUT PROMPT "列の長さ":b INPUT PROMPT "出力蘭の幅":c SET ZONEWIDTH c DIM hai(a,b) DIM retubeku(a,1) FOR i=LBOUND(retubeku,1) TO UBOUND(retubeku,1) LET retubeku(i,1)=INT(10*RND) PRINT retubeku(i,1), PRINT NEXT i RANDOMIZE FOR i=LBOUND(hai,1) TO UBOUND(hai,1) FOR j=LBOUND(hai,2) TO UBOUND(hai,2) LET hai(i,j)=INT(10*RND) REM PRINT hai(i,j), NEXT j PRINT NEXT i DIM sagyouhai(a,b+1) FOR i=LBOUND(sagyouhai,1) TO UBOUND(sagyouhai,1) FOR j=LBOUND(sagyouhai,2) TO UBOUND(sagyouhai,2) IF (j<=b) THEN LET sagyouhai(i,j)=hai(i,j) ELSE LET sagyouhai(i,j)=retubeku(i,1) END IF PRINT sagyouhai(i,j), NEXT j PRINT NEXT i REM execute "BASIC.EXE" WITH("kaidan.BAS") !別の十進BASICファイルの呼び出し。 REM CALL kaidan.BAS　　　　　　　　　　　　!別の十進BASICファイルの呼び出し。 END ! kaidan.BAS PRINT "階段.bas" END

Re: ソースファイル分割

投稿者：SHIRAISHI Kazuo 投稿日：2020年 6月16日(火)16時57分9秒

> No.4843[元記事へ] CのincludeみたいなことをしたいのであればMERGE文が使える可能性があります。 https://decimalbasic.ninja-web.net/BASICHelp/BASICHelp.html

Re: ソースファイル分割

投稿者：Bsitumonn 投稿日：2020年 6月16日(火)23時37分45秒

SHIRAISHI Kazuoさんへのお返事です。 MERGE文の紹介ありがとうございます。MERGE文をつかったところ、 MERGE文の使用法がわからないので質問します。 kaidan.BASに、retubeku(1,1)=0(retubekuはhakidasi.BASで宣言した配列)と書いて、hakidasi.BASのENDの後、最後尾にMERGE "kaidan.BAS"とかいて、実行すると、retubekuはここにかけません。というエラーがでました。また、Libraryサブディレクトリの、APISUP1.LIBにある関数が利用できれば、ソースファイルAの配列をソースファイルBに書いた関数にわたして、処理できると思ったので、 Libraryサブディレクトリの、APISUP1.LIBにある EXTERNAL FUNCTION DWORD$(n)のnに引数を与えて呼び出す方法と、hakidasi.BASの配列をkaidan.BASに渡して、配列の中身を表示する方法をおしえてください。よろしくおねがいします。

Re: ソースファイル分割

投稿者：SHIRAISHI Kazuo 投稿日：2020年 6月17日(水)07時48分26秒

MERGE文は，翻訳時にテキストを合体させるだけです。ただし，プログラム単位あるいはモジュールの外に書かなければいけないという制約があるので，実質，プログラム単位あるいはモジュールごとの分割になります。 MERGEされる側の問題でエラーが出る場合，デバッグは容易ではありません。その部分に読み込むべきテキストを合体させてテストしてください。

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

Re: ソースファイル分割

投稿者：しばっち投稿日：2020年 6月17日(水)19時28分28秒

> No.4843[元記事へ] Bsitumonnさんへのお返事です。もしかして、下記のようなプログラムのことではないでしょうか? -------------------------------------------------------------- example.bas RANDOMIZE LET N=100 DIM A(N) FOR I=1 TO N LET A(I)=INT(RND*1000) NEXT I CHAIN "test.bas" WITH (N,A) END -------------------------------------------------------------- test.bas PROGRAM SAMPLE(N,A()) FOR I=1 TO N PRINT A(I) NEXT I END

Re: ソースファイル分割

投稿者：Bsitumonn 投稿日：2020年 6月18日(木)04時13分37秒

> No.4847[元記事へ] しばっちさんへのお返事です。ソースファイルの紹介ありがとうございます。コピーしてファイル名を少し変更し実行したところ test.BASのPROGRAM文でextype4301 引数の個数の過不足や型の不一致がおこりました。 (N=100とDebugウィンドウに表示はされた。） PROGRAM文のあとを、test.BASにしてみたり、test.BAS側の変数名を変えてみたりしましたが、回避できません。よろしければ回避方法を教えてください。

Re: ソースファイル分割

投稿者：SHIRAISHI Kazuo 投稿日：2020年 6月18日(木)07時42分36秒

> No.4848[元記事へ] CHAIN文やEXECUTE文を用いるとき引数がWindowsのコマンドラインを通じて渡されることに留意してください。 https://support.microsoft.com/ja-jp/help/2823587

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

Re: ソースファイル分割

投稿者：しばっち投稿日：2020年 6月18日(木)19時44分38秒

> No.4848[元記事へ] Bsitumonnさんへのお返事です。 > test.BASのPROGRAM文でextype4301 引数の個数の過不足や型の不一致がおこりました。 > (N=100とDebugウィンドウに表示はされた。） > PROGRAM文のあとを、test.BASにしてみたり、test.BAS側の変数名を変えてみたりしましたが、回避できません。 > よろしければ回避方法を教えてください。こちらでは問題なかったので試してみました。 2進モード、複素数モード以外ではおっしゃる通りのエラーが出るようですね。逆に2進モード、複素数モードではN=100000でも問題なく動きました。 Lazarus版十進BASICでも同様な現象が見られましたので十進BASIC側のバグにも思われますが、そういう仕様なのかもしれません。いつもは2進モードで実行しているので気が付きませんでした。 P.S 初期起動モード設定をBASIC.INIに記述して起動モードを10進モードから他へ変更できるようにできませんか? 10進モードはほとんど使用していません。 P.S DWORD$関数は既にシステムに組み込まれていますので最新版をご使用ならAPISUP1.LIBは必要はありません。 (※Windows版十進BASIC ver7.8.5.4を使用) OPTION CHARACTER BYTE LET A$=DWORD$(12345678) DIM S(4) FOR I=1 TO 4 LET S(I)=ORD(A$(I:I)) PRINT S(I); NEXT I PRINT PRINT S(1)+S(2)*256+S(3)*256^2+S(4)*256^3 END

Re: ソースファイル分割

投稿者：SHIRAISHI Kazuo 投稿日：2020年 6月19日(金)07時24分2秒

> No.4850[元記事へ] CHAIN文はバグのようです。 2進モード，複素数モードで正しく動くという情報でバグの所在が絞られました。

Re: ソースファイル分割

投稿者：SHIRAISHI Kazuo 投稿日：2020年 6月19日(金)16時22分40秒

> No.4850[元記事へ] しばっちさんへのお返事です。 > 初期起動モード設定をBASIC.INIに記述して起動モードを10進モードから他へ変更できるようにできませんか? BASIC.iniの[frame]セクションに OptionArithmetic=2 を書くと2進モードで起動するようにします。モードの番号は十進 0 十進1000桁　1 2進 2 複素数　　　3 有理数　　　4 です。

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

Re: ソースファイル分割

投稿者：Bsitumonn 投稿日：2020年 6月20日(土)20時18分0秒

> No.4852[元記事へ] SHIRAISHI Kazuoさんへのお返事です。いろいろ教えていただきありがとうございました。

ハノイの塔

投稿者：しばっち投稿日：2020年 6月28日(日)19時21分44秒

ハノイの塔をバックトラック法により全探索します。このプログラムでは普通のハノイの塔も求められますが、ここでは円盤4枚の4本ハノイの塔を求めてみました。ネット上より入手した最少移動回数のデータを使用しています。実行すると22通りもの解を得られました。下記の実行結果はその1解です。棒3本では最少移動回数による解は1通りしかありませんが、4本以上になると自由度が増え複数の解が存在します。該当する部分を注釈にするか削除する等すれば最少移動回数以外の解も表示します。このプログラムでは枚数をNとすると、2^N進法を使って円盤の状態を記録します。 1枚目を2^0、2枚目を2^1、3枚目を2^2とし、N枚目を2^(N-1)とします。そして一番右端(の棒)から左に向かって位が上がっていきます。円盤4枚、棒4本の初期値は [15 0 0 0]でその意味は {2^4}^3*[2^3+2^2+2^1+2^0]+{2^4}^2*0+{2^4}^1*0+{2^4}^0*0で最大値になります。これを[0 0 0 15]の最小値が目的の状態になります。{2^4}^3*0+{2^4}^2*0+{2^4}^1*0+{2^4}^0*[2^3+2^2+2^1+2^0] このプログラムでは注意点があります。もしも、"オーバーフローエラー"と表示されたら精度が不足しています。 1000桁モードや有理数モードを使用すれば解決しますが、ビット演算(BITAND 等)命令が53ビットまでしか対応していないので必要なら自前で定義する必要があります。また、棒の数が増えると組合せが膨大になり計算に時間がかかります。全解ではなく1解でいい場合は表示後にSTOP文を入れてください。 http://oeis.org/A007664 http://oeis.org/A007665 https://oeis.org/search?q=Tower+of+Hanoi+with+6+pegs&sort=&language=&go=Search PUBLIC NUMERIC NN,MM,LIMIT,PEG(0 TO 9),COUNT PUBLIC STRING D$(200) DIM S(0 TO 200) !'スタック(200回以上の場合は増やしてください) !'''INPUT PROMPT "円盤の枚数=":NN !'''INPUT PROMPT "棒の本数=":MM LET NN=4 !' 円盤の枚数 LET MM=4 !' 棒の本数 SELECT CASE MM CASE IS<=2 PRINT "解なし!" STOP CASE 3 RESTORE 3 CASE 4 RESTORE 4 CASE 5 RESTORE 5 CASE 6 RESTORE 6 CASE 7 RESTORE 7 CASE 8 RESTORE 8 CASE 9 RESTORE 9 CASE 10 RESTORE 10 CASE ELSE RESTORE 100 END SELECT FOR I=1 TO NN READ LIMIT !'最少移動回数 IF LIMIT>2000 THEN EXIT FOR NEXT I LET PEG(MM-1)=2^NN-1 LET S(0)=STATUS(PEG) !'円盤の状態を 2^NN 進法で表し、配列Sに記録する IF POS(STR$(S(0)),"E")>0 THEN PRINT "オーバーフローエラー" STOP END IF CALL HANOI(S,0,NN) !' 以下はネット上より入手した最少移動回数データ 3 DATA 1, 3, 7, 15, 31, 63, 127, 100000000 ! 棒 3本時の最少移動回数 (8枚以上は無効) 4 DATA 1, 3, 5, 9, 13, 17, 25, 33, 41, 49, 65, 81, 97, 113, 129, 161, 193, 100000000 ! 棒 4本時の最少移動回数 5 DATA 1, 3, 5, 7, 11, 15, 19, 23, 27, 31, 39, 47, 55, 63, 71, 79, 87, 95, 103, 100000000! 棒 5本時の最少移動回数 6 DATA 1, 3, 5, 7, 9, 13, 17, 21, 25, 29, 33, 37, 41, 45, 49, 57, 65, 73, 81, 100000000 ! 棒 6本時の最少移動回数 7 DATA 1, 3, 5, 7, 9, 11, 15, 19, 23, 27, 31, 35, 39, 43, 47, 51, 55, 59, 63, 100000000 ! 棒 7本時の最少移動回数 8 DATA 1, 3, 5, 7, 9, 11, 13, 17, 21, 25, 29, 33, 37, 41, 45, 49, 53, 57, 61, 100000000 ! 棒 8本時の最少移動回数 9 DATA 1, 3, 5, 7, 9, 11, 13, 15, 19, 23, 27, 31, 35, 39, 43, 47, 51, 55, 59, 100000000 ! 棒 9本時の最少移動回数 10 DATA 1, 3, 5, 7, 9, 11, 13, 15, 17, 21, 25, 29, 33, 37, 41, 45, 49, 53, 57, 100000000 ! 棒 10本時の最少移動回数 100 DATA 100000000 END EXTERNAL SUB HANOI(S(),SP,II) IF SP>LIMIT THEN EXIT SUB !'最少移動回数を超えたら戻る(ここを外すと最少移動回数以外も探索します) FOR I=0 TO SP-1 IF S(I)=S(SP) THEN EXIT SUB !'以前にあった状態と同じなら戻る NEXT I IF S(SP)=2^NN-1 THEN !'右端へ移動し終えたなら表示 LET COUNT=COUNT+1 PRINT COUNT;"解" CALL DISPLAY(S,SP) !''CALL DISPLAY2(D$,SP) PRINT PRINT " --- E N D ---" PRINT !'''STOP !!ここの注釈を外すと1解のみの表示になります。 EXIT SUB END IF CALL GETSTATUS(S(SP),PEG) !' 各棒の円盤の状態 FOR I=0 TO NN-1 IF I<>II THEN !'前回と違う円盤を移動させる FOR J=MM-1 TO 0 STEP -1 !' I番目をJ から Kへ左端の棒が MM-1 右端の棒が 0 LET TOP=BITAND(PEG(J),-PEG(J)) !'一番上の円盤 IF BITAND(PEG(J),2^I)>0 AND TOP=2^I THEN !'移動させる円盤がある棒 FOR K=0 TO MM-1 IF J<>K THEN !'移動元と移動先は違う棒 LET TOP=BITAND(PEG(K),-PEG(K)) !'一番上の円盤 IF (TOP>2^I OR TOP=0) AND BITAND(PEG(K),2^I)=0 THEN !'移動可能なら LET PJ=PEG(J) LET PEG(J)=BITXOR(PEG(J),2^I) !'棒J 上の円盤をリセット LET PK=PEG(K) LET PEG(K)=BITOR(PEG(K),2^I) !'棒K 上に円盤をセット LET S(SP+1)=STATUS(PEG) !''LET D$(SP+1)=STR$(I+1)&" 枚目を棒 "&MID$("ABCDEFGHIJ",MM-J,1)&" から棒 "&MID$("ABCDEFGHIJ",MM-K,1)&" へ" CALL HANOI(S,SP+1,I) !'再帰呼出し(バックトラック法) !''LET D$(SP+1)="" LET PEG(J)=PJ LET PEG(K)=PK LET S(SP+1)=STATUS(PEG) END IF END IF NEXT K END IF NEXT J END IF NEXT I END SUB EXTERNAL FUNCTION STATUS(PEG()) FOR I=MM-1 TO 0 STEP -1 LET SS=SS+(2^NN)^I*PEG(I) NEXT I LET STATUS=SS END FUNCTION EXTERNAL SUB GETSTATUS(N,PEG()) FOR I=MM-1 TO 0 STEP -1 LET PEG(I)=MOD(INT(N/(2^NN)^I),2^NN) NEXT I END SUB EXTERNAL SUB DISPLAY(S(),SP) DIM A$(NN) FOR I=1 TO NN LET A$(I)=REPEAT$(" ",2*NN-2*(I-1))&REPEAT$("■",2*I-1)&REPEAT$(" ",2*NN-2*(I-1)) NEXT I FOR I=0 TO SP PRINT REPEAT$("-",MM*(4*NN+2)) PRINT "No.";I FOR J=0 TO NN-1 FOR K=MM-1 TO 0 STEP -1 LET L=MOD(INT(S(I)/(2^NN)^K),2^NN) IF BITAND(L,2^J)>0 THEN PRINT A$(J+1) EXIT FOR END IF PRINT REPEAT$(" ",4*NN+2); NEXT K NEXT J NEXT I END SUB EXTERNAL SUB DISPLAY2(D$(),SP) FOR I=1 TO SP PRINT "No.";I;" : ";D$(I) NEXT I END SUB 実行結果 1 解 ------------------------------------------------------------------------ No. 0 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------ No. 1 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------ No. 2 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------ No. 3 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------ No. 4 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------ No. 5 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------ No. 6 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------ No. 7 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------ No. 8 ■ ■■■ ■■■■■ ■■■■■■■ ------------------------------------------------------------------------ No. 9 ■ ■■■ ■■■■■ ■■■■■■■ --- E N D --- 以下略

ハノイの塔の最少移動回数

投稿者：しばっち投稿日：2020年 6月28日(日)19時23分48秒

ハノイの塔の最少移動回数を求める ! Frame-Stewart algorithm PUBLIC NUMERIC S(64,15) !'表引き FOR PEG=3 TO 10 PRINT "棒";PEG;"本" FOR N=1 TO 10 PRINT N;"枚";HANOI(N,PEG);"回" NEXT N PRINT NEXT PEG !'''PRINT HANOI(64,4) END EXTERNAL FUNCTION LMIN(ABC(),N) LET AMIN = ABC(0) FOR I=1 TO N-1 IF ABC(I)<AMIN THEN LET AMIN = ABC(I) END IF NEXT I LET LMIN=AMIN END FUNCTION EXTERNAL FUNCTION HANOI(N,PEG) DIM MOVES(0 TO N-1) IF PEG<3 OR N=0 THEN LET HANOI=0 EXIT FUNCTION END IF IF N=1 THEN LET HANOI=1 EXIT FUNCTION END IF IF PEG=3 THEN LET HANOI=2^N-1 EXIT FUNCTION END IF IF PEG>3 THEN FOR I=1 TO N-1 IF S(N-I,PEG)=0 THEN LET L=HANOI(N-I,PEG) ELSE LET L=S(N-I,PEG) IF S(I,PEG-1)=0 THEN LET P=HANOI(I,PEG-1) ELSE LET P=S(I,PEG-1) LET MOVES(I-1)=2 * L + P NEXT I LET K=LMIN(MOVES, N-1) LET S(N,PEG)=K LET HANOI=K EXIT FUNCTION END IF END FUNCTION インドのガンジス河の畔のヴァラナシ（ベナレス）に、世界の中心を表すという巨大な寺院がある。そこには青銅の板の上に、3本のダイヤモンドの柱が立てられている。そのうちの1本には、天地創造のときに神が64枚の純金の円盤を大きい円盤から順に重ねて置いた。司祭たちはそこで、昼夜を通して円盤を別の柱に移し替えている。そして、全ての円盤の移し替えが終わったときに、世界は崩壊し終焉を迎える。以上はフランスの数学者エドゥアール・リュカによる作り話です。 https://ja.wikipedia.org/wiki/ハノイの塔 64枚の円盤を移動させるには、最低でも 2^64-1回 = 18446744073709551615回かかり、1枚移動させるのに1秒かかったとすると、約5845億年かかるもし、これが棒4本だったら? 円盤64枚でも4本だと移動回数は18433回となり、世界はわずか5時間程で終焉を迎えてしまう。 ※英語圏ではハノイの塔は棒ではなく、peg(杭)というようだ。

4本ハノイの塔

投稿者：しばっち投稿日：2020年 7月 1日(水)20時17分3秒

4本ハノイの塔 PUBLIC NUMERIC COUNT,S(8,4),NN PUBLIC STRING D$(0 TO 8) MAT READ D$ INPUT NN PRINT "No. 0" FOR K=1 TO NN LET S(K,1)=1 PRINT D$(K) NEXT K CALL HANOI(NN,1,2,3,4) DATA " " DATA " ■ " DATA " ■■■ " DATA " ■■■■■ " DATA " ■■■■■■■ " DATA " ■■■■■■■■■ " DATA " ■■■■■■■■■■■ " DATA " ■■■■■■■■■■■■■ " DATA " ■■■■■■■■■■■■■■■ " END EXTERNAL SUB HANOI(N,A,B,C,D) IF N=1 THEN CALL DISPLAY(1,A,D) ELSEIF N=2 THEN CALL DISPLAY(1,A,B) CALL DISPLAY(2,A,D) CALL DISPLAY(1,B,D) ELSE CALL HANOI(N-2,A,C,D,B) CALL DISPLAY(N-1,A,C) CALL DISPLAY(N,A,D) CALL DISPLAY(N-1,C,D) CALL HANOI(N-2,B,A,C,D) END IF END SUB EXTERNAL SUB DISPLAY(N,A,B) LET S(N,A)=0 LET S(N,B)=1 PRINT REPEAT$("-",LEN(D$(0))*4) LET COUNT=COUNT+1 PRINT "No.";COUNT FOR J=1 TO NN FOR K=1 TO 4 IF S(J,K)=1 THEN PRINT D$(J) EXIT FOR END IF PRINT D$(0); NEXT K NEXT J END SUB 実行結果 ? 5 No. 0 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■ ---------------------------------------------------------------------------------------------------------------------------------------- No. 1 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■ ---------------------------------------------------------------------------------------------------------------------------------------- No. 2 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■ ---------------------------------------------------------------------------------------------------------------------------------------- No. 3 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■ ---------------------------------------------------------------------------------------------------------------------------------------- No. 4 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■ ---------------------------------------------------------------------------------------------------------------------------------------- No. 5 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■ ---------------------------------------------------------------------------------------------------------------------------------------- No. 6 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■ ---------------------------------------------------------------------------------------------------------------------------------------- No. 7 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■ ---------------------------------------------------------------------------------------------------------------------------------------- No. 8 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■ ---------------------------------------------------------------------------------------------------------------------------------------- No. 9 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■ ---------------------------------------------------------------------------------------------------------------------------------------- No. 10 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■ ---------------------------------------------------------------------------------------------------------------------------------------- No. 11 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■ ---------------------------------------------------------------------------------------------------------------------------------------- No. 12 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■ ---------------------------------------------------------------------------------------------------------------------------------------- No. 13 ■ ■■■ ■■■■■ ■■■■■■■ ■■■■■■■■■

コロナ関連の予測

投稿者：大熊　正投稿日：2020年 7月 9日(木)07時32分45秒

今、エクセルでコロナ患者の増加曲線を作り予測等をしてます、式は、　Ｙ＝A/(1+EXP(-M*(X-T))) のロジスチック曲線で、データとＹの差を2乗し、最小2乗を取り、エクセルのソルバーで、Ｙの　A,T,M を求めて、います。これを10進BASIC で同様に行いたいと思い色々やってますがうまくゆきません。すでにあるBASICのソフトの、組み合わせか投稿のソフトで同様のものがあるか、またはできるかを御教えをお願いします。

Re: コロナ関連の予測

投稿者：nagram 投稿日：2020年 7月 9日(木)21時53分13秒

> No.4858[元記事へ] 大熊　正さんへのお返事です。この掲示板の常連投稿者である山中和義さんの個人サイト(現在は閉鎖)で公開されていたプログラムです。 !重回帰分析 - 重回帰式 Y=a+b*X1+c*X2+ … +d*Xp !●重回帰式 Y=2.504+0.8161*X1-0.2749*X2+1.055*X3 PUBLIC NUMERIC P,N LET P=3 !変数の数 LET N=8 !データの数 DATA 8,4,8,18 !X1,X2,X3,Y DATA 7,7,7,12 DATA 5,8,9,14 DATA 4,3,3,6 DATA 6,8,8,12 DATA 2,5,3,8 DATA 3,6,6,10 DATA 9,9,7,16 DIM X(N,P),Y(N) !データを読み込む FOR i=1 TO N FOR j=1 TO P READ X(i,j) ![X1,X2,X3] NEXT j READ Y(i) !Y NEXT i DIM C(P+1) CALL LINEST(Y,X, C) !係数 MAT PRINT C; PRINT "決定係数の２乗=";RSQ(Y,X) !0.83405 DIM t(P) !X1,X2,X3 DATA 5,8,9 MAT READ t PRINT FORECAST(t,Y,X) !予測値 PRINT "予測値の標準誤差=";STEYX(Y,X) !●ロジスティック回帰モデル Y = 1 / ( 1 + EXP(a+b*X) ) LET P=1 LET N=8 DATA 5.42, 0.05 !X,Y DATA 5.61, 0.18 DATA 5.78, 0.25 DATA 5.95, 0.47 DATA 6.12, 0.82 DATA 6.28, 0.89 DATA 6.43, 0.98 DATA 6.58, 1.00 DIM XX(N,P),YY(N) !データを読み込む FOR i=1 TO N READ XX(i,1) ![X1] READ YY(i) !Y NEXT i !線形回帰式に変形する。LOG(1/Y-1)=a+b*X → Y'=a+b*X → Y=1/(1+EXP(Y')) DIM LogYY(N) FOR i=1 TO N IF YY(i)=1 THEN LET LogYY(i)=-5 !※ ELSE LET LogYY(i)=LOG(1/YY(i)-1) END IF NEXT i CALL LINEST(LogYY,XX, C) !係数 MAT PRINT C; PRINT "決定係数の２乗=";RSQ(LogYY,XX) SET WINDOW 5,7,-0.2,1.2 !グラフを描いてみる DRAW grid(0.5,0.25) FOR i=1 TO N !データ PLOT POINTS: XX(i,1),YY(i) NEXT i FOR i=5 TO 7 STEP 0.1 !近似式 LET t(1)=i PLOT LINES: i,1/(1+EXP( FORECAST(t,LogYY,XX) )); NEXT i PLOT LINES END !最小２乗法による ! !残差平方和 S=Σ[i=1,n]{(Y[i]-(a+b*X1+c*X2+ … +d*Xp))^2} を最小にする係数を求める。 !偏微分（∂S/∂a、∂S/∂bなど）して、連立方程式を得る。 ! ┌ Σ 1*1 Σ 1*X1 Σ 1*X2 … Σ 1*Xp ┐┌ a ┐=┌ Σ 1*Y ┐ ! │ ΣX1*1 ΣX1*X1 ΣX1*X2 … ΣX1*Xp ││ b │ │ ΣX1*Y │ ! │ ΣX2*1 ΣX2*X1 ΣX2*X2 … ΣX2*Xp ││ c │ │ ΣX2*Y │ !　　　　　　　：　　　　　　　　：　　　　：　　　　： ! └ ΣXp*1 ΣXp*X1 ΣXp*X2 … ΣXp*Xp ┘└ d ┘ └ ΣXp*Y ┘ EXTERNAL SUB LINEST(Y(),X(,), t()) !係数を返す DIM tW(P+1,N),W(N,P+1) !内積の計算に用いる FOR i=1 TO N ![1,X1,X2, … ,Xp] FOR k=1 TO P LET W(i,k+1)=X(i,k) NEXT k LET W(i,1)=1 NEXT i MAT tW=TRN(W) DIM A(P+1,P+1),b(P+1) !連立方程式 A*t=b MAT A=tW*W !左辺 A MAT b=tW*Y !右辺 b !!!MAT PRINT A; !debug !!!MAT PRINT b; DIM iA(P+1,P+1) !連立方程式を解く MAT iA=INV(A) MAT t=iA*b !求める係数 !!!MAT PRINT t; !debug END SUB EXTERNAL FUNCTION FORECAST(T(),Y(),X(,)) !予測値を求める DIM C(P+1) CALL LINEST(Y,X, C) !係数を求める LET s=C(1) FOR i=2 TO P+1 !近似式に代入する LET s=s+T(i-1)*C(i) NEXT i LET FORECAST=s END FUNCTION EXTERNAL FUNCTION STEYX(Y(),X(,)) !予測値の標準誤差 DIM T(P) LET s=0 FOR i=1 TO N FOR k=1 TO P ![X1,X2,…,Xp] LET T(k)=X(i,k) NEXT k LET s=s+(Y(i)-FORECAST(T,Y,X))^2 NEXT i LET STEYX=SQR(s/(N-2)) !SQR( Σ(Y[k]-f[k])^2 / (N-2) ) END FUNCTION EXTERNAL FUNCTION DEVSQ(Y()) !偏差平方和Σ[k=1,N]{(Y[k]-AY)^2} LET s=0 LET s2=0 FOR i=1 TO N LET s=s+Y(i) LET s2=s2+Y(i)^2 NEXT i LET DEVSQ=s2-s^2/N !ΣY*Y-(ΣY)^2/N END FUNCTION EXTERNAL FUNCTION RSQ(Y(),X(,)) !決定係数 R^2（寄与率） DIM T(P) LET s=0 FOR i=1 TO N FOR k=1 TO P ![X1,X2,…,Xp] LET T(k)=X(i,k) NEXT k LET s=s+(Y(i)-FORECAST(T,Y,X))^2 NEXT i LET RSQ=1-s/DEVSQ(Y) !1 - Σ(Y[k]-f[k])^2 / Σ(Y[k]-AY)^2 END FUNCTION !別解 EXTERNAL FUNCTION RSQ2(Y(),X(,)) !決定係数R^2 DIM W(N),T(P) FOR i=1 TO N FOR k=1 TO P ![X1,X2,…,Xp] LET T(k)=X(i,k) NEXT k LET W(i)=FORECAST(T,Y,X) !予測値 NEXT i LET RSQ2=DEVSQ(W)/DEVSQ(Y) !Σ(f[k]-Af)^2/Σ(Y[k]-AY)^2　推定値の分散を標本値の分散で割ったもの END FUNCTION

コロナ関連の予測

投稿者：大熊　正投稿日：2020年 7月11日(土)14時35分41秒

元記事　NO　4858　　の御礼メールです。早速の御返事ありがとう御座います。早速これからいろいろやってみます。敬具

Linux版Decimal Basicに付いて

投稿者：came_tongue 投稿日：2020年 7月29日(水)22時46分35秒

Linux版Decimal Basic(gtk版)を使用してみました。 JIS FullBASICの仕様書と格闘してたんですが、分からないところがあるので質問させて下さい。 1. IF 条件 THEN 単純実行文 ELSE 単純実行文 END IFについて。どうも仕様書見てみても「単純実行」の定義を見つけられなかったんですが、これは「一つの式」ないしは文しか実行出来ない、って事でしょうか。例えば、 IF 条件 THEN 　何か実行1 　何か実行2 ELSE 　.... と言う形式は認められていない、と言う事なのでしょうか。 2. プログラムを書いてみたけど条件分岐が上手く行かない。ヘッタクソなプログラムですが、次のようなモノを書いてみました。 DIM A(100) RANDOMIZE FOR n = 1 TO 100 　LET A(n)=INT(RND*MAXNUM/100 + 1) NEXT n LET SUM = 0 LET EVEN = 0 LET S_EVEN = 0 LET ODD = 0 LET S_ODD = 0 LET NUM = 0 FOR n = 1 TO 100 　LET NUM = A(n) 　LET SUM = SUM + NUM 　IF MOD(NUM,2)=0 THEN 　　LET EVEN = EVEN + NUM 　ELSE 　　LET ODD = ODD + NUM 　END IF NEXT n FOR n = 1 TO 100 　LET NUM = A(n) 　IF MOD(NUM,2)=0 THEN 　　LET S_EVEN = S_EVEN + 1 　ELSE 　　LET S_ODD = S_ODD + 1 　END IF NEXT n PRINT "SUM ", SUM PRINT "EVEN ", EVEN PRINT "#EVEN ", S_EVEN PRINT "ODD ", ODD PRINT "#ODD ", S_ODD END ところがMODの計算で上手く分岐出来ません。実行はしてくれるんですが、計算結果が望まれたものと違います。何か文法的に間違ってるのでしょうか。 (例えばNUM = A(n)と言うのが一回使われたらGCが回収に来る、とか)

Re: Linux版Decimal Basicに付いて

投稿者：SHIRAISHI Kazuo 投稿日：2020年 7月30日(木)11時34分34秒

> No.4862[元記事へ] 単純実行文の完全な定義は，JIS Full BASIC 付属書E（生成規則一覧）にあります。単純実行文＝ ask文｜break文｜call文｜cause-exception文｜chain文｜ clear文｜close文｜debug文｜delete文｜draw文｜erase文｜ exit-do文｜exit-for文｜exit-function文｜exit-handler文｜ exit-picture文｜exit-sub文｜gosub文｜goto文｜input文｜ let文｜line-input文｜mat文｜mat-input文｜mat-line-input文｜ mat-print文｜mat-read文｜mat-rewrite文｜mat-write文｜ open文｜print文｜randomize文｜read文｜restore文｜ return文｜rewrite文｜set文｜stop文｜trace文｜write文｜数値関数定義let文｜図形出力文｜図形入力文｜変形指示mat文｜文字列関数定義let文｜例外処理区戻り文簡単にいうと，実行文のうち，構造文でないもののことです。 IF文には，一行に書くタイプと構造IF文（IF～END IF）の２タイプがあります。一行に書く形のIF文には単純実行文を一つ（ELSE部にも１つ，計２つ）しか書けません。 IF 条件 THEN 　何か実行1 　何か実行2 ELSE ・・・・・・ END IF の形のIF文はIF行とELSE行，ELSE行とEND IF行の間に構造文も含めて複数行書くことができます。

Re: Linux版Decimal Basicに付いて

投稿者：SHIRAISHI Kazuo 投稿日：2020年 7月30日(木)11時40分34秒

> No.4862[元記事へ] > DIM A(100) > RANDOMIZE > FOR n = 1 TO 100 > 　LET A(n)=INT(RND*MAXNUM/100 + 1) > NEXT n > LET SUM = 0 > LET EVEN = 0 > LET S_EVEN = 0 > LET ODD = 0 > LET S_ODD = 0 > LET NUM = 0 > FOR n = 1 TO 100 > 　LET NUM = A(n) > 　LET SUM = SUM + NUM > 　IF MOD(NUM,2)=0 THEN > 　　LET EVEN = EVEN + NUM > 　ELSE > 　　LET ODD = ODD + NUM > 　END IF > NEXT n > FOR n = 1 TO 100 > 　LET NUM = A(n) > 　IF MOD(NUM,2)=0 THEN > 　　LET S_EVEN = S_EVEN + 1 > 　ELSE > 　　LET S_ODD = S_ODD + 1 > 　END IF > NEXT n > PRINT "SUM ", SUM > PRINT "EVEN ", EVEN > PRINT "#EVEN ", S_EVEN > PRINT "ODD ", ODD > PRINT "#ODD ", S_ODD > END > > ところがMODの計算で上手く分岐出来ません。 > 実行はしてくれるんですが、計算結果が望まれたものと違います。 > 何か文法的に間違ってるのでしょうか。 A(n)に代入された数値がMAXNUM/100の倍数なので，数値変数の精度の範囲でいうと全部偶数です。１０進１０００桁モードで実行してみると，違う結果が得られると思います。 MAXNUMの意味を誤解しているのかもしれません。MAXNUMは整数として精度が保証される最大数ではありません。

Re: Linux版Decimal Basicに付いて

投稿者：came_tongue 投稿日：2020年 7月30日(木)15時54分24秒

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

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日(木)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 って書くべきなのでしょうか。

データファイル集

投稿者：しばっち投稿日：2020年 7月30日(木)20時34分30秒

新たな試みとして十進BASIC等を使用して作成したデータファイル集(画像ファイル等)を公開したいと思います。下記URLよりダウンロードできます。ぜひご堪能ください。(data.zip 459MB) https://4.gigafile.nu/0829-e0c371e3106eb5417847b2ebcb9ee4d31 ダウンロードパス:設定していませんダウンロード期限：2020年8月29日(土)

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$

Re: Linux版Decimal Basicに付いて

投稿者：came_tongue 投稿日：2020年 8月 1日(土)23時45分44秒

> No.4869[元記事へ] SHIRAISHI Kazuoさんへのお返事です。色々と教えてもらってありがとうございました。

正規表現

投稿者：しばっち投稿日：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: カメラ映像表示

投稿者：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; > } >

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)まだ確認できていないので (^_^;)

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

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

BASファイル化

投稿者：しばっち投稿日：2020年10月 3日(土)19時44分1秒

前作はBASE16によるものでしたが今回はBASE64で任意ファイルをBASファイル化します。 #1245 #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

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の例外が発生しました」とダイアログが出ました。

Re: SET BITMAP SIZE文でエラー

投稿者：SHIRAISHI Kazuo 投稿日：2020年10月 8日(木)08時06分55秒

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

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

神経衰弱ゲーム

投稿者：しばっち投稿日：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: 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 が出ました。以上報告です。

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月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は削除をお願い致します。

不具合報告や質問、要望があるのですが

投稿者：ふくちん投稿日：2020年11月20日(金)12時52分9秒

こんにちは。初めまして。この掲示板は、プログラミングに関する質問や研究結果の公開などに利用できるとありますが、不具合報告やライセンスに関する質問、要望等もこちらに書いて良いのでしょうか。ご存じの方いらっしゃいますか？よろしくお願いいたします。

http://www.rouge.gr.jp/~fuku/toys/decbasic-mazeplay/

Re: 不具合報告や質問、要望があるのですが

投稿者：SHIRAISHI Kazuo 投稿日：2020年11月22日(日)15時00分29秒

> No.4886[元記事へ] ふくちんさんへのお返事です。不具合や疑問点など，気づいた点があれば掲示板に書き込んでください。

サイエンス/michikoshi-shugo_20200331/

コロナウィルス感染者数シュミレーション

投稿者：しばっち投稿日：2020年11月23日(月)10時52分22秒

コロナウィルス感染者数をSIRモデルでシュミレーションしてみました。 http://www.math.twcu.ac.jp/ogita/lec/sim_infection.pdf https://rad-it21.com/サイエンス/michikoshi-shugo_20200331/ https://wagtail.cds.tohoku.ac.jp/coda/python/p-6-application-sup-ode-sir-model.html https://ex-gram.com/infection_vs_vaccination2/ Susceptible:未感染者数 Infected :感染者数 Recovered :免疫保持者数、回復した人数このS,I,Rを３元連立微分方程式としてルンゲクッタで解いてグラフ表示しています。このプログラムではこれらパラメータをスライドバーで与えています。 Sを緑線 Iを赤線 Rを青線でグラフ表示しています。縦軸を人数、横軸が日数です。 PUBLIC NUMERIC B,G LOCATE VALUE NOWAIT(1) ,RANGE 10000 TO 10000000,AT 1000000 : N !'人口 LOCATE VALUE NOWAIT(2) ,RANGE 1 TO 10000,AT 10 : I !'初期感染者数 LOCATE VALUE NOWAIT(3) ,RANGE .01 TO 1,AT .2 : BETA !'感染率 LOCATE VALUE NOWAIT(4) ,RANGE 1 TO 30,AT 14 :GAMMA !'回復までの日数 DO LOCATE VALUE NOWAIT(1) : N !'人口 LOCATE VALUE NOWAIT(2) : I !'初期感染者数 LOCATE VALUE NOWAIT(3) : BETA !'感染率 LOCATE VALUE NOWAIT(4) :GAMMA !'回復までの日数 LET N=INT(N) LET I=INT(I) LET R=0 !'初期回復者数 LET GAMMA=INT(GAMMA) LET S=N-I !'初期未感染者数 LET T=0 !'経過日数 LET G=1/GAMMA !'回復率 LET B=BETA/N !'感染率 LET H=.5 LET DAY=180 !'期間(日) SET WINDOW -15,DAY,-N/40,N*1.02 SET COLOR MIX(15) 0,0,0 DRAW GRID(30,N/5) DO LET K1=F1(T,S,I,R) LET L1=F2(T,S,I,R) LET M1=F3(T,S,I,R) LET K2=F1(T+H/2,S+H/2*K1,I+H/2*L1,R+H/2*M1) LET L2=F2(T+H/2,S+H/2*K1,I+H/2*L1,R+H/2*M1) LET M2=F3(T+H/2,S+H/2*K1,I+H/2*L1,R+H/2*M1) LET K3=F1(T+H/2,S+H/2*K2,I+H/2*L2,R+H/2*M2) LET L3=F2(T+H/2,S+H/2*K2,I+H/2*L2,R+H/2*M2) LET M3=F3(T+H/2,S+H/2*K2,I+H/2*L2,R+H/2*M2) LET K4=F1(T+H,S+H*K3,I+H*L3,R+H*M3) LET L4=F2(T+H,S+H*K3,I+H*L3,R+H*M3) LET M4=F3(T+H,S+H*K3,I+H*L3,R+H*M3) LET TT=T+H LET SS=S+H*(K1+2*K2+2*K3+K4)/6 LET II=I+H*(L1+2*L2+2*L3+L4)/6 LET RR=R+H*(M1+2*M2+2*M3+M4)/6 SET LINE COLOR 3 ! 緑 PLOT LINES:TT,SS;T,S SET LINE COLOR 4 ! 赤 PLOT LINES:TT,II;T,I SET LINE COLOR 2 ! 青 PLOT LINES:TT,RR;T,R LET S=SS LET I=II LET R=RR LET T=TT LOOP UNTIL T>=DAY SET DRAW MODE EXPLICIT WAIT DELAY .5 SET DRAW MODE HIDDEN CLEAR LOOP END EXTERNAL FUNCTION F1(T,S,I,R) !'dS/dt=f1(t,S,I,R) LET F1=-B*S*I END FUNCTION EXTERNAL FUNCTION F2(T,S,I,R) !'dI/dt=f2(t,S,I,R) LET F2=B*S*I-G*I END FUNCTION EXTERNAL FUNCTION F3(T,S,I,R) !'dR/dt=f3(t,S,I,R) LET F3=G*I END FUNCTION

Qt5 版の GetKeyState() に不具合があるようです

投稿者：ふくちん投稿日：2020年11月24日(火)02時29分39秒

> No.4887[元記事へ] ありがとうございます。では、一つずつ書きます。不具合報告です。(私が発見した不具合はこれだけです) 「十進BASIC 8.1.0.7 (x86_64) Qt5版」を Fedora30 にインストールしましたが、 GetKeyState() がうまく動作していないようです。どのキーを押しても、負の数が戻ってきません。プログラムは https://decimalbasic.ninja-web.net/BASICHelp/html/basi16ck.htm に倣って、 --- ここから --- DO FOR k = 8 TO 239 IF GetKeyState(k) < 0 THEN PRINT k NEXT k LOOP END --- ここまで --- と、しています。 dnf install qt5pas は、実施済みです。 gtk2 版は、同じプログラムが思惑通り動作しているので、 Qt5 とのインタフェース、あるいは Qt5 そのものがうまく動作していないのかもしれません。よろしくお願いいたします。 SHIRAISHI Kazuoさんへのお返事です。 > ふくちんさんへのお返事です。 > > 不具合や疑問点など，気づいた点があれば掲示板に書き込んでください。 > >

http://www.rouge.gr.jp/~fuku/toys/decbasic-mazeplay/

Re: Qt5 版の GetKeyState() に不具合があるようです

投稿者：SHIRAISHI Kazuo 投稿日：2020年11月24日(火)16時54分43秒

> No.4889[元記事へ] ご報告ありがとうございます。 GETKEYSTATEは一応Lazarusのドキュメントに記載はあるのですが， https://lazarus-ccr.sourceforge.io/docs/lcl/lclintf/getkeystate.html LCLの実装にGETKEYSTATEが不要だと機能しないようです。十進BASICのMac版ではGETKEYSTATEが機能しないことを確認しているので， Qt版でも使えないことを追記しておきます。 http://hp.vector.co.jp/authors/VA008683/basi0000.htm > ありがとうございます。 > > では、一つずつ書きます。 > > 不具合報告です。(私が発見した不具合はこれだけです) > 「十進BASIC 8.1.0.7 (x86_64) Qt5版」を Fedora30 にインストールしましたが、 > GetKeyState() がうまく動作していないようです。 > > どのキーを押しても、負の数が戻ってきません。 > プログラムは https://decimalbasic.ninja-web.net/BASICHelp/html/basi16ck.htm に倣って、 > --- ここから --- > DO > FOR k = 8 TO 239 > IF GetKeyState(k) < 0 THEN PRINT k > NEXT k > LOOP > END > --- ここまで --- > と、しています。 > > dnf install qt5pas > は、実施済みです。 > > gtk2 版は、同じプログラムが思惑通り動作しているので、 > Qt5 とのインタフェース、あるいは Qt5 そのものが > うまく動作していないのかもしれません。 > > よろしくお願いいたします。 > > SHIRAISHI Kazuoさんへのお返事です。 > > > ふくちんさんへのお返事です。 > > > > 不具合や疑問点など，気づいた点があれば掲示板に書き込んでください。 > > > >

フラクタル画像

投稿者：しばっち投稿日：2020年12月22日(火)19時46分6秒

フラクタル画像 http://souzousha.iinaa.net/www/hata/Index.html OPTION ARITHMETIC COMPLEX PUBLIC NUMERIC A,B,C,D,FL,XMIN,XMAX,YMIN,YMAX,X0,Y0 SET POINT STYLE 1 SET TEXT COLOR 4 DO LET I=I+1 LET XMIN=1E+10 LET YMIN=XMIN LET XMAX=-1E+10 LET YMAX=XMAX LET X0=0 LET Y0=0 LET FL=0 LET N=12 READ IF MISSING THEN EXIT DO:AR,AI,BR,BI,CR,CI,DR,DI LET A=COMPLEX(AR,AI) LET B=COMPLEX(BR,BI) LET C=COMPLEX(CR,CI) LET D=COMPLEX(DR,DI) CALL DRAW(N,0) LET XM=(XMAX-XMIN)/2*1.5 LET YM=(YMAX-YMIN)/2*1.5 LET X0=X0/2^N LET Y0=Y0/2^N SET WINDOW -MAX(XM,YM),MAX(XM,YM),-MAX(XM,YM),MAX(XM,YM) LET FL=1 CALL DRAW(17,0) ASK TEXT HEIGHT HEIGHT PLOT TEXT ,AT -MAX(XM,YM),MAX(XM,YM)-1.5*HEIGHT:"A="&FORMAT$(A) PLOT TEXT ,AT -MAX(XM,YM),MAX(XM,YM)-3*HEIGHT:"B="&FORMAT$(B) PLOT TEXT ,AT -MAX(XM,YM),MAX(XM,YM)-4.5*HEIGHT:"C="&FORMAT$(C) PLOT TEXT ,AT -MAX(XM,YM),MAX(XM,YM)-6*HEIGHT:"D="&FORMAT$(D) !'GSAVE "フラクタル"&USING$("%%%",I)&".png" WAIT DELAY 1 CLEAR LOOP DATA 0,0,.5,.288675134594813,0,0,.5,-.288675134594813 DATA 0,0,.4614,.4614,.622,-.196,0,0 DATA .4614,.4614,0,0,0,0,.622,-.196 DATA 0,0,.5,.28867,0,0,.6667,0 DATA 0,0,0,.6667,0,0,.6667,0 DATA 0,.7071,0,0,.5,0,0,0 DATA 0,0,.4,.5,0,0,.4,-.5 DATA .4614,.4614,0,0,0,0,.2896,-.585 DATA .4614,.4614,0,0,.622,-.196,0,0 DATA .1,.1,.5,.3,-.1,-.1,.5,-.3 DATA 0,.2887,.5,.2887,0,-.2887,.5,-.2887 DATA .5,.2887,0,0,.5,-.2887,0,0 DATA .5,.4,0,.4,.5,-.4,0,-.4 DATA .5,-.05,0,0,.5,.05,0,0 DATA 0,0,-.5,-.5,0,0,-.5,.5 DATA .5,-.5,0,0,-.5,-.5,0,0 DATA .3,.6,0,0,-.3,.6,0,0 DATA -.3,.7,0,0,.3,-.6,0,0 DATA -.3,.6,0,0,.3,-.6,0,0 DATA .3,.7,0,0,0,0,.2,.5 DATA .2,.7,0,0,0,0,.2,.6 DATA 0,0,-.5,-.5,0,0,0,.7 DATA .6,.2,0,0,0,0,.67,0 DATA .7,.2,0,0,0,0,.67,0 DATA .67,-.5,0,0,-.25,.5,0,0 DATA .55,-.45,0,0,.8,.2,0,0 DATA .71,-.44,.05,0,.73,.5,.02,0 DATA .71,-.37,0,0,.71,.37,0,0 DATA .8,-.5,0,0,.8,.5,0,0 DATA .1,0,.5,.3,.1,0,.67,0 DATA -.25,.5,0,0,0,0,.75,0 DATA 0,0,.8,0,0,0,-.2,-.4 DATA 0,0,.8,.1,0,0,-.2,-.4 DATA 0,0,.3,.6,0,0,-.3,-.6 DATA .7,.1,0,.3,0,.2,.7,0 DATA -.25,.5,0,0,0,0,0,.7 DATA .1,0,.3,.6,.1,0,.3,-.6 DATA .3,.6,-.1,-.1,.1,.1,-.3,-.6 DATA .3,.6,0,0,0,0,-.3,-.6 DATA .3,.8,0,0,0,0,-.3,-.3 DATA .5,-.5,0,0,-.25,.5,0,0 DATA .5,-.6,0,0,-.1,.5,0,0 DATA 0,0,.5,.7,0,0,.7,0 DATA 0,0,.5,.3,0,0,.5,.65 DATA 0,0,.5,.3,0,0,.5,.85 DATA .8,-.2,.1,.1,.1,.2,.6,-.2 DATA .8,.2,.1,.1,.1,.2,.6,.1 DATA .8,.2,.1,.1,.1,-.2,.6,-.2 DATA .8,.2,0,.2,0,.2,.6,.1 DATA 0,0,-.5,-.5,.5,-.5,0,0 DATA .7,-.6,.2,.4,-.7,-.6,.2,.4 DATA .6,-.6,.2,.5,-.6,-.6,.2,.5 DATA .7,-.5,.2,-.4,-.7,-.5,.2,-.4 DATA -.1,.9,0,0,.1,-.55,0,0 DATA 0,0,-.3,.6,-.3,-.6,0,0 DATA .48,.48,0,0,0,0,.48,-.48 DATA .2,0,0,.7,.2,0,0,-.7 DATA .1,0,0,.7,.1,0,0,-.7 DATA 0,0,0,-.5,.8,0,0,0 DATA .5,-.55,0,0,-.1,.55,.2,0 DATA .5,-.5,.2,0,-.25,.5,0,0 DATA .6,-.6,.22,0,-.1,-.2,.22,0 DATA .7,-.6,0,0,-.1,-.2,0,0 DATA .7,-.5,0,0,-.2,-.4,0,0 DATA .7,-.6,.4,0,-.1,-.2,.4,0 DATA .7,-.6,.2,.4,-.1,-.2,.2,.4 DATA .1,.4,-.2,-.2,.1,-.4,1,.3 DATA 0,.1,.7,-.5,0,0,-.2,-.3 DATA .1,.1,.6,-.5,0,.1,-.2,-.3 DATA .1,.1,.5,.3,-.1,.1,-.5,.3 DATA .1,-.1,.4,.5,-.1,.1,-.4,.5 DATA 0,0,.7,-.7,0,0,-.2,-.4 DATA .4,-.5,0,.1,0,0,-.4,-.5 DATA -.1,.1,.6,-.4,.1,.5,.2,0 DATA 0,-.1,.3,-.5,0,-.1,0,.67 DATA -.5,.5,0,0,0,0,0,.5 DATA .5,-.4,0,0,0,0,.5,.4 DATA -.4,.7,0,0,.2,-.3,0,0 DATA .1,.5,-.2,-.2,.1,-.5,1,.3 DATA .1,0,.7,-.6,.1,0,-.2,-.3 DATA .1,.5,-.1,.1,.1,.5,1,.1 DATA .4,.5,-.2,.2,.1,-.3,.6,.5 DATA .7,-.3,0,0,0,0,.6,.3 DATA .7,-.3,-.1,0,-.1,0,.6,.3 DATA .3,-.6,0,-.1,0,-.1,.6,.3 DATA .5,-.6,0,-.1,0,-.1,.6,.3 DATA .5,-.5,.1,0,.1,0,.5,.5 DATA 0,0,.65,0,0,-.65,0,0 DATA 0,0,.65,.2,.2,-.65,0,0 DATA .5,-.5,0,.5,0,.2,.5,-.5 DATA .5,-.5,0,-.3,0,-.3,.5,-.5 DATA .5,-.5,0,-.2,0,.2,.5,-.5 DATA .5,-.5,0,-.5,0,-.2,.5,-.5 DATA .5,-.5,.2,-.1,.2,-.2,.5,-.5 DATA .5,-.5,.1,.1,.3,.4,.5,-.5 DATA .5,-.5,.2,.2,-.25,.5,.1,.2 DATA .6,-.6,.2,-.1,-.1,.4,.1,-.3 DATA .2,-.6,0,0,0,0,.3,-.6 DATA .2,-.6,0,0,0,0,.5,-.6 DATA .2,-.6,0,0,0,0,.5,-.7 DATA .2,-.6,0,0,0,0,.5,-.8 DATA .2,-.6,0,0,0,0,.5,-.9 DATA .3,-.5,0,0,0,0,.5,-.9 DATA .5,-.5,0,0,0,0,.5,-.9 DATA .3,-.7,0,0,0,0,.5,-.9 DATA .3,-.7,.4,0,0,0,.5,-.8 DATA .72,-.5,0,0,0,0,.3,.4 DATA .72,-.5,.2,0,0,0,.3,.4 DATA 1,-.3,.2,0,0,0,.3,-.3 DATA 1,-.3,.2,0,0,.2,.2,-.4 DATA .19,0,.3,.6,.19,0,.3,-.6 DATA .19,.33,.3,.6,.19,-.33,.3,-.6 DATA 0,.33,.3,.6,0,-.33,.3,-.6 DATA .2,.7,0,.2,-.2,.7,0,.2 DATA 0,0,0,.3,-.3,.9,.3,0 DATA .1,0,0,.3,-.3,.9,.3,0 DATA .3,.4,.6,-.4,-.6,-.8,.3,-.4 DATA 0,0,-.5,-.35,-.5,-.35,0,0 DATA .2,0,-.5,-.5,-.5,-.5,-.2,0 DATA 0,.2,-.5,-.5,-.5,-.5,0,.2 DATA 0,-.3,-.5,-.38,-.5,-.38,0,.2 DATA .7,.5,0,-.3,0,-.6,.2,.3 DATA .2,.2,.3,.3,.2,-.2,.3,-.3 DATA .2,.3,.5,.6,.2,-.3,.5,-.6 DATA .6,-.2,0,0,.8,.4,0,0 DATA .6,-.2,.2,.1,.7,.4,0,0 DATA .5,-.2,.3,.1,.7,.5,.3,-.1 DATA .5,-.3,0,0,0,0,.7,-.3 DATA .5,-.3,.3,-.2,0,0,.7,.3 DATA .3,-.2,.3,-.2,0,0,.9,.2 DATA .3,-.5,.1,.1,.3,.5,.1,-.1 DATA .4,-.5,0,0,.4,.5,0,0 DATA .4,-.5,.1,0,.4,.5,0,0 DATA .4,-.6,0,0,.4,.6,0,0 DATA .4,-.65,0,0,.4,.65,0,0 DATA .2,-.72,.2,0,.2,.72,0,0 DATA .4,-.68,.2,0,.4,.68,.2,0 DATA .4,-.6,0,.2,.4,.6,0,0 DATA .4,-.7,0,0,.4,.7,0,0 DATA .5,-.6,0,.1,.5,.6,0,0 DATA .4,-.6,0,.1,-.4,-.6,0,0 DATA .3,-.6,0,0,-.3,-.6,0,0 DATA .3,-.6,0,.1,-.3,-.6,0,0 DATA .3,-.65,0,.1,-.3,-.65,0,0 DATA .3,-.7,0,.3,-.3,-.7,0,0 DATA .3,-.75,.3,-.3,-.3,-.75,.3,-.3 DATA .2,-.8,.4,-.4,-.2,-.8,.4,-.4 DATA .7,.2,.2,.2,.2,-.2,.9,.3 DATA 0,.1,.5,-.3,0,.1,.67,0 DATA 0,.1,.5,-.3,0,.1,.67,.3 DATA 0,.2,.5,-.3,0,.2,.67,.3 DATA 0,.3,.55,-.3,0,.3,.67,.3 DATA .01,.35,.7,-.35,.01,.35,.7,.35 DATA .1,0,.2,.5,.4,-.7,.1,0 DATA 0,0,.2,.5,.4,-.7,.1,0 DATA 0,0,.2,.5,.4,-.7,.3,0 DATA .1,0,.2,.5,.4,-.7,.3,0 DATA 0,0,.2,.5,.3,-.77,0,0 DATA .1,0,.2,.5,.2,-.8,.2,0 DATA .1,0,.2,.5,.2,-.7,.2,0 DATA 0,0,.1,.4,.5,-.8,0,0 DATA 0,0,.1,.4,.5,-.8,.4,0 DATA 0,.1,.1,.4,.5,-.8,.2,0 DATA 0,.1,.1,.4,.5,-.9,.2,0 DATA 0,.2,.1,.4,.5,-.9,.2,0 DATA .2,.2,.1,.4,.5,-.78,-.1,0 DATA 0,.2,.3,-.5,.5,-.8,0,-.2 DATA .5,.3,.1,0,.1,0,.7,0 DATA .5,-.5,.1,0,.1,0,.6,0 DATA .5,-.66,.1,0,.1,0,.6,0 DATA .5,-.6,0,0,0,0,.5,-.6 DATA .5,-.6,0,0,.1,0,.5,-.6 DATA .5,-.6,0,-.15,0,.1,.5,-.6 DATA .5,-.6,0,-.15,0,-.15,.5,-.6 DATA .5,.3,0,0,0,0,.5,-.3 DATA .5,.3,.2,0,0,0,.5,-.3 DATA .5,.3,.2,.2,0,0,.5,-.3 DATA .5,.3,.2,0,.1,.1,.5,-.3 DATA .5,.3,.1,.2,-.1,-.2,.5,-.3 DATA .3,-.7,0,-.15,0,-.15,.3,-.7 DATA .3,-.7,.1,-.2,.1,-.2,.3,-.7 DATA .2,-.7,.1,-.2,.1,-.2,.2,-.7 DATA .2,-.7,.1,.25,0,.25,.2,-.7 DATA .2,-.8,.1,.25,0,.25,.2,-.7 DATA .2,-.8,.1,.4,0,.4,.2,-.8 DATA .2,-.8,0,.45,0,.45,.2,-.8 DATA .3,-.8,.1,-.2,.1,.2,.3,-.2 DATA .6,-.8,.1,-.2,.1,.2,.3,-.3 DATA -.25,.5,0,0,0,0,.75,0 DATA 0,.5,0,0,0,0,.75,0 DATA -.5,.5,0,0,0,0,0,.5 DATA -.7,.5,0,0,0,0,0,.4 END EXTERNAL FUNCTION FORMAT$(Z) OPTION ARITHMETIC COMPLEX IF IM(Z)<0 THEN LET SIGN$=" - " ELSE LET SIGN$=" + " LET FORMAT$=USING$("-%.####",RE(Z))&SIGN$&USING$("%.####",ABS(IM(Z)))&"i" END FUNCTION EXTERNAL SUB DRAW(N,Z) OPTION ARITHMETIC COMPLEX IF N>0 THEN CALL DRAW(N-1,A*Z+B*CONJ(Z)) CALL DRAW(N-1,C*(Z-1)+D*(CONJ(Z)-1)+1) IF FL=0 THEN LET XMIN=MIN(XMIN,RE(Z)) LET XMAX=MAX(XMAX,RE(Z)) LET YMIN=MIN(YMIN,IM(Z)) LET YMAX=MAX(YMAX,IM(Z)) LET X0=X0+RE(Z) LET Y0=Y0+IM(Z) ELSE PLOT POINTS:Z-COMPLEX(X0,Y0) END IF END IF END SUB

フラクタル画像

投稿者：しばっち投稿日：2020年12月22日(火)19時51分7秒

スライドバーでパラメータを操作できるようにしてみました。 OPTION ARITHMETIC COMPLEX PUBLIC NUMERIC A,B,C,D,FL,XMIN,XMAX,YMIN,YMAX,X0,Y0 SET POINT STYLE 1 LOCATE VALUE NOWAIT(1),RANGE -1 TO 1,AT 0:AR LOCATE VALUE NOWAIT(2),RANGE -1 TO 1,AT 0:AI LOCATE VALUE NOWAIT(3),RANGE -1 TO 1,AT .5:BR LOCATE VALUE NOWAIT(4),RANGE -1 TO 1,AT .288:BI LOCATE VALUE NOWAIT(5),RANGE -1 TO 1,AT 0:CR LOCATE VALUE NOWAIT(6),RANGE -1 TO 1,AT 0:CI LOCATE VALUE NOWAIT(7),RANGE -1 TO 1,AT .5:DR LOCATE VALUE NOWAIT(8),RANGE -1 TO 1,AT -.288:DI LOCATE VALUE NOWAIT(9),RANGE -1 TO 1,AT 0:ZR LOCATE VALUE NOWAIT(10),RANGE -1 TO 1,AT 0:ZI LOCATE VALUE NOWAIT(11),RANGE .1 TO 2,AT 1:SCALE DO LOCATE VALUE NOWAIT(1):AR LOCATE VALUE NOWAIT(2):AI LOCATE VALUE NOWAIT(3):BR LOCATE VALUE NOWAIT(4):BI LOCATE VALUE NOWAIT(5):CR LOCATE VALUE NOWAIT(6):CI LOCATE VALUE NOWAIT(7):DR LOCATE VALUE NOWAIT(8):DI LOCATE VALUE NOWAIT(9):ZR LOCATE VALUE NOWAIT(10):ZI LOCATE VALUE NOWAIT(11):SCALE LET XMIN=1E+10 LET YMIN=XMIN LET XMAX=-1E+10 LET YMAX=XMAX LET X0=0 LET Y0=0 LET FL=0 LET N=10 LET A=COMPLEX(AR,AI) LET B=COMPLEX(BR,BI) LET C=COMPLEX(CR,CI) LET D=COMPLEX(DR,DI) LET Z0=COMPLEX(ZR,ZI) CALL DRAW(N,Z0) LET XM=(XMAX-XMIN)/2*1.3 LET YM=(YMAX-YMIN)/2*1.3 LET X0=X0/2^N LET Y0=Y0/2^N SET WINDOW -MAX(XM,YM)*SCALE,MAX(XM,YM)*SCALE,-MAX(XM,YM)*SCALE,MAX(XM,YM)*SCALE DRAW GRID(MAX(XM,YM)*SCALE/5,MAX(XM,YM)*SCALE/5) LET FL=1 CALL DRAW(16,Z0) ASK TEXT HEIGHT HEIGHT PLOT TEXT ,AT -MAX(XM,YM)*SCALE,MAX(XM,YM)*SCALE-1.5*HEIGHT:"A="&FORMAT$(A) PLOT TEXT ,AT -MAX(XM,YM)*SCALE,MAX(XM,YM)*SCALE-3*HEIGHT:"B="&FORMAT$(B) PLOT TEXT ,AT -MAX(XM,YM)*SCALE,MAX(XM,YM)*SCALE-4.5*HEIGHT:"C="&FORMAT$(C) PLOT TEXT ,AT -MAX(XM,YM)*SCALE,MAX(XM,YM)*SCALE-6*HEIGHT:"D="&FORMAT$(D) PLOT TEXT ,AT -MAX(XM,YM)*SCALE,MAX(XM,YM)*SCALE-7.5*HEIGHT:"Z0="&FORMAT$(Z0) SET DRAW MODE EXPLICIT WAIT DELAY .3 SET DRAW MODE HIDDEN CLEAR LOOP END EXTERNAL FUNCTION FORMAT$(Z) OPTION ARITHMETIC COMPLEX IF IM(Z)<0 THEN LET SIGN$=" - " ELSE LET SIGN$=" + " LET FORMAT$=USING$("-%.###",RE(Z))&SIGN$&USING$("%.###",ABS(IM(Z)))&"i" END FUNCTION EXTERNAL SUB DRAW(N,Z) OPTION ARITHMETIC COMPLEX IF N>0 THEN CALL DRAW(N-1,A*Z+B*CONJ(Z)) CALL DRAW(N-1,C*(Z-1)+D*(CONJ(Z)-1)+1) IF FL=0 THEN LET XMIN=MIN(XMIN,RE(Z)) LET XMAX=MAX(XMAX,RE(Z)) LET YMIN=MIN(YMIN,IM(Z)) LET YMAX=MAX(YMAX,IM(Z)) LET X0=X0+RE(Z) LET Y0=Y0+IM(Z) ELSE SET POINT COLOR 2 PLOT POINTS:A*Z+B*CONJ(Z)-COMPLEX(X0,Y0) SET POINT COLOR 4 PLOT POINTS:C*(Z-1)+D*(CONJ(Z)-1)+1-COMPLEX(X0,Y0) END IF END IF END SUB

戻る