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

プログラミング初心者です。

投稿者：初心者

投稿日：2011年 1月10日(月)00時44分5秒

はじめまして、プログラミング初心者です。是非皆さんにご教授願いたいと思います。 n88互換Basic For Windowsにて、二次方程式の数値計算を行っています。 ① X^2+PX+Q=0 という簡単な二次方程式をN88で解くのですが、ニュートンラフソン法との反復回数などの比較を行いたいため、上記の式の項を移項し左辺をＸだけにし、 X=-(X^2+Q)/P という反復公式にしました。試行値とPとQを変化させ、上記の式を反復法で解くプログラミングはどのようになりますでしょうか？ ② また①とは別に、下記のような演算時間を計測するプログラムを組みました。ですがこれでは1秒未満で計算が終わってしまうプログラムでは全て「0ﾋﾞｮｳ」になってしまうため 160行目から300行目までの計算を1000回行って秒数を計測したいと考えたのですが 1000回行うためにはどのようにFOR NEXT文を入れればよろしいでしょうか？ 100 REM Ex2 Newton Raphson 110 T$=TIME$ 120 HH=VAL(MID$(T$,1,2)) 130 MM=VAL(MID$(T$,4,2)) 140 SS=VAL(MID$(T$,7,2)) 150 SEC1=(HH*60+MM)*60+SS 160 K=1:Ep=.00001 170 CLOSE #1:OPEN "I:Ex2_OUT.TXT" FOR OUTPUT AS #1 180 INPUT "X0=";X:PRINT X 190 IF X=0 THEN 270 200 E=(SQR(183)-X)/SQR(183)*100 210 R=(X^2+183)/(2*X) 220 PRINT #1,K;",";R;",";X;",";E 230 PRINT K;,",";R;",";X;",";E 240 IF ABS(R-X)<Ep THEN 300 250 X=R:K=K+1 260 GOTO 190 270 PRINT #1,"ERROR" 280 PRINT "ERROR" 290 GOTO 370 300 PRINT R 310 T$=TIME$ 320 HH=VAL(MID$(T$,1,2)) 330 MM=VAL(MID$(T$,4,2)) 340 SS=VAL(MID$(T$,7,2)) 350 SEC2=(HH*60+MM)*60+SS 360 SEC=SEC2-SEC1 350 PRINT SEC;"ﾋﾞｮｳ" 360 PRINT #1,SEC;"ﾋﾞｮｳ" 370 CLOSE #1 380 END ご回答よろしくお願い申し上げます。

Re: プログラミング初心者です。

投稿者：白石　和夫投稿日：2011年 1月11日(火)12時35分9秒

> No.1477[元記事へ] ②です。次のようにFull BASICのプログラムに書き換えてから考えると答えが見えてくると思います。なお，このプログラムは，人間がINPUT文を実行するのに要する時間を含めて計測しているようです。 100 REM Ex2 Newton Raphson 110 LET time0=TIME 120 LET K=1 130 LET Ep=.00001 140 OPEN #1: NAME "I:Ex2_OUT.TXT" 145 ERASE #1 150 INPUT PROMPT "X0=":X0 160 PRINT X0 170 LET X=X0 180 DO 190 IF X=0 THEN 200 PRINT #1: "ERROR" 210 PRINT "ERROR" 220 STOP 230 END IF 240 LET E=(SQR(183)-X)/SQR(183)*100 250 LET R=(X^2+183)/(2*X) 260 PRINT #1: K;",";R;",";X;",";E 270 PRINT K,",";R;",";X;",";E 280 IF ABS(R-X)<Ep THEN EXIT DO 290 LET X=R 300 LET K=K+1 310 LOOP 320 LET SEC=TIME-time0 330 PRINT SEC;"ﾋﾞｮｳ" 340 PRINT #1: SEC;"ﾋﾞｮｳ" 350 PRINT R 360 CLOSE #1 370 END

HIGGS素数について

投稿者：永野護投稿日：2011年 1月12日(水)13時03分19秒

新年あけましておめでとうございます。本年も皆様にとってよい年でありますように。昨年は大変お世話になりました。今年も是非よろしくお願いいたしまします。早速ですが　　質問１．HIGGS素数はどのように作るものでしょうか。なおHIGGS素数については http://oeis.org/　　にてHIGGSで検索してください。また十進BASICでプログラムすればどのようになるのでしょうか。質問２．最短経路決定問題（ある都市から別の都市へいく最短路を見つける問題）についてはダイクストラのアルゴリズムによるものがよくみうけられますが、これをLP問題としてとけばどのようなプログラムになるのでしょうか。いつもお手数おかけします。暇なときにでも、回答お願いできないでしょうか。

Re: HIGGS素数について

投稿者：山中和義投稿日：2011年 1月13日(木)13時55分10秒

> No.1480[元記事へ] 永野護さんへのお返事です。 > 質問１素数の中から、条件を満たすものを選びます。 !HIGGS素数 !　Higgs' primes: a(n+1) = next prime such that a(n+1)-1 | (a(1)...a(n))^3. !　2, 3, 5, 7, 11, 13, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 101, 107, 109, 127, 131, 139, 149, 151, 157, 167, 173, 179, 181, 191, 197, 199, 211, 223, 229, 233, 251, 263, 269, 271, 277, 281, 283, 293, 311, 313, 317, 331, 347, 349, 359 OPTION ARITHMETIC RATIONAL !多桁の整数 LET N=50 DIM P(N) CALL HIGGSPrimeList(N,P) !ｎ個のHIGGS素数列 MAT PRINT P; FOR i=1 TO 359 IF HIGGSPrimeQ(i)<>0 THEN PRINT i; !HIGGS素数列の判定 NEXT i PRINT END !試行割算法 EXTERNAL FUNCTION PrimeQ(n) !素数判定　1:素数、0:素数でない OPTION ARITHMETIC RATIONAL !多桁の整数 LET PrimeQ=0 IF n<2 OR n<>INT(n) THEN EXIT FUNCTION !引数を確認する !２以上の自然数なら IF MOD(n,2)=0 THEN !２の倍数 IF n=2 THEN LET PrimeQ=1 !２は素数 ELSEIF MOD(n,3)=0 THEN !３の倍数 IF n=3 THEN LET PrimeQ=1 !３は素数 ELSE LET k=5 DO WHILE k*k<=n !√nまで検証する IF MOD(n,k)=0 THEN !5,11,17,23,29,… EXIT FUNCTION ELSEIF MOD(n,k+2)=0 THEN !7,13,19,25,31,… EXIT FUNCTION END IF !+1,+3,+5は２の倍数（偶数）、+1,+4は３の倍数、+5は５の倍数 LET k=k+6 LOOP LET PrimeQ=1 !最後まで割り切れなければ、素数である END IF END FUNCTION !HIGGS素数 EXTERNAL FUNCTION HIGGSPrimeQ(n) !HIGGS素数判定　1:HIGGS素数、0:HIGGS素数でない OPTION ARITHMETIC RATIONAL !多桁の整数 LET HIGGSPrimeQ=0 IF PrimeQ(n)=0 THEN EXIT FUNCTION !素数でなければ、HIGGS素数でない IF n=2 THEN !２はHIGGS素数である LET HIGGSPrimeQ=1 EXIT FUNCTION END IF LET t=2^3 LET k=3 !ｎ未満のHIGGS素数列を得る DO WHILE k<n IF PrimeQ(k)<>0 THEN IF MOD(t,k-1)=0 THEN !P(k+1)-1|(P(1)P(2)…P(k))^3なら LET t=t*k^3 !(P(1)P(2)…P(k))^3 END IF END IF LET k=k+2 LOOP IF MOD(t,n-1)=0 THEN LET HIGGSPrimeQ=1 !P(n+1)-1|(P(1)P(2)…P(n))^3なら END FUNCTION EXTERNAL SUB HIGGSPrimeList(n,p()) !ｎ個のHIGGS素数列を返す OPTION ARITHMETIC RATIONAL !多桁の整数 IF n<1 THEN EXIT SUB !引数を確認する LET c=1 !見つけた個数 LET p(c)=2 !２はHIGGS素数 IF n=1 THEN EXIT SUB LET t=2^3 LET c=2 LET p(c)=3 IF n=2 THEN EXIT SUB LET t=t*3^3 LET k=5 DO IF PrimeQ(k)<>0 THEN !5,11,17,23,29,… が素数なら IF MOD(t,k-1)=0 THEN !P(n+1)-1|(P(1)P(2)…P(n))^3なら LET c=c+1 LET p(c)=k IF c=n THEN EXIT DO LET t=t*k^3 !(P(1)P(2)…P(n))^3 END IF END IF IF PrimeQ(k+2)<>0 THEN !7,13,19,25,31,… IF MOD(t,k+1)=0 THEN !P(n+1)-1|(P(1)P(2)…P(n))^3なら LET c=c+1 LET p(c)=k+2 IF c=n THEN EXIT DO LET t=t*(k+2)^3 END IF END IF LET k=k+6 !次へ LOOP END SUB > 質問２解き方は自己流ですが、、、 !問題 !節点Ａ～Ｅまでの最短距離を求めよ。枝の数字は距離とする。 !　　　　７ !　　　┌→Ｄ !　　５│７↓２ !　Ａ→Ｂ→Ｅ !　│２↑　↑ !　└→Ｃ─┘ !　　４　９ !答え !枝x1(A,B)、x2(A,C)、x3(C,B)、x4(B,D)、x5(B,E)、x6(C,E)、x7(D,E)とする。 !　　　　x4 !　　　┌→Ｄ !　　x1│x5↓x7 !　Ａ→Ｂ→Ｅ !　│x3↑　↑ !　└→Ｃ─┘ !　　x2　x6 ! !制約条件の式の作り方 !左辺 !　節点xに対して、入っている枝は-1、出ている枝に1として、総和をとる。 !右辺 !　節点xが出発点なら１、到着点なら-1、それ以外は０とする。 ! !　たとえば節点Aなら、入っている枝はなし。出ている枝はx1,x2。出発点なので !　x1+x2=1 となる。 ! !目的関数 !　5*x1 + 4*x2 + 2*x3 + 7*x4 + 7*x5 + 9*x6 + 2*x7 の最小値 !制約条件 !　節点A　x1+x2=1 !　節点B　-x1-x3+x4+x5=0 !　節点C　-x2+x3+x6=0 !　節点D　-x4+x7=0 !　節点E　-x5-x6-x7=-1 !　x1,x2,x3,x4,x5,x6,x7∈{0,1} ! !これを解いて、枝xi=1なら最短経路に含まれる。 LET N=7 !変数の数 LET M=5 !制約条件の数 DIM A(M+1,N+1) !係数行列 DATA 1, 1, 0, 0, 0, 0, 0, 1 DATA -1, 0,-1, 1, 1, 0, 0, 0 DATA 0,-1, 1, 0, 0, 1, 0, 0 DATA 0, 0, 0,-1, 0, 0, 1, 0 DATA 0, 0, 0, 0,-1,-1,-1, -1 DATA 5, 4, 2, 7, 7, 9, 2, 0 MAT READ A LET cMAX=9999 DIM x(N) FOR i=1 TO 2^N-1 !全パターンを検証する LET t=i LET c=0 DO WHILE t>0 !２進法へ LET c=c+1 LET x(c)=MOD(t,2) LET t=INT(t/2) LOOP FOR j=1 TO M !制約条件を確認する LET t=0 FOR k=1 TO N LET t=t+A(j,k)*x(k) NEXT k IF t<>A(j,N+1) THEN EXIT FOR !１つでも満たさなければ終了 NEXT j IF j>M THEN !制約条件を満たすなら LET t=0 !目的関数を計算する FOR k=1 TO N LET t=t+A(M+1,k)*x(k) NEXT k IF t<=cMAX THEN !最小なら LET cMAX=t MAT PRINT x; !xiと値を表示する PRINT t END IF END IF NEXT i END

HIGGS素数について

投稿者：永野護投稿日：2011年 1月13日(木)14時40分56秒

山中様、おいそがしい中、プログラム提供ありがとうございました。ご尽力に感謝します。結局HIGGS素数の意味がわかりません。説明していただけないでしょうか。

Re: HIGGS素数について

投稿者：山中和義投稿日：2011年 1月13日(木)14時55分54秒

> No.1482[元記事へ] 永野護さんへのお返事です。 > 結局HIGGS素数の意味がわかりません。説明していただけないでしょうか。２はHIGGS素数です。 a(n+1)-1 | (a(1)...a(n))^3の意味素数３は、3-1が2^3の約数（または2^3は3-1の倍数の意）だからHIGGS素数となる。素数５は、5-1が2^3*3^3（１つ前のHIGGS素数の３乗の積）の約数だからHIGGS素数となる。素数17は、17-1が2^3*3^3*5^3* … *13^3の約数でないのでHIGGS素数とならない。

ＨＩＧＧＳ素数について

投稿者：永野護投稿日：2011年 1月13日(木)15時57分53秒

山中様のたびたびの回答に感謝します。お忙しい折、たいへんお手数をおかけしました。敬具

8パズル

投稿者：永野護投稿日：2011年 1月23日(日)10時49分52秒

8パズル（3×3)を解くプログラムをつくっています。評価関数としては目標状態と現在の不一致の駒の枚数としてみましたが、千日手になってうまくいきませんでした。不一致の駒の枚数とマンハッタン距離の和を評価関数とすべきなのでしょうか。いつもいつもお頼みするばかりで誠に恐縮なのですが山登り法で8パズルを解く方法をご教授してもらえないでしょうか。謹具

Re: 8パズル

投稿者：山中和義投稿日：2011年 1月26日(水)15時23分5秒

> No.1485[元記事へ] 永野護さんへのお返事です。 > 8パズル（3×3)を解くプログラムをつくっています。千日手は、過去と同じ盤面になって無限ループになるからです。履歴をとって、チェックする必要があります。評価関数はどちらを使ってもうまくいかない場合があります。局所的な判断ですから、それが大局的に最適かどうかは分かりません。たとえば、 DATA 6,2,9 DATA 1,7,3 DATA 5,4,8 の場合は、解けません。マンハッタン距離によるサンプル LET M=3 !MxNパズル LET N=3 !DATA 1,6,2 !開始の盤面　※9は空きを意味する !DATA 5,7,3 !DATA 9,4,8 DATA 6,9,2 DATA 1,7,3 DATA 5,4,8 DIM B(M*N) MAT READ B DATA 1,2,3 !終了の盤面 DATA 4,5,6 DATA 7,8,9 DIM G(M*N) MAT READ G DIM H(0 TO 1000,M*N) !盤面の履歴（手順） CALL hill_climb_search(0,M,N,B,G,H) END EXTERNAL SUB hill_climb_search(p,M,N,B(),G(),H(,)) !山登り法 PRINT p;"手" !debug !!!IF p>=100 THEN EXIT SUB !上限を設定する FOR j=1 TO M*N !p手目の盤面を記録する LET H(p,j)=B(j) NEXT j LET C=0 !不一致の駒（数字）の枚数 FOR i=1 TO M*N IF B(i)<>G(i) THEN LET C=C+1 IF B(i)=9 THEN LET sp=i !空きを探す NEXT i IF C=0 THEN !終了の盤面なら FOR i=p TO 0 STEP -1 !履歴（手順）を表示する PRINT i;": "; FOR j=1 TO M*N !盤面を表示する PRINT H(i,j); NEXT j PRINT NEXT i !STOP !１つのみ!!! ELSE DIM S(M*N) !save it MAT S=B LET E0=cost(M,N,B,G) !現状の盤面の評価値を得る !空きの上下左右の位置にある駒（数字）を移動させる PRINT sp !debug IF sp>N THEN !１行目以外なら、上の数字を移動させる LET B(sp)=B(sp-M) LET B(sp-M)=9 IF cost(M,N,B,G)<=E0 THEN !評価値が良くなれば MAT PRINT B; !debug CALL history(p,M,N,B,H, rc) !新規の盤面なら IF rc=0 THEN CALL hill_climb_search(p+1,M,N,B,G,H) END IF MAT B=S !restore it END IF IF sp<=M*N-N THEN !M行目以外なら、下の数字を移動させる LET B(sp)=B(sp+M) LET B(sp+M)=9 IF cost(M,N,B,G)<=E0 THEN MAT PRINT B; !debug CALL history(p,M,N,B,H, rc) IF rc=0 THEN CALL hill_climb_search(p+1,M,N,B,G,H) END IF MAT B=S END IF IF MOD(sp-1,M)>0 THEN !１列目以外なら、左の数字を移動させる LET B(sp)=B(sp-1) LET B(sp-1)=9 IF cost(M,N,B,G)<=E0 THEN MAT PRINT B; !debug CALL history(p,M,N,B,H, rc) IF rc=0 THEN CALL hill_climb_search(p+1,M,N,B,G,H) END IF MAT B=S END IF IF MOD(sp-1,M)<M-1 THEN !N列目以外なら、右の数字を移動させる LET B(sp)=B(sp+1) LET B(sp+1)=9 IF cost(M,N,B,G)<=E0 THEN MAT PRINT B; !debug CALL history(p,M,N,B,H, rc) IF rc=0 THEN CALL hill_climb_search(p+1,M,N,B,G,H) END IF MAT B=S END IF END IF END SUB EXTERNAL SUB history(p,M,N,B(),H(,), rc) !同じ盤面かどうか確認する LET rc=1 FOR i=0 TO p FOR j=1 TO M*N IF H(i,j)<>B(j) THEN EXIT FOR !並びが異なるなら NEXT j IF j>M*N THEN EXIT SUB !既出なら NEXT i LET rc=0 END SUB EXTERNAL FUNCTION cost(M,N,B(),G()) !評価関数 LET c=0 FOR i=1 TO M*N LET Bx=MOD(B(i)-1,N) !列番号0～N-1 LET By=INT((B(i)-1)/M) !行番号0～M-1 LET Gx=MOD(G(i)-1,N) LET Gy=INT((G(i)-1)/M) !!!PRINT Bx;By; Gx;Gy !debug LET c=c+ABS(Bx-Gx)+ABS(By-Gy) !マンハッタン距離 NEXT i LET cost=c END FUNCTION

8パズル

投稿者：永野護投稿日：2011年 1月26日(水)16時15分22秒

山中様、大変お手数をおかけしました。貴重なプログラムを作って頂いた事に心より感謝します。お忙しい中、本当にすいませんでした。山登り法というのは完全ではないということがわかりました。私としては解が１つあればよかったのですが。パズルの問題というのはどれもロジックが難しいです。私が住んでいる高知市も最低気温は氷点下のときがあります。まだまだ寒い日が続きますが、くれぐれもお体を大切になさって下さい。謹具

Re: 8パズル

投稿者：山中和義投稿日：2011年 1月28日(金)16時36分5秒

> No.1487[元記事へ] 永野護さんへのお返事です。 3x3の場合、盤面の数は181,440通り。最適解の最長手数は、31手です。これより、手数の上限を設ければバックトラック法で解を見つけることができます。１つ見つかれば、これを上限として、それより手数が少ないものを見つけようとします。探索途中で、より手数が少ないものが、より早く見つかれば、処理時間は速くなります。 !M行N列パズル　最適解の最長手数 ! !3x3の場合、盤面の数は181,440通り。31手 ! ! DATA 6,4,7 ![1] ! DATA 8,5,9 ! DATA 3,2,1 ! ! DATA 8,6,7 ![2] ! DATA 2,5,4 ! DATA 3,9,1 !の２つ。 LET M=3 !M行N列パズル LET N=3 DATA 6,2,9 !開始の盤面　※9は空きを意味する DATA 1,7,3 DATA 5,4,8 DIM B(M*N) MAT READ B MAT PRINT B; !debug DATA 1,2,3 !終了の盤面 DATA 4,5,6 DATA 7,8,9 DIM G(M*N) MAT READ G MAT PRINT G; !debug PUBLIC NUMERIC cMAX LET cMAX=31 DIM H(0 TO cMAX,M*N) !盤面の履歴（手順） CALL hill_climb_search(0,M,N,B,G,H) END EXTERNAL SUB hill_climb_search(p,M,N,B(),G(),H(,)) !山登り法 !!!PRINT p;"手" !debug FOR j=1 TO M*N !p手目の盤面を記録する LET H(p,j)=B(j) NEXT j LET c=cost(M,N,B,G) IF p+c-1>cMax THEN EXIT SUB !残り手数（予想）と上限から、これ以降の展開は諦める IF c=0 THEN !終了の盤面なら LET cMAX=p FOR i=0 TO p !履歴（手順）を表示する PRINT i;": "; FOR j=1 TO M*N !盤面を表示する PRINT H(i,j); NEXT j PRINT NEXT i PRINT !STOP !１つのみ!!! ELSE DIM S(M*N) !save it MAT S=B !空きの上下左右の位置にある駒（数字）を移動させる FOR sp=1 TO M*N !空きを探す IF B(sp)=M*N THEN EXIT FOR NEXT sp IF sp>N THEN CALL move(sp-N,sp) !１行目以外なら、上の数字を移動させる IF sp<=M*N-N THEN CALL move(sp+N,sp) !M行目以外なら、下の数字を移動させる IF MOD(sp-1,N)>0 THEN CALL move(sp-1,sp) !１列目以外なら、左の数字を移動させる IF MOD(sp-1,N)<N-1 THEN CALL move(sp+1,sp) !N列目以外なら、右の数字を移動させる END IF SUB move(i,j) !i位置からj位置へ移動する LET B(j)=B(i) !数字を移動する LET B(i)=M*N !空きにする CALL history(p,M,N,B,H, rc) !新規の盤面なら IF rc=0 THEN CALL hill_climb_search(p+1,M,N,B,G,H) MAT B=S !restore it END SUB END SUB EXTERNAL SUB history(p,M,N,B(),H(,), rc) !同じ盤面かどうか確認する LET rc=1 !既出 FOR i=0 TO p FOR j=1 TO M*N IF H(i,j)<>B(j) THEN EXIT FOR !並びが異なるなら NEXT j IF j>M*N THEN EXIT SUB !すべて同じなら NEXT i LET rc=0 !新規 END SUB EXTERNAL FUNCTION cost(M,N,B(),G()) !評価関数 LET c=0 FOR i=1 TO M*N IF B(i)<>G(i) THEN LET c=c+1 !不一致の駒（数字）の枚数 NEXT i LET cost=c END FUNCTION

8パズル

投稿者：永野護投稿日：2011年 1月30日(日)11時39分53秒

山中様、回答ありがとうございました。お手数をおかけしました。敬具

超限帰納法

投稿者：永野護投稿日：2011年 2月10日(木)11時49分58秒

お世話になります。プログラムの話ではないのですが、お許し下さい。 2つ質問させてください。質問1.超限帰納法について奇数の和はn^2であることの証明 1.n=1の時　　1^2=1で成り立つ。 2.n=kの時成り立つと仮定すればn=k+1の時は、1+3+5+......(2k-1)+(2k+1)=k^2+2k+1 =(k+1)^2となり成り立つ。ゆえにすべての奇数nで成り立つ。 ***** 以上の証明は数学的帰納法でしょうか。それとも対象が全ての自然数nではなくて奇数であるから、こうゆう場合は超限帰納法というのでしょうか。 ----------------------------------- -------------------------------------- 質問2.スティルチェス積分について ∫1dsin(x)=∫cos(x)dx=〔sin(x)〕=1-0=1(積分範囲は0<=x<=pai/2) (dsin(x)=cos(x)dxを使いました) 上記の計算もスティルチェス積分というのでしょうか。お手数おかけします。なにとぞ宜しくお願いします。

Re: 超限帰納法

投稿者：山中和義投稿日：2011年 2月11日(金)10時26分33秒

> No.1491[元記事へ] 永野護さんへのお返事です。 > 質問1.超限帰納法について > 質問2.スティルチェス積分について自然数kに対して、k番目の奇数を対応させて論じているので、数学的帰納法です。置換積分法を使ったリーマン積分です。一応両方ともその拡張ですから、拡張範囲で使っていると言えなくもないでしょう。

超限帰納法

投稿者：永野護投稿日：2011年 2月12日(土)10時46分38秒

山中様、回答ありがとうございました。長年気になっていたことが一応解決しました。いつもお手数おかけして申し訳なく思っています。本当にありがとうございました。謹具

MacBook air と十進Basic

投稿者：入谷純

投稿日：2011年 2月17日(木)10時07分10秒

場違いかも知れませんが，質問をさせて下さい。私は自宅のimac(10.6.6, 3.06GHz intel Core 2 Duo) と職場のimac(10.5, intel) で十進Basicを利用させてもらっています。大変満足して，経済学で必要な数値計算に使っています。去年にMacBook air (10.6.6, 2.13GHz intel Core 2 Duo) を購入しました。旅先で計算をする必要がある時に，十進Basic を利用たいのですが，稼働してくれません。ダブルクリックをすると，パッと開く反応があるのですが，それきりです。プログラムの方から開こうとしても，動いてくれません。計算機に詳しい方にお聴きしても，今のところ何が問題かわかりません。申し訳ないですが，何かヒントを頂ければと思い，掲示板を利用させていただきました。宜しくお願いします。

Re: MacBook air と十進Basic

投稿者：白石和夫投稿日：2011年 2月17日(木)21時05分33秒

> No.1494[元記事へ] 古いバージョンの十進BASIC（MAC版）だと動きますか。使っているLazarusのバージョンが違うと動作が異なる可能性があります。 ver 0.5.5.5と0.6.0.0はたぶん同じバージョンのLazarusを使っています。この2つの版はLazarusでプリンタが使えるようになったので，印刷機能を有効にしています。たとえば，プリンタがひとつも登録されていないと起動できないなどという不具合をもっている可能性もあります。

Re: MacBook air と十進Basic

投稿者：入谷純

投稿日：2011年 2月19日(土)08時50分24秒

> No.1495[元記事へ] 白石和夫さん，お返事有り難うございます。 > 古いバージョンの十進BASIC（MAC版）だと動きますか。 0.5.5.5と0.5.5.4 の二つを down load して確かめました。結果は同じでした。 > 使っているLazarusのバージョンが違うと動作が異なる可能性があります。 > ver 0.5.5.5と0.6.0.0はたぶん同じバージョンのLazarusを使っています。 > この2つの版はLazarusでプリンタが使えるようになったので，印刷機能を有効にしています。 > たとえば，プリンタがひとつも登録されていないと起動できないなどという不具合をもっている可能性もあります。 > MacBook air にはプリンター関係のことを一切考えていませんでした。プリンターの登録を試してみました。見事に動き始めました。有り難うございました。 40年以上前に最初にフォートランを学びました。Basic は昔に戻った感じで使え，とても良い気分です。十進Basicのおかげで若返るかも知れません。

Re: MacBook air と十進Basic

投稿者：白石和夫投稿日：2011年 2月19日(土)11時12分39秒

> No.1496[元記事へ] ご報告ありがとうございました。 Lazarusの開発チームも潤沢な資金を持っているとは思えないので，プリンタなしでの環境での動作チェックの機会がないのだろうと思います。実際のプリンタがつながっていなくてもプリンタドライバが入っていれば Okだと思うので，トラブル対策のところに追記しておきたいと思います。 (補記) Linuxだと仮想マシンでプリンタなしの環境も簡単に作れるので試してみましたが， Linuxの場合はプリンタなしでも動作するようです。

πの計算してみました。

投稿者：今村　文広投稿日：2011年 2月20日(日)16時23分54秒

以前から気になっていた算術幾何平均によるπの近似計算を10進BASICで行ってみました。1000桁まで求まっているようです。 !算術幾何平均によるπの算出公式 !改良サラミン・ブレントの計算公式 OPTION ARITHMETIC DECIMAL_HIGH !10進1000桁 OPTION BASE 0 DIM C(10) LET a=1 ! A0=1 LET b=1/2 ! B0=1/2 LET C(0)=a-b ! C0=A0-B0 LET Cs=0 FOR n=1 TO 10 LET An=((a+b)/2+SQR(a*b))/2 ! A(n+1)=((A(n)+B(n))/2+√(A(n)B(n)))/2 LET Bn=SQR(a*b) ! B(n+1)=√(A(n)B(n)) LET C(n)=An-Bn ! C(n+1)=A(n+1)-B(n+1) FOR j=0 TO n LET Cs=Cs+2^j*C(j) ! Cs=Σ2^j*C(j) ; j=0～n NEXT j LET PAI=(An+Bn)/(1-Cs) ! π=(A(n)+B(n))/(1-Cs) PRINT n;PAI LET a=An LET b=Bn LET Cs=0 NEXT n END

交流回路解析

投稿者：石橋屋

投稿日：2011年 3月11日(金)11時29分14秒

初めての投稿です．よろしくお願い致します．リタイアした電気系エンジニアです．Basic09,QBasicからVisual Basic5,6を経由し、Delphi6,7 Turbo Delphiを道具として、回路計算を行ってきました．PCにプログラミング言語が同梱されなくなったせいか、自分でモデルを作り、計算式を立て、計算をするという風潮が見られなくなってから久しいように思います．設計現場へのプログラミング言語導入に努力してきましたが、導入費用、ライセンスの観点から、現在はlazarusを推奨しています．Delphiで作った回路計算用コンポーネントをlazarusに移植し、一応の環境を作り上げました．しかし、プログラミングの経験のない人にはlazarusは取っ付きにくいようで、入門用の言語を探していました．そんな折も折、5日前に十進Basicに遭遇しました．名前を見た限り、失礼ながら「おもちゃっぽい」枠組みだろうな、とタカをくくっていたのですが、ダウンロードして、いざ動かしてみるとそのしっかりした仕組に驚かされました．何よりも嬉しかったのは、複素数が普通にサポートされている点です．Delphiも複素数をサポートしていますがライブラリーにバグがあり、技術系さんには当たり前の10^-6程度の小さな値が使えません．仕方が無いので、小さなパッチを当てて使ったものです．lazarusuの複素数サポートは実用的には問題がありません．十進BASIC習熟のため、この掲示板を見ながらいくつかのプログラムを作っています．この掲示板では数学問題に興味をお持ちの方が多いようで、回路問題はあまり論じておられなくて残念に思いました．しかし、「複素数」といえば回路計算、ということで早速簡単なプログラムを作って確認しました．このプログラムは複素数の行列演算が可能かどうかを確認するためのものです．期待通りの結果が出てとても喜んでいます．もう少し習熟してから、昔の職場への普及を図りたいと考えています．それにしても、このように美しいソフトが、PCにバインドされれば、エンジニアのマインドも少しは改善されるでしょうに．回路計算への応用に興味ある方がおられるようでしたら、いくつかの例をご紹介したいと考えております．今回のプログラムのリストです．回路モデルと基本の計算式は添付ファイルを参照してください．回路方程式は、いわゆる節点解析をベースにしています．使ってみての感想ですが．Graphicで描画される線や点のサイズが小さい（細い）ので表示された結果が良く見えません．今回は稚拙な方法で大きなドットを作って見やすくしたつもりです．もう少しスマートで汎用的な方法はないでしょうか？ OPTION ARITHMETIC COMPLEX OPTION BASE 0 SUB PutDot(i,x) ASK WINDOW w,H,LL,RR LET sw=w/641*1 LET sh=h/641*10 PLOT AREA:i,x;i-sw,x;i+sw,x;i,x+sh;i,x-sh END SUB SUB DrawLog(L,H) SET WINDOW L,H,-42,42 ASK LINE STYLE s ASK LINE COLOR col SET LINE COLOR 15 SET TEXT COLOR 1 SET TEXT FONT "Century Gothic BOLD ITALIC",12 FOR i=L TO H STEP 1 SET LINE STYLE 2 PLOT LINES :i,-42;i,42 LET k=10^i CALL un(k,uni$) SET TEXT JUSTIFY "LEFT","BASE" PLOT TEXT ,AT i,0:STR$(k)&uni$ SET LINE STYLE 3 FOR j=2 TO 9 PLOT LINES :LOG10(j*10^i),-42;LOG10(j*10^i),42 NEXT j NEXT i FOR j=-40 TO 40 STEP 10 IF J=0 THEN SET LINE STYLE 0 ELSE SET LINE STYLE 3 END if SET TEXT FONT "Century Gothic BOLD ITALIC",12 SET TEXT COLOR "blue" SET TEXT JUSTIFY "LEFT","half" PLOT TEXT ,AT LOG10(1.2*FL),j:STR$(J)&"db" IF j>=-20 AND j<=20 THEN SET text COLOR "RED" SET TEXT JUSTIFY "RIGHT","half" SET TEXT FONT "ＭＳ明朝",12 PLOT TEXT ,AT H,j:STR$(J*9)&"°" END if PLOT LINES :L,j;H,j NEXT j SET LINE STYLE s SET LINE COLOR col END SUB SUB UN(n,uni$) LET x=INT(INT(LOG10(n/1000))/3)+1 IF x<0 THEN LET x=0 ELSE LET n=n/1000^x END IF LET uni$=u$(x) END SUB DEF db(x)=20*LOG10(ABS(x)) DEF SINH(x)=(EXP(x)-EXP(-x))/2 DEF COSH(x)=(exp(x)+exp(-x))/2 DATA "","k","M","G","T" DIM U$(5) FOR j=0 TO 4 READ U$(j) NEXT j LET fl=10E3 ! fmin LET fh=1200E3 ! fmax CALL DrawLog(LOG10(fl),LOG10(fh)) LET f0=1E6 ! Band width of OP AMP LET G0=1E5 ! DC Gain of OP AMP LET w0=2*PI*f0 LET g1=1/20E3 ! 1/R1 LET g2=1/30E3 ! 1/R2 LET g3=1/12E3 ! 1/R3 LET gout=1/2000 ! 1/Rout LET C1=330E-12 LET C2=33E-12 SET POINT STYLE 1 LET f=fl DIM Ak(0 TO 1,0 TO 1) DIM ax(0 TO 1) DIM b(0 TO 1) DIM AkI(2,2) LET b(0)=g1 LET b(1)=0 DIM Bk(0 TO 2,0 TO 2) DIM Bx(0 TO 2) DIM Bb(0 TO 2) DIM BkI(3,3) LET Bb(0)=g1 LET Bb(1)=0 LET Bb(2)=0 DO LET w=2*PI*f LET Gop=G0/COMPLEX(1,w*G0/w0) !OP AMPのゲイン LET YC1=COMPLEX(0,w*C1) LET YC2=COMPLEX(0,w*C2) LET Ak(0,0)=g1+g2+g3+YC1 LET Ak(0,1)=-g2 LET Ak(1,0)=g3 LET Ak(1,1)=YC2 !OP AMP のゲインを∞としたとき MAT AkI=INV(Ak) MAT ax=AkI*b LET Glpf=AX(1) !OP AMP のゲインをGopの場合 LET Ak(0,1)=-g2+g3/Gop LET Ak(1,1)=YC2+(YC2+g3)/Gop SET area COLOR "BLUE" CALL putdot( LOG10(f),db(Glpf)) SET area COLOR "RED" CALL putdot( LOG10(f),arg(Glpf)*20/PI) MAT AkI=INV(Ak) MAT ax=AkI*b LET Glpf=AX(1) SET area COLOR "MAGENTA" CALL putdot( LOG10(f),db(Glpf)) SET area COLOR "GREEN" CALL putdot( LOG10(f),arg(Glpf)*20/PI) ! Routを考慮すると LET Bk(0,0)=g1+g2+g3+YC1 LET Bk(0,1)=g3/Gop LET Bk(0,2)=-g2 LET Bk(1,0)=g3 LET Bk(1,1)=(g3+YC2)/Gop LET Bk(1,2)=YC2 LET Bk(2,0)=-g2 LET Bk(2,1)=-gout+YC2/Gop LET Bk(2,2)=gout+g2+YC2 MAT BkI=INV(Bk) MAT bx=BkI*bb LET Glpf=bx(2) LET G=db(Glpf) SET area COLOR "black" CALL putdot( LOG10(f),db(Glpf)) SET area COLOR "black" CALL putdot( LOG10(f),arg(Glpf)*20/PI) LET f=f*1.01 LOOP UNTIL f>fh END

Re: 交流回路解析

投稿者：白石　和夫投稿日：2011年 3月11日(金)12時05分29秒

> No.1499[元記事へ] 数学を使う諸科学での応用が広まることを期待しています。 Full BASIC規格の範囲には線の太さを変える命令はありませんが，独自拡張で SET LINE WIDTH 命令を用意しています。引数は，標準の太さに対する倍率（整数に限る）です。 Full BASICをObject Pascalに変換するBASICAccも複素数をサポートしています。 Lazarusの新バージョンの公開を待ってBASICAccも次バージョンを出します。複素数は倍精度数のペアで表現します。完全に同一ではありませんが，十進BASICの複素数演算の移植です。次バージョンでは，プログラムを解析して自動的に実数型と複素数型の変数に振り分けることで現在のBASICAccよりも複素数を使うプログラムを高速化します。

Re: 交流回路解析

投稿者：石橋屋

投稿日：2011年 3月11日(金)12時15分52秒

> No.1500[元記事へ] 白石　和夫さんへのお返事です。早速のご返事ありがとうございます、 > 数学を使う諸科学での応用が広まることを期待しています。 ⇒同感です > Full BASIC規格の範囲には線の太さを変える命令はありませんが，独自拡張で > SET LINE WIDTH > 命令を用意しています。引数は，標準の太さに対する倍率（整数に限る）です。 ⇒SET LINE Widthは確認しました．贅沢を言うようですがSET DOT WIDTHみたいな命令はありますか？

Re: 交流回路解析

投稿者：白石　和夫投稿日：2011年 3月11日(金)12時35分26秒

> No.1501[元記事へ] 点の大きさを変える命令は用意していません。プリンタやメタファイルでの利用を考えるとその種の命令もほしい気はします。

Re: 交流回路解析

投稿者：白石和夫投稿日：2011年 3月12日(土)07時45分44秒

> No.1502[元記事へ] POINT STYLEを追加します。ただし，追加されたPOINT STYLEにJISとの互換性はありません。（JISと矛盾することはありません）

Re: 交流回路解析(POINT STYLE)

投稿者：石橋屋投稿日：2011年 3月12日(土)09時01分30秒

> No.1503[元記事へ] 白石和夫様　早朝からご返事ありがとうございます． > POINT STYLEを追加します。 ⇒使用可能になり次第使わせていただきます．

Re: 交流回路解析

投稿者：石橋屋投稿日：2011年 3月14日(月)10時29分26秒

> No.1503[元記事へ] 白石和夫さんへのお返事です。 ver 7.5.0をダウンロードしました.poin styleは使えるのですが、ヘルプが使えません. 「 Web ページへのナビゲーションは取り消されました」と表示されるだけで、肝心のヘルプが表示されません. どうすれば回復するのでしょうか？ SET POINT STYLE 2とするとえらく太い線になります.SET POINT STYLE 1だとひ弱な表示になります、中間はないのでしょうか．

Re: 交流回路解析

投稿者：白石和夫投稿日：2011年 3月14日(月)16時18分49秒

> No.1505[元記事へ] ヘルプが見れないのは，次が原因ではないでしょうか。 http://support.microsoft.com/kb/902225/ja 以下の手順で見れるようになれば，セキュリティが原因です。方法 1 .chm ファイルをダブルクリックします。 [開いているファイル - セキュリティの警告] ダイアログボックスで、[この種類のファイルであれば常に警告する] チェックボックスをオフにします。 [開く] をクリックします。方法 2 .chm ファイルを右クリックし、[プロパティ] をクリックします。 [ブロックの解除] をクリックします。 .chm ファイルをダブルクリックして開きます。なお，追加されたPoint Styleは6と7です。 Point Styleの詳細は，サンプルプログラムの STATEMEN\POINTSTY.BAS を実行してみてください。

Re: 交流回路解析

投稿者：石橋屋投稿日：2011年 3月14日(月)16時37分34秒

> No.1506[元記事へ] 白石和夫さんへのお返事です。回答をありがとうございます. 残念ながら、問題は解決していません. .chmファイルというのはコンパイルされたhelp fileというファイルですね？ご指示のように操作しましたが、下記のようなう反応はしませんでした. ちなみに、OSはWindows 7 Home premiumです．旧バージョンのダウンロードと全く同じ操作をしたつもりですが、どこでどう間違ったのでしょうか. > ヘルプが見れないのは，次が原因ではないでしょうか。 > http://support.microsoft.com/kb/902225/ja > 以下の手順で見れるようになれば，セキュリティが原因です。 > 方法 1 > .chm ファイルをダブルクリックします。 > [開いているファイル - セキュリティの警告] ダイアログボックスで、[この種類のファイルであれば常に警告する] チェックボックスをオフにします。 > [開く] をクリックします。 > 方法 2 > .chm ファイルを右クリックし、[プロパティ] をクリックします。 > [ブロックの解除] をクリックします。 > .chm ファイルをダブルクリックして開きます。 > > なお，追加されたPoint Styleは6と7です。 > Point Styleの詳細は，サンプルプログラムの > STATEMEN\POINTSTY.BAS > を実行してみてください。 > > > >

Re: 交流回路解析

投稿者：白石和夫投稿日：2011年 3月14日(月)17時04分2秒

> No.1507[元記事へ] Windows 7だとしたら，IEのセキュリティで間違いないと思います。「WEBページへのナビゲーションは取り消されました」　で検索してみると，たとえば，次のようなページが見つかります。 http://www.nishishi.com/blog/2009/06/chm_help_tips.html また，インストール先を変えると効果があるという記事もあります。もし，BASIC750.zipを展開して実行しているのであれば，展開先をUSBメモリに変えてみたり， BASIC750setup.exeを利用してみるなど，試みてください。以下の画像は，Winodws Vistaで実行してみたものです。

Re: 交流回路解析

投稿者：SECOND 投稿日：2011年 3月15日(火)04時44分22秒

石橋屋さんへのお返事です。 !太い線で曲線を描く場合にも、plot lines を使う方が、程よい太さで、 !サンプリング間隔も拘束されず、高速で遥かに安定した太さを維持できます。 !それから、U$()の添え字の下限には、負数も使えます。m,μ・・ OPTION ARITHMETIC COMPLEX DIM U$(-2 TO 4), ybak(4) ! MAT READ U$ DATA "u", "m", "", "k", "M", "G", "T"! LET L=LOG10( 0.03E-3 ) LET H=LOG10( 30E+4 ) SET WINDOW L,H,-42,42 SET TEXT FONT "Century Gothic BOLD ITALIC",12 SET TEXT JUSTIFY "center","top" ! !---- 横軸対数目盛 SET LINE COLOR 15 FOR i=INT(L) TO H SET COLOR MIX(15) .7,.7,.7 FOR j=2 TO 9 PLOT LINES :LOG10(j*10^i),-42; LOG10(j*10^i),42 NEXT j SET COLOR MIX(15) .4,.4,.4 PLOT LINES :i,-42; i,42 ! !---- 数値と補助単位シンボル LET x=INT(i/3) PLOT TEXT ,AT i,0 :STR$(10^(i-3*x))& u$(x) NEXT i ! !---- dB の横軸 FOR i=-40 TO 40 STEP 10 IF i<>0 THEN PLOT LINES :L,i; H,i NEXT i !---- 0 dB の横軸 SET LINE COLOR 1 PLOT LINES :L,0; H,0 ! SET LINE width 2 LET f=1E-3 DO LET Lf=LOG10(f) LET Zt=100/COMPLEX(1,f) !sample L.P.F( Cutoff=1Hz 6dB/Oct. Gain=40dB) CALL PutDot(1, 20*LOG10( re(Zt)), "green") CALL PutDot(2, 20*LOG10(-im(Zt)), "cyan" ) CALL PutDot(3, 20*LOG10(ABS(Zt)), "blue" ) CALL PutDot(4, arg(Zt)*40/PI , "red" ) LET Lfbak=Lf LET f=f*1.1 LOOP UNTIL 10E3< f SUB PutDot(n,y,c$) IF Lfbak<>0 THEN SET LINE COLOR c$ PLOT LINES: Lfbak,ybak(n); Lf,y END IF LET ybak(n)=y END SUB END

トラブル解決

投稿者：石橋屋投稿日：2011年 3月15日(火)09時08分52秒

> No.1508[元記事へ] 白石和夫さんへのお返事です。白石様　　お手を煩わせて申し訳ありませんでした. 問題は解決しましたが、原因は不明のままです. ご指示いただいた方法でトライしましたが、功を奏したとは申しませんでした. 仕方が無いので、①コンピュータの復旧②十進BASICのアンイストール ③残っている関連ファイルの削除、を実行した後で、十進BASICを再インストールしました．再インストール中、セキュリティに関するメッセージは出ませんでしたので、何事も無く事は終わりました．なお、POINT STYLEの追加部分に関して誤解しておりました． SET POINT STYLE 6　で実行すると表示の質が改善されました．ありがとうございました．

曲線描画

投稿者：石橋屋投稿日：2011年 3月15日(火)09時23分43秒

SECONDさん、ありがとうございます． > !太い線で曲線を描く場合にも、plot lines を使う方が、程よい太さで、 > !サンプリング間隔も拘束されず、高速で遥かに安定した太さを維持できます。 ⇒周波数特性のような曲線の場合はご指摘のようにplot linesのほうが使いやすいと思います．ただし、横軸が時間の「波形」表示の場合はlineで描画するとパルス信号の立ち上がり部分も同じ密度で描画されるので、実物のオシロ波形と比べると違和感があります．Delphi,lazarus版はもともとlineで描画していましたが、昨日、point描画機能を追加し試してみたところ、表示の品位は良くなったように思えます． > !それから、U$()の添え字の下限には、負数も使えます。m,μ・ ⇒添字に負数を使えることは知りませんでした．ありがとうございます．Delphi,lazarus版では単位系はp(10^-12)からGまでカバーしていますが、周波数表示に関しては、小さい方は良いだろう、といことで、今回の例では省略しました．

ＴＶ放送周波数一覧表

投稿者：SECOND 投稿日：2011年 3月15日(火)14時12分23秒

PRINT "ＴＶ放送周波数割当一覧表" PRINT LET i=90 CALL CHANNEL(" ", 1, 3, i, 6, "↓アナログ VHF（2011.7.24 まで)", "") CALL CHANNEL("c",13, 21, i, 6, "↓ケーブル TV", "") LET i=i+2 PRINT REPEAT$(" ",26);"※すき間２MHz" CALL CHANNEL("c",22, 22, i, 6, "", "") CALL CHANNEL(" ", 4, 6, i, 6, "↓アナログ VHF（2011.7.24 まで)", "") CALL CHANNEL(" ", 7, 7, i, 4, "", " ※幅２MHz 重なり") CALL CHANNEL(" ", 8, 8, i, 6, "", " ※(同地域内片方)") CALL CHANNEL(" ", 9, 12, i, 6, "", "") CALL CHANNEL("c",23, 63, i, 6, "↓ケーブル TV", "") LET i=i+2 PRINT REPEAT$(" ",26);"※すき間２MHz" CALL CHANNEL(" ",13, 53, i, 6, "↓地上デジタル物理ch.／アナログ UHF（2011.7.24 まで)" , "") CALL CHANNEL(" ",54, 62, i, 6, "↓アナログ UHF（2011.7.24 まで)" , "") LET i=i+11322 PRINT REPEAT$(" ",26);"※すき間 11,322MHz" CALL CHANNEL(" ",63, 80, i, 6, "↓SHF（難視聴地域用ローカル）", "") SUB CHANNEL(h$,c1,c2,i,s,t$,m$) IF ""< t$ THEN PRINT "-------------------------" PRINT t$ PRINT "-------------------------" END IF FOR c=c1 TO c2 PRINT h$;USING$("##",c);" ch. "; PRINT USING "##,###~##,### MHz<#################":i, i+6, m$; PRINT USING "映像搬送波##,###.## 音声搬送波##,###.##" :i+1.25,i+5.75 LET i=i+s NEXT c END SUB END

確率はどれくらい？

投稿者：GAI 投稿日：2011年 3月21日(月)09時36分11秒

５２枚のトランプのカードからランダムに１３枚を選びパケットを裏向きに持つ。「１３」と声に出してパケットのトップからカードを一枚表向きにしてテーブルへ出す。号令とカードの数字が異なれば、次に「１２」と発声して次のカードを重ねていく。このように最後「１」の発声とカードの数字が合わずに終わってしまう確率が知りたいんですがよろしくお願いいたします。モンテカルロ法的に数千回の試行による実験値でもかまいません。

VIEWPORT で、MAT PLOT CELLS

投稿者：SECOND 投稿日：2011年 3月23日(水)14時45分33秒

!VIEWPORT で、MAT PLOT CELLS を使うと、ｘ座標だけが、 !枠の中に入ってくれません。仕様でしょうか。 SET VIEWPORT 1/2,1, 1/2,1 PLOT LINES: 0,0; 1,0; 1,1; 0,1; 0,0 ! 10 DIM A(2,3) 20 DATA 1,2,3 30 DATA 4,5,6 40 MAT READ A 50 SET WINDOW 0,4,0,4 60 MAT PLOT CELLS,IN 0,0; 2,3 :A 70 END

Re: VIEWPORT で、MAT PLOT CELLS

投稿者：白石和夫投稿日：2011年 3月24日(木)21時43分47秒

> No.1514[元記事へ] ご報告ありがとうございます。おかしいのはWindows版だけで，BASICAccやMAC版では正常です。たぶん，高速処理のために改変した部分のバグです。（Delphiはビットマップを直接いじれるのに対し，　Lazarusではビットマップの内部にはタッチできない）至急，調査します。 (3月25日　補記)修正しました。

PENNY　ANTE

投稿者：永野護投稿日：2011年 4月10日(日)10時58分50秒

いつもお世話になっています。また質問させてください。質問1. ペニー　アンティー（PENNY　ANTE)というゲームがあります。（わくわくする数学　　ロブ　イースタウェイ著　岩谷宏訳　ソフトバンク　クリエイティブ P.84) 1枚のコインを連続して投げます。このとき先手のAさんが連を裏裏裏と予想し、後手のBさんが表裏裏と予想すれば、Bさんが勝つ確率は7/8になるそうです。（予想した連がでれば勝ち）以上のことをシミュレーションで確認するにはどんなプログラムをつくればよろしいでしょうか。質問2. 私たちが使っている時計は長針、短針、秒針が同時に重なることはない（０時０分０秒を除いて）そうですが、時計の盤面をどのように刻みなおしても、（例えば　1日＝16時間、1時間＝32分、1分＝32秒）3針が同時に重なることはないのでしょうか。以上が質問です。よろしくお願いします。　

Re: PENNY　ANTE

投稿者：白石和夫投稿日：2011年 4月10日(日)15時37分48秒

> No.1516[元記事へ] > 質問1. > ペニー　アンティー（PENNY　ANTE)というゲームがあります。 > （わくわくする数学　　ロブ　イースタウェイ著　岩谷宏訳　ソフトバンク　クリエイティブ P.84) > 1枚のコインを連続して投げます。このとき先手のAさんが連を裏裏裏と予想し、後手のBさんが表裏裏と予想すれば、Bさんが勝つ確率は7/8になるそうです。（予想した連がでれば勝ち） > 以上のことをシミュレーションで確認するにはどんなプログラムをつくればよろしいでしょうか。「連」の意味を順序込みで解釈すると，答えが間違っている気がします。「連が表裏裏」の意味を順序を無視して表1枚，裏2枚と解釈すればシミュレーションで近い答えが出ます。 100 LET a=0 110 LET b=0 120 FOR trial=1 TO 10000 130 LET s2=INT(RND*2) 140 LET s3=INT(RND*2) 150 DO 160 LET s1=s2 170 LET s2=s3 180 LET s3=INT(RND*2) 190 IF s1+s2+s3=0 THEN 200 LET a=a+1 210 EXIT DO 220 END IF 230 IF s1+s2+s3=1 THEN 240 LET b=b+1 250 EXIT DO 260 END IF 270 loop 280 PRINT a/trial, b/trial 290 NEXT trial 300 END

PENNY　ANTE

投稿者：永野護投稿日：2011年 4月10日(日)16時52分53秒

お返事ありがとうございました。連は順序込みのようです。本の記述が間違っているのでしょうか.........。

Re: PENNY　ANTE

投稿者：山中和義投稿日：2011年 4月11日(月)10時56分19秒

> No.1518[元記事へ] 永野護さんへのお返事です。勝敗が決まらず連が長くなる場合、その部分を収束させる（A,Bのどちらになるか判定する）ために試行回数を増やさざるを得ないようです。先手が1/8、後手が7/8、7手目で勝負ありとなりました。 90 !!RANDOMIZE !←←←　※必要に応じて 100 LET a=0 !先手の勝ち数 110 LET b=0 !後手 115 LET c=0 !勝敗が決まる手数 120 FOR trial=1 TO 30000 !試行回数←←←←← 130 LET s2=INT(RND*2) !１手目 140 LET s3=INT(RND*2) !２手目 145 LET c=c+2 150 DO !３手目以降 160 LET s1=s2 170 LET s2=s3 180 LET s3=INT(RND*2) 185 LET c=c+1 190 IF s1+s2+s3=0 THEN !先手の判定 200 LET a=a+1 210 EXIT DO 220 END IF 230 IF s1=1 AND s2+s3=0 THEN !後手の判定←←←←← 240 LET b=b+1 250 EXIT DO 260 END IF 270 LOOP 280 !!!PRINT a/trial, b/trial !←←← 290 NEXT trial 295 PRINT a/trial; b/trial; c/trial !←←← 300 END

Re: PENNY　ANTE

投稿者：山中和義投稿日：2011年 4月11日(月)12時17分10秒

> No.1516[元記事へ] 永野護さんへのお返事です。 > 質問2. 最初に12時に重なっているのを除いて、12時間後に重なるときを勘定に入れると 12時間（= H）で長針と短針が重なるのは、11回（= (H-1)回）長針と秒針が重なるのは、１時間（= M分）で59回（= (M-1)回）なので、59*12=708回（= (M-1)*H回）３針が重なる回数は、この２つの数の最大公約数となる。通常の時計の場合は１となるので、最初の12時に重なっているのを除いて、最後の12時に重なっている１回だけ重なる。

ＰＥＮＮＹ　ＡＮＴＥ

投稿者：永野護投稿日：2011年 4月11日(月)14時08分23秒

山中様、白石様、貴重なご助言ありがとうございました。たいへん、助かりました。敬具

PENNY　ANTE

投稿者：永野護投稿日：2011年 4月12日(火)10時15分8秒

PENNY　　ANTE　のプログラムで下記のように125行目と155行目にRANDOMIZEをいれ,90行目の!!をはずしてから実行すると答えが正解からずれてしまうのはなぜでしょうか。同様なことをEXCEL VBAで試してみましたがこちらの場合は正解がでているみたいなのですが。125行目と155行目どちらもだめなのでしょうか。それともどちらか1つだけならかまわないのでしょうか。ご教示いただければ幸いです。 90 RANDOMIZE !←←←　※必要に応じて 100 LET a=0 !先手の勝ち数 110 LET b=0 !後手 115 LET c=0 !勝敗が決まる手数 120 FOR trial=1 TO 30000 !試行回数←←←←← 125 RANDOMIZE 130 LET s2=INT(RND*2) !１手目 140 LET s3=INT(RND*2) !２手目 145 LET c=c+2 150 DO !３手目以降 155 RANDOMIZE 160 LET s1=s2 170 LET s2=s3 180 LET s3=INT(RND*2) 185 LET c=c+1 190 IF s1+s2+s3=0 THEN !先手の判定 200 LET a=a+1 210 EXIT DO 220 END IF 230 IF s1=1 AND s2+s3=0 THEN !後手の判定←←←←← 240 LET b=b+1 250 EXIT DO 260 END IF 270 LOOP 280 !!!PRINT a/trial, b/trial !←←← 290 NEXT trial 295 PRINT a/trial; b/trial 300 END

Re: PENNY　ANTE

投稿者：山中和義投稿日：2011年 4月12日(火)13時40分22秒

> No.1522[元記事へ] 永野護さんへのお返事です。 > それともどちらか1つだけならかまわないのでしょうか。 RANDOMIZE文は、乱数表の選択する。 RND関数は、その乱数表の左上から順に数を得る。という意味です。したがって、プログラムの先頭に１つRANDOMIZE文を記述するというのが通常です。途中で乱数表を替えると、微妙に発生率が変わると思います。しかし、簡易例として 100 !!!RANDOMIZE !←←←←← 110 DIM d(6) 120 LET N=10000 130 PRINT N/6 !予想 140 FOR i=1 TO N !さいころの目 150 RANDOMIZE !←←←←← 160 LET v=INT(RND*6)+1 170 LET d(v)=d(v)+1 180 NEXT i 190 FOR i=1 TO 6 !回数を表示する 200 PRINT i; d(i) 210 NEXT i 220 END で確認すると、乱数の発生が偏り過ぎと思います。

PENNY　ANTE

投稿者：永野護投稿日：2011年 4月12日(火)14時02分47秒

ご教示に感謝します。お手数をおかけしました。

和分方程式

投稿者：永野護投稿日：2011年 4月13日(水)13時06分39秒

たび重なる質問を、お許しください。 Σf(x)(from x=1 to 3)=61 (ただしf(x)は2次以下の整式）とします。 f(x)=ax^2+bx+cとしてx=1のときf(x)=a+b+c x=2のときf(x)=4a+2b+c x=3のときf(x)=9a++3b+c 上記を足し合わせて14a+6b+3c=61 ---------------------------------------------- プログラムで3元1次方程式14a+6b+3c=61を解きます。 for a=1 to 100 for b=1 to 100 for c=1 to 100 if 14*a+6*b+3*c=61 then print "a:b:c:=";a;b;c next next next ------------------------------------------------------ たとえばa=2,b=3,c=5が得られます。ゆえにf(x)=2x^2+3x+5 以上のことは和分方程式を解いたと言いえるでしょうか。どなたかわかる方、よろしくお願いします。

Re: 和分方程式

投稿者：山中和義投稿日：2011年 4月13日(水)20時41分51秒

> No.1525[元記事へ] 永野護さんへのお返事です。 > プログラムで3元1次方程式14a+6b+3c=61を解きます。不定方程式だと思います。

和分方程式

投稿者：永野護投稿日：2011年 4月14日(木)09時07分2秒

私の説明不足でした。 Σf(x)(from x=1 to 3)=61を和分方程式といえるのでしょうか、という質問です。

銅線の表皮効果による電流分布 Ver.2

投稿者：SECOND 投稿日：2011年 4月18日(月)22時24分2秒

!銅線の表皮効果による電流分布 Ver.2 ! !広い範囲の線径と周波数を、カーソル・バーで、それぞれ独立にスキャン出来るようにした。 !交流における、エナメル銅線の太さの最適値を、探すツール。 ! !--------------- OPTION ARITHMETIC COMPLEX ASK bitmap SIZE i,j LET i=MIN(i,j) SET TEXT font "ＭＳゴシック",10*i/500 SET TEXT HEIGHT ABS(worldy(11*i/500)-worldy(0)) SET TEXT background "OPAQUE" PLOT TEXT,AT .1,.93:"左ボタン押下で、赤線↓をドラッグする。　　右クリック終了。" SET AREA COLOR 0 ! !---------------------------- ! 内部半径r(m)の電流方向電界Ｅr ／表皮半径a(m)の電流方向電界Ｅa ＝電流密度の比 ! ! Ｅr/Ｅa= besseli(0,r*k)/ besseli(0,a*k)　…besseli(0,z) 変形ベッセル関数１種０次 ! ! k=(1+i)/δ　δ(表皮の厚さm)=√{2/(ω*u*g)}　…1/s*H/m*S/m= 1/m^2　…H=Wb/A Wb=V*s S=1/Ω ! LET u=PI*4e-7 !H/m 透磁率 !銅(真空) LET g=5.96e7 !S/m 導電率 !銅{ 6.45e7(0℃), 5.96e7(25℃), 4.48e7(100℃) } ! !---------------------------- DIM B1(1,100), B2(1,100), u1$(0 TO 10), u2$(0 TO 10) MAT READ u1$, u2$ DATA 100pm,1nm,10nm,100nm,0.001mm,0.01mm,0.1mm,1mm ,10mm ,100mm,1m DATA 1hz,10hz,100hz,1khz ,10khz ,100khz,1Mhz ,10Mhz,100Mhz,1Ghz ,10Ghz ! LET fqm=10 !log10( 周波数目盛 hz ／線径目盛 m ) ! !----- cursor window SET VIEWPORT 0, 1, .66, .91 SET COLOR MIX(15) .7, .7, .7 ! LET di=.267e-3 !mφ 開始の銅線直径 LET fq=2.67e6 !Hz 開始の周波数 CALL iniaxis( LOG10( .957e3), LOG10( 7.62e9) ) !Hz 周波数の(下限, 上限) ! !----- title window SET VIEWPORT .1, .9, .54, .66 SET WINDOW -1,1, 0,1 SET TEXT background "opaque" SET TEXT JUSTIFY "center","bottom" PLOT TEXT,AT 0, .45:"表皮効果によるエナメル線(銅)の電流密度分布" PLOT TEXT,AT 0, .05:" 表皮　　←　中心　→　　表皮 " SET TEXT JUSTIFY "left","bottom" ! DO !----- foot window SET VIEWPORT 0, 1, .04, .14 SET WINDOW -1, 1, 0,1 PLOT AREA: -1,0; -1,1; 1,1; 1,0 !clear PLOT TEXT,AT -.04, .5 :"Wait …" ! !----- graph window SET VIEWPORT .3, .7, .14, .54 LET a=di/2 !m 導線半径 SET WINDOW -a,a, 0,1 PLOT AREA: -a,0; -a,1; a,1; a,0 !clear SET COLOR MIX(15) .4, .4, .4 DRAW grid( a/5, 0.2) SET LINE STYLE 3 SET LINE COLOR 0 PLOT LINES: -a,0; a,0 SET LINE STYLE 1 !----- SET LINE COLOR "black" WHEN EXCEPTION IN CALL skin( a, fq) LET w$="(交流／直流)コンダクタンスの比 ="& USING$("###.#", sum)& "%" USE LET ext=EXTYPE beep LET w$="Overflow EXTYPE="& STR$(ext) END WHEN !----- foot window SET VIEWPORT 0, 1, .04, .14 SET WINDOW -1, 1, 0,1 PLOT TEXT,AT -.37, .5 :w$ PLOT TEXT,AT -.7, 0 :"(表皮の厚さ"& USING$("#.####",δ*1e3)& "mm)が、断面に占める面積比 ="& USING$("###.#", sum1)& "%" ! !----- cursor window SET VIEWPORT 0, 1, .66, .91 LET w=ux12-lx12 SET WINDOW lx12-.05*w, ux12+.05*w, 0, 1 SET COLOR MIX(15) .7, .7, .7 !----- DO WAIT DELAY .02 MOUSE POLL x,y,mlb,mrb LOOP UNTIL mlb=1 OR mrb=1 !----- cursor input DO WHILE mlb=1 MOUSE POLL x,y,mlb,mrb IF x<=lx12 THEN LET x=lx12+dotx IF ux12<=x THEN LET x=ux12-dotx IF ly1< y AND y< uy1 THEN IF bx1<>pixelx(x) THEN LET di=10^(x-fqm) CALL cursor12( bx1,B1,uy1,ly1, "ｄ="& USING$("###.####",di*1e3)& "mmφ") END IF ELSEIF ly2< y AND y< uy2 THEN IF bx2<>pixelx(x) THEN LET fq=10^x CALL cursor12( bx2,B2,uy2,ly2, "ｆ="& USING$("#,###,###,###",fq)& "Hz") END IF END IF WAIT DELAY .02 LOOP LOOP UNTIL mrb=1 SUB cursor12( bx,B(,), uy,ly, w$) MAT PLOT CELLS, IN worldx(bx),uy; worldx(bx),ly: B LET bx=pixelx(x) ASK PIXEL ARRAY (worldx(bx),uy) B SET LINE COLOR "red" PLOT LINES: worldx(bx),uy; worldx(bx),ly PLOT TEXT,AT lx12,uy: w$ END SUB SUB inicurs(x, bx,B(,), uy,ly) ASK PIXEL SIZE (x,uy; x,ly) i,j MAT B=ZER(i,j) ASK PIXEL ARRAY (x,uy) B LET bx=pixelx(x) END SUB SUB inibox(ux,lx, uy,ly, u$()) SET LINE COLOR 15 FOR i=INT(lx) TO ux FOR j=1 TO 9 LET x=i+LOG10(j) IF lx< x AND x< ux THEN PLOT LINES :x,ly; x,uy NEXT j IF lx<=i THEN PLOT TEXT,AT i,ly :u$(i) NEXT i SET LINE COLOR "blue" PLOT LINES: lx,ly; ux,ly; ux,uy; lx,uy; lx,ly END SUB SUB iniaxis(lx,ux) LET w=ux-lx SET WINDOW lx-.05*w, ux+.05*w, 0, 1 LET dotx=w/(pixelx(w)-pixelx(0)) !----- 問題座標を、ピクセル中心位置に調整する。 LET ux12=worldx(pixelx(ux)) LET lx12=worldx(pixelx(lx)) LET uy1=worldy(pixely(0.85)) LET ly1=worldy(pixely(0.5)) LET uy2=worldy(pixely(0.35)) LET ly2=worldy(pixely(0.0)) !----- CALL inibox( ux12,lx12, uy1,ly1, u1$) LET x=LOG10(di)+fqm CALL inicurs(x, bx1,B1, uy1,ly1) CALL cursor12( bx1,B1,uy1,ly1, "ｄ="& USING$("###.####",di*1e3)& "mmφ") ! CALL inibox( ux12,lx12, uy2,ly2, u2$) LET x=LOG10(fq) CALL inicurs(x, bx2,B2, uy2,ly2) CALL cursor12( bx2,B2,uy2,ly2, "ｆ="& USING$("#,###,###,###",fq)& "Hz") END SUB !------- 台形∫-------- !∫=(f0+f1)/2*⊿+(f1+f2)/2*⊿+ … +(fn-2 + fn-1)/2*⊿+(fn-1 + fn)/2*⊿ !∫=(f0 /2 + f1 + … + fn-2 + fn-1 + fn /2)*⊿ ! !∫={(f0+fn)/2 + f1 + … + fn-2 + fn-1 }*⊿ !∫={(f0-fn)/2 + f1 + … + fn-2 + fn-1 + fn }*⊿ !---------------------- ! ! x^2*( d2y/dx2 ) + x*( dy/dx) - (x^2+n^2)*y =0　…変形ベッセル１種微分方程式(n=次数) ! !ξ^2*(d2Ｅz/dξ2) + ξ*(dＥz/dξ) - ξ^2*Ｅz =0　…円柱の電流方向の電界Ｅz ! !ξ=r*(1+i)/δ δ=√{2/(2*π*f*u*g)}　　…半径ｒ　表皮の厚さδ ! ! Ｅz= besseli(0,ξ) …次数 0 ! !---------------------- SUB skin( a, fq) !( a=半径, fq=周波数 ) LET δ=1/SQR(PI*fq*u*g) !「表皮の厚さ」 ! LET sum1=( 1-MAX((1-δ/a),0)^2 ) *100 !％ ! !sum1 (表皮の厚さ)が、断面に占める面積比 = π{a^2 - (a-δ)^2}/πa^2 = {1 - (1-δ/a)^2} ! LET k=COMPLEX(1,1)/δ !(1+i)/δ LET Ea= ABS( besseli(0,a*k) ) !表面での電流方向電界 LET xb=0 ! r=0 LET yb=1/Ea !(E0/Ea) r=0 での電界比　...besseli(0,0)=1 !--- LET dr=a/256 !(pixelx(a)-pixelx(0)) LET sum=-a/2 !{(E0/Ea)*0 - (Ea/Ea)*a}/2　==(f0-fn)/2 FOR r=dr TO a+dr/2 STEP dr LET Ratio=ABS( besseli(0,r*k))/Ea !Er/Ea　表面に対する電界比 (電流密度比)０～１ PLOT LINES: xb,yb; r,Ratio PLOT LINES:-xb,yb;-r,Ratio LET sum=sum+Ratio*r !＋∑(Er/Ea)*r　 ==(f0-fn)/2 +f1+f2+...+fn LET xb=r LET yb=Ratio NEXT r LET sum=sum*dr *200/a^2 !2π*sum*dr /πa^2 *100% ! 　　　　　　　　　　　　　　　 a !sum= (交流／直流)コンダクタンスの比 = {2π∫Ratio(r)r dr} / {πa^2} ! 　　　　　　　　　　　　　　　 0 END SUB !--------------------------- !　　　　　　　　　　　　　　　　π !　変形ベッセル関数１種 n 次　　I(n,x)= 1/π*∫{ exp(x*cos(t)) *cos(n*t) }*dt !　　　　　　　　　　　　　　　　0 !--------------------------- FUNCTION besseli(n,x) ! 変形ベッセル１種ｎ次 LET m=2*INT( (6+MAX(n,1.5*ABS(x))+9*1.5*ABS(x)/(1.5*ABS(x)+2))/2) LET w=0 FOR kk=1 TO m LET w=w+Tki(kk,x) NEXT kk LET besseli=EXP(x)*Tki(n,x)/(Tki(0,x)+2*w) END FUNCTION FUNCTION Tki(i,x) LET t2=0 LET t1=1e-9 !EPS(0) LET t0=2*(m+1)/x*t1+t2 FOR kp1=m TO i+1 STEP -1 LET t2=t1 LET t1=t0 LET t0=2*kp1/x*t1+t2 NEXT kp1 LET Tki=t0 END FUNCTION END

ASK PIXEL ARRAY

投稿者：SECOND 投稿日：2011年 4月19日(火)23時34分14秒

!これは、このまま、いいのでしょうか。 !単純な推測としては、最後の変更色で、揃えられると、思っていたのですが。 ! ! 別現象 !１番目の色を、特別な色、SET COLOR MIX(1) .5, .5, .5　に選ぶと、 !２番目の色に変更後、同一色指標なのに、変更前の色までも、完全に paste されます。 DIM m(1000,1000) ! !************************************************ SET COLOR MIX(1) .5, .5, .51 !*　ASK PIXEL ARRAY 　→ MAT PLOT CELLS での動作 DRAW disk WITH SCALE(1/5)*SHIFT(1/4,.5) !* SET COLOR MIX(1) .8, .8, .8 !*　同一色指標の色を変更して並べた画素の内、 DRAW disk WITH SCALE(1/5)*SHIFT(3/4,.5) !*　色の変更前の画素は、くり抜かれ、背景色になる。 ! !************************************************ ! ASK PIXEL SIZE (0,1; 1,0) i,j MAT m=ZER(i,j) ASK PIXEL ARRAY (0,1) m !左円(１番目の色) の部分は、くり抜きに、コピーされる。 WAIT DELAY .5 ! CLEAR RANDOMIZE FOR i=1 TO 500 SET LINE COLOR 1+RND*16 PLOT LINES :RND,RND; NEXT i ! WAIT DELAY 1 MAT PLOT CELLS, IN 0,1; 1,0: m !左円(１番目の色) の部分は、背景色のまま、ペーストなし。 END

セルオートマトン

投稿者：しばっち投稿日：2011年 8月14日(日)23時25分29秒

!'ボクセル表現(VOXEL) LET N=32 DIM A(-N TO N,-N TO N),B(-N TO N,-N TO N) FILE GETSAVENAME F$,"dxfファイル|*.dxf" IF F$="" THEN STOP IF POS(UCASE$(F$),".DXF")=0 THEN LET F$=F$ & ".dxf" OPEN #1:NAME F$ ERASE #1 PRINT #1:"0" PRINT #1:"SECTION" PRINT #1:"2" PRINT #1:"ENTITIES" !'-------------------------------------- LET A(0,0)=1 !'初期値 CALL CUBE(#1,0,N-1,0,1) !'-------------------------------------- !'LET A(-N/4,-N/4)=1 !'初期値(4点) !'CALL CUBE(#1,-N/4,N-1,-N/4,1) !'LET A(N/4,N/4)=1 !'CALL CUBE(#1,N/4,N-1,N/4,1) !'LET A(-N/4,N/4)=1 !'CALL CUBE(#1,-N/4,N-1,N/4,1) !'LET A(N/4,-N/4)=1 !'CALL CUBE(#1,N/4,N-1,-N/4,1) !'-------------------------------------- FOR Y=N-2 TO 0 STEP -1 FOR X=-N+1 TO N-1 FOR Z=-N+1 TO N-1 LET B(X,Z)=MOD(A(X-1,Z-1)+A(X-1,Z+1)+A(X+1,Z+1)+A(X+1,Z-1),2) !'LET B(X,Z)=MOD(A(X-1,Z-1)+A(X-1,Z)+A(X-1,Z+1)+A(X,Z-1)+A(X,Z)+A(X,Z+1)+A(X+1,Z-1)+A(X+1,Z)+A(X+1,Z+1),2) IF B(X,Z)<>0 THEN CALL CUBE(#1,X,Y,Z,1) NEXT Z NEXT X MAT A=B NEXT Y PRINT #1:"0" PRINT #1:"ENDSEC" PRINT #1:"0" PRINT #1:"EOF" CLOSE #1 END 以下省略 EXTERNAL SUB CUBE(#1,X,Y,Z,L) END SUB

マンデルブロー

投稿者：しばっち投稿日：2011年 8月14日(日)23時26分11秒

!'ボクセル表現(VOXEL) OPTION BASE 0 DIM CC(3),ZZ(3) READ XS,XE,YS,YE,ZS,ZE,MAXITER,N DATA -2.2,0.5,-1.35,1.35,-1.35,1.35,50,50 !'(要)調整 FILE GETSAVENAME F$,"dxfファイル|*.dxf" IF F$="" THEN STOP IF POS(UCASE$(F$),".DXF")=0 THEN LET F$=F$ & ".dxf" OPEN #1:NAME F$ ERASE #1 PRINT #1:"0" PRINT #1:"SECTION" PRINT #1:"2" PRINT #1:"ENTITIES" FOR Y=YS TO YE STEP (YE-YS)/N FOR X=XS TO XE STEP (XE-XS)/N FOR Z=ZS TO ZE STEP (ZE-ZS)/N LET CC(0)=X !'初期値 LET CC(1)=Y LET CC(2)=Z LET CC(3)=0 MAT ZZ=ZER FOR I=1 TO MAXITER CALL MUL(ZZ,ZZ,ZZ) !'Z=Z^2+C(クォータニオン演算) CALL ADD(ZZ,ZZ,CC) IF ZZ(0)^2+ZZ(1)^2+ZZ(2)^2+ZZ(3)^2>4 THEN EXIT FOR NEXT I IF I>MAXITER THEN CALL RECT(#1,X,Y,Z,(XE-XS)/N,(YE-YS)/N,(ZE-ZS)/N) NEXT Z NEXT X NEXT Y PRINT #1:"0" PRINT #1:"ENDSEC" PRINT #1:"0" PRINT #1:"EOF" CLOSE #1 END EXTERNAL SUB MUL(S(),A(),B()) !'クォータニオン(4元数)掛算 OPTION BASE 0 DIM SS(3) LET SS(0)=A(0)*B(0)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3) LET SS(1)=A(0)*B(1)+A(1)*B(0)+A(2)*B(3)-A(3)*B(2) LET SS(2)=A(0)*B(2)-A(1)*B(3)+A(2)*B(0)+A(3)*B(1) LET SS(3)=A(0)*B(3)+A(1)*B(2)-A(2)*B(1)+A(3)*B(0) MAT S=SS END SUB EXTERNAL SUB ADD(S(),A(),B()) OPTION BASE 0 DIM SS(3) MAT SS=A+B MAT S=SS END SUB 以下省略 EXTERNAL SUB RECT(#1,XX,YY,ZZ,XL,YL,ZL) END SUB

ジュリア集合

投稿者：しばっち投稿日：2011年 8月14日(日)23時27分1秒

!'ボクセル表現(VOXEL) OPTION BASE 0 DIM ZZ(3),Z0(3),Z1(3),Z2(3),TZ(3) READ XS,XE,YS,YE,ZS,ZE,N,NN,MAXITER,EPS DATA -1.5,1.5,-1.5,1.5,-1.5,1.5,80,3,30,0.0005 !'(要)調整 FILE GETSAVENAME F$,"dxfファイル|*.dxf" IF F$="" THEN STOP IF POS(UCASE$(F$),".DXF")=0 THEN LET F$=F$ & ".dxf" OPEN #1:NAME F$ ERASE #1 PRINT #1:"0" PRINT #1:"SECTION" PRINT #1:"2" PRINT #1:"ENTITIES" FOR Y=YS TO YE STEP (YE-YS)/N FOR X=XS TO XE STEP (XE-XS)/N FOR Z=ZS TO ZE STEP (ZE-ZS)/N WHEN EXCEPTION IN LET ZZ(0)=X !'初期値 LET ZZ(1)=Y LET ZZ(2)=Z LET ZZ(3)=0 FOR I=1 TO MAXITER CALL POW(Z1,ZZ,NN) LET Z1(0)=Z1(0)-1 !'Z^NN-1 CALL POW(Z2,ZZ,NN-1) MAT Z2=NN*Z2 !'NN*Z^(NN-1) CALL DIV(Z0,Z1,Z2) MAT Z0=(-1)*Z0 CALL ADD(ZZ,ZZ,Z0) !' Z=Z-(Z^NN-1)/(NN*Z^(NN-1)) ニュートン法(クォータニオン演算) IF ABS(ZZ(0)-TZ(0))<EPS AND ABS(ZZ(1)-TZ(1))<EPS AND ABS(ZZ(2)-TZ(2))<EPS AND ABS(ZZ(3)-TZ(3))<EPS THEN EXIT FOR MAT TZ=ZZ NEXT I IF I>MAXITER THEN CALL RECT(#1,X,Y,Z,(XE-XS)/N,(YE-YS)/N,(ZE-ZS)/N) !'収束しなかったら記録 USE END WHEN NEXT Z NEXT X NEXT Y PRINT #1:"0" PRINT #1:"ENDSEC" PRINT #1:"0" PRINT #1:"EOF" CLOSE #1 END EXTERNAL SUB MUL(S(),A(),B()) !'クォータニオン(4元数)掛算 OPTION BASE 0 DIM SS(3) LET SS(0)=A(0)*B(0)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3) LET SS(1)=A(0)*B(1)+A(1)*B(0)+A(2)*B(3)-A(3)*B(2) LET SS(2)=A(0)*B(2)-A(1)*B(3)+A(2)*B(0)+A(3)*B(1) LET SS(3)=A(0)*B(3)+A(1)*B(2)-A(2)*B(1)+A(3)*B(0) MAT S=SS END SUB EXTERNAL SUB ADD(S(),A(),B()) OPTION BASE 0 DIM SS(3) MAT SS=A+B MAT S=SS END SUB EXTERNAL SUB POW(S(),A(),N) OPTION BASE 0 DIM SS(3) MAT SS=A FOR I=2 TO N CALL MUL(SS,SS,A) NEXT I MAT S=SS END SUB EXTERNAL SUB DIV(S(),A(),B()) OPTION BASE 0 DIM BB(3) LET BB(0)=B(0) LET BB(1)=-B(1) LET BB(2)=-B(2) LET BB(3)=-B(3) CALL MUL(S,A,BB) MAT S=(1/(B(0)^2+B(1)^2+B(2)^2+B(3)^2))*S END SUB 以下省略 EXTERNAL SUB RECT(#1,XX,YY,ZZ,XL,YL,ZL) END SUB

リサージュ曲線 etc.

投稿者：しばっち投稿日：2011年 8月14日(日)23時29分30秒

※関数の周期(変数N)は考慮していない。(要)調整 OPTION BASE 0 LET LL=5 !'チューブ半径 LET NN=8 !'分割数 DIM X(7201),Y(7201),Z(7201),XN(NN),YN(NN),ZN(NN),XM(NN),YM(NN),ZM(NN) RANDOMIZE !'--------------------------------------------------- LET AA=INT(RND*20+1) LET BB=INT(RND*20+1) LET CC=INT(RND*20+1) LET DD=INT(RND*10+1) LET N=360 LET FF$="リサージュ曲線" & STR$(AA) & "_" & STR$(BB) & "_" & STR$(CC) & "_" & STR$(DD) FOR I=0 TO N+1 LET X(I)=100*COS(AA*I*PI/180) LET Z(I)=100*SIN(BB*I*PI/180) LET Y(I)=100*SIN(CC*I*PI/180+DD*PI/2) NEXT I !'--------------------------------------------------- !'LET DD=INT(RND*5+1) !'LET CC=INT(RND*200+1) !'LET BB=INT(RND*200+1) !'LET AA=INT(RND*100+1)+BB !'BB<AA !'LET N=360*10 !'LET FF$="内トロコイド曲線" & STR$(AA) & "_" & STR$(BB) & "_" & STR$(CC) & "_" & STR$(DD) !'FOR I=0 TO N+1 !' LET X(I)=(AA-BB)*COS(I*PI/180)+CC*COS((AA-BB)/BB*I*PI/180) !'スピログラフ !' LET Y(I)=(AA-BB)*SIN(DD*I*PI/180) !' LET Z(I)=(AA-BB)*SIN(I*PI/180)-CC*SIN((AA-BB)/BB*I*PI/180) !'NEXT I !'--------------------------------------------------- !'LET AA=INT(RND*100+1) !'LET BB=INT(RND*200+1)+AA !'AA<BB !'LET CC=INT(RND*200+1) !'LET DD=INT(RND*5+1) !'LET N=360*10 !'LET FF$="外トロコイド曲線" & STR$(AA) & "_" & STR$(BB) & "_" & STR$(CC) & "_" & STR$(DD) !'FOR I=0 TO N+1 !' LET X(I)=(AA+BB)*COS(I*PI/180)-CC*COS((AA+BB)/BB*I*PI/180) !' LET Z(I)=(AA+BB)*SIN(I*PI/180)-CC*SIN((AA+BB)/BB*I*PI/180) !' LET Y(I)=(AA+BB)*SIN(DD*I*PI/180) !'NEXT I !'--------------------------------------------------- !'LET AA=INT(RND*20+1) !'LET BB=INT(RND*20+1) !'LET N=360 !'LET FF$="バラ曲線" & STR$(AA) & "_" & STR$(BB) !'FOR I=0 TO N+1 !' LET R=150*COS(I*PI/180*AA)*COS(I*PI/180*BB) !' LET X(I)=R*COS(I*PI/180)*COS(I*PI/180) !' LET Z(I)=R*COS(I*PI/180)*SIN(I*PI/180) !' LET Y(I)=R*SIN(I*PI/180) !'NEXT I !'--------------------------------------------------- !'LET AA=INT(RND*20+1) !'LET BB=INT(RND*20+1) !'LET N=360 !'LET FF$="球面模様" & STR$(AA) & "_" & STR$(BB) !'FOR I=0 TO N+1 !' LET X(I)=100*SIN(AA*I*PI/180)*COS(BB*I*PI/180) !' LET Z(I)=100*SIN(AA*I*PI/180)*SIN(BB*I*PI/180) !' LET Y(I)=100*COS(AA*I*PI/180) !'NEXT I !'--------------------------------------------------- !'LET N=360*5 !'LET FF$="円柱螺旋" !'FOR I=0 TO N+1 !' LET X(I)=I/36*COS(I*PI/180)+.5 !' LET Z(I)=I/36*SIN(I*PI/180)+.5 !' LET Y(I)=(I/144)^2+.5 !'NEXT I !'--------------------------------------------------- !'LET AA=INT(RND*20+1) !'LET BB=INT(RND*20+1) !'LET N=360*15 !'LET FF$="球面螺旋" & STR$(AA) & "_" & STR$(BB) !'FOR I=0 TO N+1 !' LET X(I)=100*COS(I*PI/180)*SIN(I*PI/180*BB/AA) !' LET Z(I)=100*SIN(I*PI/180)*SIN(I*PI/180*BB/AA) !' LET Y(I)=100*COS(I*PI/180*BB/AA) !'NEXT I !'--------------------------------------------------- !'LET N=360*5 !'LET FF$="円錐螺旋" !'FOR I=0 TO N+1 !' LET X(I)=I/36*COS(I*PI/180)+.5 !' LET Z(I)=I/36*SIN(I*PI/180)+.5 !' LET Y(I)=I/18+.5 !'NEXT I !'--------------------------------------------------- !'LET N=360*5 !'LET FF$="香取線香" !'FOR I=0 TO N+1 !' LET X(I)=(50-I/36)*COS(I*PI/180) !' LET Z(I)=(50-I/36)*SIN(I*PI/180) !' LET Y(I)=SQR(I/36) !'NEXT I !'--------------------------------------------------- !'LET N=360*10 !'LET FF$="バネ状トーラス" !'FOR I=0 TO N+1 !' LET X(I)=(25+12*COS(1.11*I*PI/180))*COS(0.1*I*PI/180) !' LET Z(I)=(25+12*SIN(1.11*I*PI/180))*SIN(0.1*I*PI/180) !' LET Y(I)=12*SIN(1.11*I*PI/180) !'NEXT I !'--------------------------------------------------- !'LET N=360*20 !'LET FF$="手まり" !'FOR I=0 TO N+1 !' LET X(I)=100*SIN(1.11*I*PI/180)*COS(I*PI/180) !' LET Z(I)=100*SIN(1.11*I*PI/180)*SIN(I*PI/180) !' LET Y(I)=100*COS(1.11*I*PI/180) !'NEXT I FILE GETSAVENAME F$,"dxfファイル|*.dxf" IF F$="" THEN STOP IF RIGHT$(F$,1)="!" THEN LET F$=F$(1:LEN(F$)-1) & FF$ IF POS(UCASE$(F$),".DXF")=0 THEN LET F$=F$ & ".dxf" OPEN #1:NAME F$ ERASE #1 PRINT #1:"0" PRINT #1:"SECTION" PRINT #1:"2" PRINT #1:"ENTITIES" FOR I=0 TO N LET XA=X(I+1)-X(I) LET YA=Y(I+1)-Y(I) LET ZA=Z(I+1)-Z(I) LET VX=Y(I+1)*Z(I)-Z(I+1)*Y(I) LET VY=Z(I+1)*X(I)-X(I+1)*Z(I) LET VZ=X(I+1)*Y(I)-Y(I+1)*X(I) LET SS=SQR(VX^2+VY^2+VZ^2) IF SS=0 THEN LET VX=(Y(I+1)+1)*(Z(I)+1)-(Z(I+1)+1)*(Y(I)+1) LET VY=(Z(I+1)+1)*(X(I)+1)-(X(I+1)+1)*(Z(I)+1) LET VZ=(X(I+1)+1)*(Y(I)+1)-(Y(I+1)+1)*(X(I)+1) LET SS=SQR(VX^2+VY^2+VZ^2) END IF LET VX=VX/SS LET VY=VY/SS LET VZ=VZ/SS LET TX=XA+VX*LL LET TY=YA+VY*LL LET TZ=ZA+VZ*LL FOR K=0 TO NN-1 CALL QUATERNIONROT(TX,TY,TZ,XA,YA,ZA,360-K*360/NN,XO,YO,ZO) LET XN(K)=XO+X(I) LET YN(K)=YO+Y(I) LET ZN(K)=ZO+Z(I) NEXT K IF I>0 THEN FOR K=0 TO NN-1 PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:XM(K) PRINT #1:"20" PRINT #1:YM(K) PRINT #1:"30" PRINT #1:ZM(K) PRINT #1:"11" IF K=NN-1 THEN PRINT #1:XM(0) ELSE PRINT #1:XM(K+1) PRINT #1:"21" IF K=NN-1 THEN PRINT #1:YM(0) ELSE PRINT #1:YM(K+1) PRINT #1:"31" IF K=NN-1 THEN PRINT #1:ZM(0) ELSE PRINT #1:ZM(K+1) PRINT #1:"12" IF K=NN-1 THEN PRINT #1:XN(0) ELSE PRINT #1:XN(K+1) PRINT #1:"22" IF K=NN-1 THEN PRINT #1:YN(0) ELSE PRINT #1:YN(K+1) PRINT #1:"32" IF K=NN-1 THEN PRINT #1:ZN(0) ELSE PRINT #1:ZN(K+1) PRINT #1:"13" PRINT #1:XN(K) PRINT #1:"23" PRINT #1:YN(K) PRINT #1:"33" PRINT #1:ZN(K) NEXT K END IF MAT XM=XN MAT YM=YN MAT ZM=ZN NEXT I PRINT #1:"0" PRINT #1:"ENDSEC" PRINT #1:"0" PRINT #1:"EOF" CLOSE #1 END EXTERNAL SUB QUATERNIONROT(X,Y,Z,XA,YA,ZA,THETA,XX,YY,ZZ) !'任意軸回転点 P(X,Y,Z) 回転軸(XA,YA,ZA) 回転後 P'(XX,YY,ZZ) OPTION BASE 0 DIM Q(4),IQ(4),P(4),S(4),T(4) LET R=SQR(XA*XA+YA*YA+ZA*ZA) LET XB=XA/R LET YB=YA/R LET ZB=ZA/R LET Q(0)=COS(THETA/2*PI/180) LET Q(1)=SIN(THETA/2*PI/180)*XB LET Q(2)=SIN(THETA/2*PI/180)*YB LET Q(3)=SIN(THETA/2*PI/180)*ZB LET P(0)=0 LET P(1)=X LET P(2)=Y LET P(3)=Z CALL QUATERNIONINV(Q,IQ) CALL QUATERNIONMUL(Q,P,S) CALL QUATERNIONMUL(S,IQ,T) LET XX=T(1) LET YY=T(2) LET ZZ=T(3) END SUB EXTERNAL SUB QUATERNIONINV(QI(),QO()) LET QO(0)=QI(0) LET QO(1)=-QI(1) LET QO(2)=-QI(2) LET QO(3)=-QI(3) END SUB EXTERNAL SUB QUATERNIONMUL(A(),B(),S()) LET S(0)=A(0)*B(0)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3) LET S(1)=A(0)*B(1)+A(1)*B(0)+A(2)*B(3)-A(3)*B(2) LET S(2)=A(0)*B(2)-A(1)*B(3)+A(2)*B(0)+A(3)*B(1) LET S(3)=A(0)*B(3)+A(1)*B(2)-A(2)*B(1)+A(3)*B(0) END SUB リサージュ曲線 (AA=9,BB=7,CC=16,DD=6)

樹木曲線

投稿者：しばっち投稿日：2011年 8月14日(日)23時30分48秒

LET L=500 !'幹の長さ LET LL=40 !'幹の太さ LET AX=0 !'初期ベクトル LET AY=L LET AZ=0 LET OX=0 LET OY=0 LET OZ=0 INPUT PROMPT "LEVEL=":LEV FILE GETSAVENAME F$,"dxfファイル|*.dxf" IF F$="" THEN STOP IF RIGHT$(F$,1)="!" THEN LET F$=F$(1:LEN(F$)-1) & "樹木曲線" & STR$(LEV) IF POS(UCASE$(F$),".DXF")=0 THEN LET F$=F$ & ".dxf" OPEN #1:NAME F$ ERASE #1 PRINT #1:"0" PRINT #1:"SECTION" PRINT #1:"2" PRINT #1:"ENTITIES" CALL TREE(LEV,AX,AY,AZ,OX,OY,OZ,L,LL,#1) PRINT #1:"0" PRINT #1:"ENDSEC" PRINT #1:"0" PRINT #1:"EOF" CLOSE #1 END EXTERNAL SUB TREE(N,AX,AY,AZ,OX,OY,OZ,L,LL,#1) !'※枝の伸び方(角度)がおかしい IF N>0 THEN CALL SPHERE(#1,AX,AY,AZ,LL) !'関節部に球を配置 CALL TUBE(#1,OX,OY,OZ,AX,AY,AZ,LL) LET A=AY*OZ-AZ*OY !'外積 LET B=AZ*OX-AX*OZ LET C=AX*OY-AY*OX IF OX=0 AND OY=0 AND OZ=0 THEN LET A=0 LET B=1 LET C=0 END IF LET P=ACOS(COSINE(0,1,0,AX-OX,AY-OY,AZ-OZ)) LET XX=COS(30*PI/180)*COS(0) LET YY=SIN(30*PI/180) LET ZZ=COS(30*PI/180)*SIN(0) CALL ROTATE(XX,YY,ZZ,AX-OX+A,AY-OY+B,AZ-OZ+C,P+30,X1,Y1,Z1) LET S=SQR(X1^2+Y1^2+Z1^2) LET X1=X1/S*L*.8 LET Y1=Y1/S*L*.8 LET Z1=Z1/S*L*.8 CALL TREE(N-1,AX+X1,AY+Y1,AZ+Z1,AX,AY,AZ,L*.8,LL*.6,#1) LET XX=COS(30*PI/180)*COS(120*PI/180) LET YY=SIN(30*PI/180) LET ZZ=COS(30*PI/180)*SIN(120*PI/180) CALL ROTATE(XX,YY,ZZ,AX-OX+A,AY-OY+B,AZ-OZ+C,P+30,X2,Y2,Z2) LET S=SQR(X2^2+Y2^2+Z2^2) LET X2=X2/S*L*.8 LET Y2=Y2/S*L*.8 LET Z2=Z2/S*L*.8 CALL TREE(N-1,AX+X2,AY+Y2,AZ+Z2,AX,AY,AZ,L*.8,LL*.6,#1) LET XX=COS(30*PI/180)*COS(240*PI/180) LET YY=SIN(30*PI/180) LET ZZ=COS(30*PI/180)*SIN(240*PI/180) CALL ROTATE(XX,YY,ZZ,AX-OX+A,AY-OY+B,AZ-OZ+C,P+30,X3,Y3,Z3) LET S=SQR(X3^2+Y3^2+Z3^2) LET X3=X3/S*L*.8 LET Y3=Y3/S*L*.8 LET Z3=Z3/S*L*.8 CALL TREE(N-1,AX+X3,AY+Y3,AZ+Z3,AX,AY,AZ,L*.8,LL*.6,#1) END IF END SUB EXTERNAL SUB TUBE(#1,X0,Y0,Z0,X1,Y1,Z1,LL) !'チューブ(蓋なし) LET NN=8 !'分割数 LET X=X1-X0 !'回転軸 LET Y=Y1-Y0 LET Z=Z1-Z0 LET A0=1 !'線分(X0,Y0,Z0)-(X1,Y1,Z1)に垂直で適当なベクトル(A0,B0,C0) LET B0=1 LET C0=1 IF X<>0 THEN !'内積 0より X*A0+Y*B0+Z*C0=0 LET A0=(-B0*Y-C0*Z)/X ELSEIF Y<>0 THEN LET B0=(-A0*X-C0*Z)/Y ELSEIF Z<>0 THEN LET C0=(-A0*X-B0*Y)/Z END IF LET SS=SQR(A0*A0+B0*B0+C0*C0) LET TX=A0*LL/SS LET TY=B0*LL/SS LET TZ=C0*LL/SS FOR K=0 TO NN-1 CALL ROTATE(TX,TY,TZ,X,Y,Z,K*360/NN,XA,YA,ZA) CALL ROTATE(TX,TY,TZ,X,Y,Z,(K+1)*360/NN,XB,YB,ZB) PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:XA+X0 PRINT #1:"20" PRINT #1:YA+Y0 PRINT #1:"30" PRINT #1:ZA+Z0 PRINT #1:"11" PRINT #1:XB+X0 PRINT #1:"21" PRINT #1:YB+Y0 PRINT #1:"31" PRINT #1:ZB+Z0 PRINT #1:"12" PRINT #1:XB+X1 PRINT #1:"22" PRINT #1:YB+Y1 PRINT #1:"32" PRINT #1:ZB+Z1 PRINT #1:"13" PRINT #1:XA+X1 PRINT #1:"23" PRINT #1:YA+Y1 PRINT #1:"33" PRINT #1:ZA+Z1 NEXT K END SUB EXTERNAL SUB SPHERE(#1,XX,YY,ZZ,RR) !'球 LET N=8 !'分割数 LET ALPHA=0 LET BETA=0 LET X0=-RR*SIN(ALPHA*PI/180)*COS(BETA*PI/180)+XX LET Y0=RR*COS(ALPHA*PI/180)+YY LET Z0=RR*SIN(ALPHA*PI/180)*SIN(BETA*PI/180)+ZZ LET ALPHA=180/N FOR BETA=0 TO 359 STEP 360/N LET X1=-RR*SIN(ALPHA*PI/180)*COS(BETA*PI/180)+XX LET Y1=RR*COS(ALPHA*PI/180)+YY LET Z1=RR*SIN(ALPHA*PI/180)*SIN(BETA*PI/180)+ZZ LET X2=-RR*SIN(ALPHA*PI/180)*COS((BETA+360/N)*PI/180)+XX LET Y2=RR*COS(ALPHA*PI/180)+YY LET Z2=RR*SIN(ALPHA*PI/180)*SIN((BETA+360/N)*PI/180)+ZZ PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:X0 PRINT #1:"20" PRINT #1:Y0 PRINT #1:"30" PRINT #1:Z0 PRINT #1:"11" PRINT #1:X2 PRINT #1:"21" PRINT #1:Y2 PRINT #1:"31" PRINT #1:Z2 PRINT #1:"12" PRINT #1:X1 PRINT #1:"22" PRINT #1:Y1 PRINT #1:"32" PRINT #1:Z1 NEXT BETA FOR ALPHA=180/N TO 180-180/N STEP 180/N FOR BETA=0 TO 359 STEP 360/N PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" LET X1=-RR*SIN((ALPHA+180/N)*PI/180)*COS(BETA*PI/180)+XX LET Y1=RR*COS((ALPHA+180/N)*PI/180)+YY LET Z1=RR*SIN((ALPHA+180/N)*PI/180)*SIN(BETA*PI/180)+ZZ LET X2=-RR*SIN((ALPHA+180/N)*PI/180)*COS((BETA-360/N)*PI/180)+XX LET Y2=RR*COS((ALPHA+180/N)*PI/180)+YY LET Z2=RR*SIN((ALPHA+180/N)*PI/180)*SIN((BETA-360/N)*PI/180)+ZZ LET X3=-RR*SIN(ALPHA*PI/180)*COS((BETA-360/N)*PI/180)+XX LET Y3=RR*COS(ALPHA*PI/180)+YY LET Z3=RR*SIN(ALPHA*PI/180)*SIN((BETA-360/N)*PI/180)+ZZ LET X4=-RR*SIN(ALPHA*PI/180)*COS(BETA*PI/180)+XX LET Y4=RR*COS(ALPHA*PI/180)+YY LET Z4=RR*SIN(ALPHA*PI/180)*SIN(BETA*PI/180)+ZZ PRINT #1:"10" PRINT #1:X1 PRINT #1:"20" PRINT #1:Y1 PRINT #1:"30" PRINT #1:Z1 PRINT #1:"11" PRINT #1:X2 PRINT #1:"21" PRINT #1:Y2 PRINT #1:"31" PRINT #1:Z2 PRINT #1:"12" PRINT #1:X3 PRINT #1:"22" PRINT #1:Y3 PRINT #1:"32" PRINT #1:Z3 PRINT #1:"13" PRINT #1:X4 PRINT #1:"23" PRINT #1:Y4 PRINT #1:"33" PRINT #1:Z4 NEXT BETA NEXT ALPHA LET ALPHA=180 LET BETA=0 LET X0=-RR*SIN(ALPHA*PI/180)*COS(BETA*PI/180)+XX LET Y0=RR*COS(ALPHA*PI/180)+YY LET Z0=RR*SIN(ALPHA*PI/180)*SIN(BETA*PI/180)+ZZ LET ALPHA=180-180/N FOR BETA=0 TO 359 STEP 360/N LET X1=-RR*SIN(ALPHA*PI/180)*COS(BETA*PI/180)+XX LET Y1=RR*COS(ALPHA*PI/180)+YY LET Z1=RR*SIN(ALPHA*PI/180)*SIN(BETA*PI/180)+ZZ LET X2=-RR*SIN(ALPHA*PI/180)*COS((BETA+360/N)*PI/180)+XX LET Y2=RR*COS(ALPHA*PI/180)+YY LET Z2=RR*SIN(ALPHA*PI/180)*SIN((BETA+360/N)*PI/180)+ZZ PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:X0 PRINT #1:"20" PRINT #1:Y0 PRINT #1:"30" PRINT #1:Z0 PRINT #1:"11" PRINT #1:X1 PRINT #1:"21" PRINT #1:Y1 PRINT #1:"31" PRINT #1:Z1 PRINT #1:"12" PRINT #1:X2 PRINT #1:"22" PRINT #1:Y2 PRINT #1:"32" PRINT #1:Z2 NEXT BETA END SUB

Re: 樹木曲線

投稿者：しばっち投稿日：2011年 8月14日(日)23時31分35秒

> No.1640[元記事へ] 続き EXTERNAL SUB ROTATE(XX,YY,ZZ,X0,Y0,Z0,TH,NX,NY,NZ) !'任意軸回転(ロドリグの公式) !'(X0,Y0,Z0)と原点を通る回転軸 !'点 P(XX,YY,ZZ)をTH度回転 P'(NX,NY,NZ) DIM A(3,3) LET S=SQR(X0*X0+Y0*Y0+Z0*Z0) LET X=X0/S LET Y=Y0/S LET Z=Z0/S LET A(1,1)=X*X*(1-COS(TH*PI/180))+COS(TH*PI/180) LET A(1,2)=X*Y*(1-COS(TH*PI/180))+Z*SIN(TH*PI/180) LET A(1,3)=X*Z*(1-COS(TH*PI/180))-Y*SIN(TH*PI/180) LET A(2,1)=Y*X*(1-COS(TH*PI/180))-Z*SIN(TH*PI/180) LET A(2,2)=Y*Y*(1-COS(TH*PI/180))+COS(TH*PI/180) LET A(2,3)=Y*Z*(1-COS(TH*PI/180))+X*SIN(TH*PI/180) LET A(3,1)=Z*X*(1-COS(TH*PI/180))+Y*SIN(TH*PI/180) LET A(3,2)=Z*Y*(1-COS(TH*PI/180))-X*SIN(TH*PI/180) LET A(3,3)=Z*Z*(1-COS(TH*PI/180))+COS(TH*PI/180) LET NX=XX*A(1,1)+YY*A(1,2)+ZZ*A(1,3) LET NY=XX*A(2,1)+YY*A(2,2)+ZZ*A(2,3) LET NZ=XX*A(3,1)+YY*A(3,2)+ZZ*A(3,3) END SUB EXTERNAL FUNCTION COSINE(AX,AY,AZ,BX,BY,BZ) LET COSINE=(AX*BX+AY*BY+AZ*BZ)/SQR(AX^2+AY^2+AZ^2)/SQR(BX^2+BY^2+BZ^2) END FUNCTION

ケーリーツリー

投稿者：しばっち投稿日：2011年 8月14日(日)23時32分52秒

INPUT PROMPT "LEVEL=":N LET L=500 FILE GETSAVENAME F$,"dxfファイル|*.dxf" IF F$="" THEN STOP IF RIGHT$(F$,1)="!" THEN LET F$=F$(1:LEN(F$)-1) & "ケーリーツリー" & STR$(N) IF POS(UCASE$(F$),".DXF")=0 THEN LET F$=F$ & ".dxf" OPEN #1:NAME F$ ERASE #1 PRINT #1:"0" PRINT #1:"SECTION" PRINT #1:"2" PRINT #1:"ENTITIES" CALL TREE(N,0,0,0,0,L,0,L,#1) PRINT #1:"0" PRINT #1:"ENDSEC" PRINT #1:"0" PRINT #1:"EOF" CLOSE #1 END EXTERNAL SUB TREE(N,XS,YS,ZS,XE,YE,ZE,L,#1) IF N>0 THEN CALL TUBE(#1,XS,YS,ZS,XE,YE,ZE,10) LET X=XE-XS LET Y=YE-YS LET Z=ZE-ZS IF X<>0 THEN CALL TREE(N-1,XE,YE,ZE,XE,YE,ZE+L/2,L/2,#1) CALL TREE(N-1,XE,YE,ZE,XE,YE,ZE-L.2,L/2,#1) CALL TREE(N-1,XE,YE,ZE,XE,YE+L/2,ZE,L/2,#1) CALL TREE(N-1,XE,YE,ZE,XE,YE-L/2,ZE,L/2,#1) END IF IF Y<>0 THEN CALL TREE(N-1,XE,YE,ZE,XE+L/2,YE,ZE,L/2,#1) CALL TREE(N-1,XE,YE,ZE,XE-L/2,YE,ZE,L/2,#1) CALL TREE(N-1,XE,YE,ZE,XE,YE,ZE+L/2,L/2,#1) CALL TREE(N-1,XE,YE,ZE,XE,YE,ZE-L/2,L/2,#1) END IF IF Z<>0 THEN CALL TREE(N-1,XE,YE,ZE,XE+L/2,YE,ZE,L/2,#1) CALL TREE(N-1,XE,YE,ZE,XE-L/2,YE,ZE,L/2,#1) CALL TREE(N-1,XE,YE,ZE,XE,YE+L/2,ZE,L/2,#1) CALL TREE(N-1,XE,YE,ZE,XE,YE-L/2,ZE,L/2,#1) END IF END IF END SUB 以下省略 EXTERNAL SUB TUBE(#1,X0,Y0,Z0,X1,Y1,Z1,LL) !'チューブ(蓋なし) END SUB EXTERNAL SUB ROTATE(XX,YY,ZZ,X0,Y0,Z0,TH,NX,NY,NZ) !'任意軸回転(ロドリグの公式) END SUB

シェルピンスキー

投稿者：しばっち投稿日：2011年 8月14日(日)23時34分19秒

INPUT PROMPT "LEVEL=":N LET L=500 FILE GETSAVENAME F$,"dxfファイル|*.dxf" IF F$="" THEN STOP IF RIGHT$(F$,1)="!" THEN LET F$=F$(1:LEN(F$)-1) & "シェルピンスキー" & STR$(N) IF POS(UCASE$(F$),".DXF")=0 THEN LET F$=F$ & ".dxf" OPEN #1:NAME F$ ERASE #1 PRINT #1:"0" PRINT #1:"SECTION" PRINT #1:"2" PRINT #1:"ENTITIES" CALL SIERPINSKI(N,0,0,0,L,#1) PRINT #1:"0" PRINT #1:"ENDSEC" PRINT #1:"0" PRINT #1:"EOF" CLOSE #1 END EXTERNAL SUB SIERPINSKI(N,X,Y,Z,L,#1) IF N=0 THEN CALL OBJ(#1,X,Y,Z,L) ELSE CALL SIERPINSKI(N-1,X,Y,Z,L/2,#1) CALL SIERPINSKI(N-1,X+L/2,Y,Z,L/2,#1) CALL SIERPINSKI(N-1,X-L/2,Y,Z,L/2,#1) CALL SIERPINSKI(N-1,X,Y+L/2,Z,L/2,#1) CALL SIERPINSKI(N-1,X,Y-L/2,Z,L/2,#1) CALL SIERPINSKI(N-1,X,Y,Z+L/2,L/2,#1) CALL SIERPINSKI(N-1,X,Y,Z-L/2,L/2,#1) END IF END SUB EXTERNAL SUB OCTAHEDRON(#1,X,Y,Z,XL,YL,ZL) !'8面体 LET X0=X LET Y0=Y+YL/2 LET Z0=Z LET X1=X+XL/2 LET Y1=Y LET Z1=Z LET X2=X LET Y2=Y LET Z2=Z+ZL/2 LET X3=X-XL/2 LET Y3=Y LET Z3=Z LET X4=X LET Y4=Y LET Z4=Z-ZL/2 LET X5=X LET Y5=Y-YL/2 LET Z5=Z PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:X0 PRINT #1:"20" PRINT #1:Y0 PRINT #1:"30" PRINT #1:Z0 PRINT #1:"11" PRINT #1:X1 PRINT #1:"21" PRINT #1:Y1 PRINT #1:"31" PRINT #1:Z1 PRINT #1:"12" PRINT #1:X2 PRINT #1:"22" PRINT #1:Y2 PRINT #1:"32" PRINT #1:Z2 PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:X0 PRINT #1:"20" PRINT #1:Y0 PRINT #1:"30" PRINT #1:Z0 PRINT #1:"11" PRINT #1:X2 PRINT #1:"21" PRINT #1:Y2 PRINT #1:"31" PRINT #1:Z2 PRINT #1:"12" PRINT #1:X3 PRINT #1:"22" PRINT #1:Y3 PRINT #1:"32" PRINT #1:Z3 PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:X0 PRINT #1:"20" PRINT #1:Y0 PRINT #1:"30" PRINT #1:Z0 PRINT #1:"11" PRINT #1:X3 PRINT #1:"21" PRINT #1:Y3 PRINT #1:"31" PRINT #1:Z3 PRINT #1:"12" PRINT #1:X4 PRINT #1:"22" PRINT #1:Y4 PRINT #1:"32" PRINT #1:Z4 PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:X0 PRINT #1:"20" PRINT #1:Y0 PRINT #1:"30" PRINT #1:Z0 PRINT #1:"11" PRINT #1:X4 PRINT #1:"21" PRINT #1:Y4 PRINT #1:"31" PRINT #1:Z4 PRINT #1:"12" PRINT #1:X1 PRINT #1:"22" PRINT #1:Y1 PRINT #1:"32" PRINT #1:Z1 PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:X5 PRINT #1:"20" PRINT #1:Y5 PRINT #1:"30" PRINT #1:Z5 PRINT #1:"11" PRINT #1:X2 PRINT #1:"21" PRINT #1:Y2 PRINT #1:"31" PRINT #1:Z2 PRINT #1:"12" PRINT #1:X1 PRINT #1:"22" PRINT #1:Y1 PRINT #1:"32" PRINT #1:Z1 PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:X5 PRINT #1:"20" PRINT #1:Y5 PRINT #1:"30" PRINT #1:Z5 PRINT #1:"11" PRINT #1:X3 PRINT #1:"21" PRINT #1:Y3 PRINT #1:"31" PRINT #1:Z3 PRINT #1:"12" PRINT #1:X2 PRINT #1:"22" PRINT #1:Y2 PRINT #1:"32" PRINT #1:Z2 PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:X5 PRINT #1:"20" PRINT #1:Y5 PRINT #1:"30" PRINT #1:Z5 PRINT #1:"11" PRINT #1:X4 PRINT #1:"21" PRINT #1:Y4 PRINT #1:"31" PRINT #1:Z4 PRINT #1:"12" PRINT #1:X3 PRINT #1:"22" PRINT #1:Y3 PRINT #1:"32" PRINT #1:Z3 PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:X5 PRINT #1:"20" PRINT #1:Y5 PRINT #1:"30" PRINT #1:Z5 PRINT #1:"11" PRINT #1:X1 PRINT #1:"21" PRINT #1:Y1 PRINT #1:"31" PRINT #1:Z1 PRINT #1:"12" PRINT #1:X4 PRINT #1:"22" PRINT #1:Y4 PRINT #1:"32" PRINT #1:Z4 END SUB

Re: シェルピンスキー

投稿者：しばっち投稿日：2011年 8月14日(日)23時35分10秒

> No.1643[元記事へ] 続き EXTERNAL SUB OBJ(#1,X,Y,Z,L) CALL TUBE(#1,X-L/2,Y,Z,X+L/2,Y,Z,L/4) CALL TUBE(#1,X,Y+L/2,Z,X,Y-L/2,Z,L/4) CALL TUBE(#1,X,Y,Z-L/2,X,Y,Z+L/2,L/4) CALL OCTAHEDRON(#1,X,Y,Z,L,L,L) END SUB EXTERNAL SUB TUBE(#1,X0,Y0,Z0,X1,Y1,Z1,LL) !'角柱(蓋あり) DIM XX(4),YY(4),ZZ(4) LET X=X1-X0 !'線分(X0,Y0,Z0)-(X1,Y1,Z1)に垂直な適当なベクトル(A,B,C) LET Y=Y1-Y0 LET Z=Z1-Z0 LET A=1 LET B=1 LET C=1 IF X<>0 THEN !'内積0よりX*A+Y*B+Z*C=0 LET A=(-B*Y-C*Z)/X ELSEIF Y<>0 THEN LET B=(-A*X-C*Z)/Y ELSEIF Z<>0 THEN LET C=(-A*X-B*Y)/Z END IF LET SS=SQR(A*A+B*B+C*C) LET A=A/SS !'単位ベクトル LET B=B/SS LET C=C/SS LET TX=A*LL LET TY=B*LL LET TZ=C*LL FOR K=0 TO 3 CALL ROTATE(TX,TY,TZ,X,Y,Z,K*90,XA,YA,ZA) CALL ROTATE(TX,TY,TZ,X,Y,Z,(K+1)*90,XB,YB,ZB) PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:XA+X0 PRINT #1:"20" PRINT #1:YA+Y0 PRINT #1:"30" PRINT #1:ZA+Z0 PRINT #1:"11" PRINT #1:XB+X0 PRINT #1:"21" PRINT #1:YB+Y0 PRINT #1:"31" PRINT #1:ZB+Z0 PRINT #1:"12" PRINT #1:XB+X1 PRINT #1:"22" PRINT #1:YB+Y1 PRINT #1:"32" PRINT #1:ZB+Z1 PRINT #1:"13" PRINT #1:XA+X1 PRINT #1:"23" PRINT #1:YA+Y1 PRINT #1:"33" PRINT #1:ZA+Z1 LET XX(K+1)=XA !'(追加部分) LET YY(K+1)=YA LET ZZ(K+1)=ZA NEXT K PRINT #1:"0" !'蓋(追加部分) PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:XX(1)+X1 PRINT #1:"20" PRINT #1:YY(1)+Y1 PRINT #1:"30" PRINT #1:ZZ(1)+Z1 PRINT #1:"11" PRINT #1:XX(2)+X1 PRINT #1:"21" PRINT #1:YY(2)+Y1 PRINT #1:"31" PRINT #1:ZZ(2)+Z1 PRINT #1:"12" PRINT #1:XX(3)+X1 PRINT #1:"22" PRINT #1:YY(3)+Y1 PRINT #1:"32" PRINT #1:ZZ(3)+Z1 PRINT #1:"13" PRINT #1:XX(4)+X1 PRINT #1:"23" PRINT #1:YY(4)+Y1 PRINT #1:"33" PRINT #1:ZZ(4)+Z1 PRINT #1:"0" PRINT #1:"3DFACE" PRINT #1:"8" PRINT #1:"LAYER1" PRINT #1:"62" PRINT #1:"1" PRINT #1:"10" PRINT #1:XX(4)+X0 PRINT #1:"20" PRINT #1:YY(4)+Y0 PRINT #1:"30" PRINT #1:ZZ(4)+Z0 PRINT #1:"11" PRINT #1:XX(3)+X0 PRINT #1:"21" PRINT #1:YY(3)+Y0 PRINT #1:"31" PRINT #1:ZZ(3)+Z0 PRINT #1:"12" PRINT #1:XX(2)+X0 PRINT #1:"22" PRINT #1:YY(2)+Y0 PRINT #1:"32" PRINT #1:ZZ(2)+Z0 PRINT #1:"13" PRINT #1:XX(1)+X0 PRINT #1:"23" PRINT #1:YY(1)+Y0 PRINT #1:"33" PRINT #1:ZZ(1)+Z0 END SUB 以下省略 EXTERNAL SUB ROTATE(XX,YY,ZZ,X0,Y0,Z0,TH,NX,NY,NZ) !'任意軸回転(ロドリグの公式) END SUB

ヒルベルト曲線

投稿者：しばっち投稿日：2011年 8月14日(日)23時36分27秒

PUBLIC NUMERIC XS,YS,ZS,XE,YE,ZE INPUT PROMPT "LEVEL=": N DIM A(3),B(3),C(3),D(3),E(3),F(3),G(3),H(3) MAT READ A,B,C,D,E,F,G,H DATA -1,1,1 DATA -1,1,-1 DATA -1,-1,-1 DATA -1,-1,1 DATA 1,-1,1 DATA 1,-1,-1 DATA 1,1,-1 DATA 1,1,1 LET RR=10 LET XS=0 LET YS=0 LET ZS=0 FILE GETSAVENAME F$, "dxfファイル|*.dxf" IF RIGHT$(F$,1)="!" THEN LET F$=F$(1:LEN(F$)-1) & "ヒルベルト曲線" & STR$(N) IF POS(UCASE$(F$),".DXF")=0 THEN LET F$=F$ & ".dxf" OPEN #1:NAME F$ ERASE #1 PRINT #1:"0" PRINT #1:"SECTION" PRINT #1:"2" PRINT #1:"ENTITIES" CALL SPHERE(#1,XS,YS,ZS,RR) CALL HILBERT(N,A,B,C,D,E,F,G,H,#1) PRINT #1:"0" PRINT #1:"ENDSEC" PRINT #1:"0" PRINT #1:"EOF" CLOSE #1 END EXTERNAL SUB HILBERT(N,A(),B(),C(),D(),E(),F(),G(),H(),#1) IF N>0 THEN CALL HILBERT(N-1,A,D,E,H,G,F,C,B,#1) CALL MOVE(A,B,#1) CALL HILBERT(N-1,A,H,G,B,C,F,E,D,#1) CALL MOVE(B,C,#1) CALL HILBERT(N-1,A,H,G,B,C,F,E,D,#1) CALL MOVE(C,D,#1) CALL HILBERT(N-1,C,D,A,B,G,H,E,F,#1) CALL MOVE(D,E,#1) CALL HILBERT(N-1,C,D,A,B,G,H,E,F,#1) CALL MOVE(E,F,#1) CALL HILBERT(N-1,E,D,C,F,G,B,A,H,#1) CALL MOVE(F,G,#1) CALL HILBERT(N-1,E,D,C,F,G,B,A,H,#1) CALL MOVE(G,H,#1) CALL HILBERT(N-1,G,F,C,B,A,D,E,H,#1) END IF END SUB EXTERNAL SUB MOVE(A(),B(),#1) LET L=100 !'移動量 LET RR=10 !'チューブ半径 LET XE=XS+L*(B(1)-A(1))/2 LET YE=YS+L*(B(2)-A(2))/2 LET ZE=ZS+L*(B(3)-A(3))/2 CALL TUBE(#1,XS,YS,ZS,XE,YE,ZE,RR) CALL SPHERE(#1,XE,YE,ZE,RR) !'関節部に球を配置 LET XS=XE LET YS=YE LET ZS=ZE END SUB 以下省略 EXTERNAL SUB TUBE(#1,X0,Y0,Z0,X1,Y1,Z1,LL) !'チューブ(蓋なし) END SUB EXTERNAL SUB SPHERE(#1,XX,YY,ZZ,RR) !'球 END SUB EXTERNAL SUB ROTATE(XX,YY,ZZ,X0,Y0,Z0,TH,NX,NY,NZ) !'任意軸回転(ロドリグの公式) END SUB ヒルベルト曲線レベル4(ファイルサイズ約76MB)

チューリングマシンの停止性定理

投稿者：永野護投稿日：2011年 8月19日(金)16時22分36秒

計算量の理論の本を読んでいたら、チューリングマシンの停止性定理というのがでており、任意のプログラムの実行が有限時間で解を出力して終了するかいつまでたっても計算が終了しないかを判定するアルゴリズムは存在しない、というようなことが書かれていたのですが、たとえば ------------------------------------------------------------ FOR a=1 TO 1000 IF a^2=25 THEN PRINT a : STOP NEXT a END ----------------------------------------------------------------- というプログラムであれば明らかにa=5を出力して停止すると思われますが、チューリングマシンの停止性定理というのは任意のプログラムを判定できるとは限らないということをいっているのであり、私が上で例示したプログラムの場合は停止すると判定できる、ということでよいでしょうか。まったく素人で恥ずかしいのですが、恥を忍んでの質問です。よろしくお願いします。残暑の厳しい折です。皆様のご健康をお祈りいたします。

Re: チューリングマシンの停止性定理

投稿者：白石和夫投稿日：2011年 8月19日(金)18時20分37秒

FOR a=1 to 1000 　○○○○ NEXT a は，途中でaの値を変えることがない限り必ず停止するので，○○○○ が無限ループを含まなければ必ず停止します。それではおもしろくないので， LET a=1 DO IF a^2=25 THEN PRINT a EXIT DO END IF LET a=a+1 LOOP END の停止性を判定する問題にしてみます。このプログラムだけを対象するする場合のアルゴリズムは， PRINT "Yes" END でいいので，これもつまらない問題です。そこで， LET a=1 DO IF a^2 = □ THEN PRINT a EXIT DO END IF LET a=a+1 LOOP END の型のプログラムの停止性を考えます。この問題は，□ が平方数か否かを判定するアルゴリズムが存在するかどうかの問題になります。そのようなアルゴリズムは実際に存在します。たとえば， INPUT n LET a=1 DO UNTIL a^2>=n LET a=a+1 LOOP IF a^2=n THEN PRINT "平方数" ELSE PRINT "平方数でない" END それでは，対象となるプログラムが， DEF f(x)=◇◇◇ LET a=1 DO IF f(a) = 25 THEN PRINT a EXIT DO END IF LET a=a+1 LOOP END の形だったら，どんなアルゴリズムを用いればいいのでしょうか。（現実のコンピュータは扱うことが可能な数値の範囲が制限されますが，そのような制限はないものとします）

Re: チューリングマシンの停止性定理

投稿者：白石和夫投稿日：2011年 8月20日(土)08時19分36秒

> No.1646[元記事へ] 要するに，「任意のプログラムを判定することはできない」のではなく，「任意のプログラムを判定することのできるプログラムは作れない」です。

チューリングマシンの停止性定理

投稿者：永野護投稿日：2011年 8月20日(土)10時35分23秒

わかりやすい回答ありがとうございました。お手数をおかけしました。敬具

パズル　（バケツを空に）

投稿者：山中和義投稿日：2011年 8月28日(日)19時50分38秒

!問題 !大きなバケツが3つある。6,11,14ずつ水が入っている。 !あるバケツに、それ以上多くの水が入っている他のバケツから、水を一部移して2倍にできる。 !この操作を繰り返して、1つのバケツを空にせよ。 !例 !バケツをA,B,Cとして、6,11,14とすると、 !　バケツBからバケツAに水を移して、12,5,14とする。 !　バケツCからバケツAに水を移して、12,11,8とする。 !　バケツCからバケツBに水を移して、6,22,3とする。 !の3通りの操作ができる。 ! !答え !水量の小さい順にバケツをA,B,Cとする。それぞれの水量をa,b,cとする。 !・q=[b/a]とするqを2進法展開して、k桁となれば、 !　q=q[0]*2^0+q[1]*2^1+q[2]*2^2+ … +q[k-1]*2^(k-1)、ただしq[i]（0≦i≦k-1）は0,1 !　長さkのビット列について !　　ビットq[i]が1なら、バケツBからバケツAに水を移す。すなわち、2*a,b-a,cとする。 !　　ビットq[i]が0なら、バケツCからバケツAに水を移す。すなわち、2*a,b,c-aとする。 !　を行う。 !・移動した結果をあらためて、水量の小さい順にバケツをA,B,Cとする。 !これを繰り返せば、バケツBが空になる。 LET a=6 !バケツの水量 LET b=11 LET c=14 LET s=0 !手数 PRINT s;": "; a;b;c DO WHILE a>0 AND b>0 AND c>0 !どのバケツも空でないなら IF b< a THEN swap a,b !a≦b≦cとする IF c< a THEN swap a,c IF c< b THEN swap b,c PRINT "(";a;",";b;",";c;")" LET q=INT(b/a) PRINT BSTR$(q,2) !debug DO WHILE q>0 !2進法展開 LET s=s+1 IF MOD(q,2)=1 THEN !バケツBから LET b=b-a LET a=2*a ELSE !バケツCから LET c=c-a LET a=2*a END IF PRINT s;": ";a;b;c LET q=INT(q/2) LOOP LOOP END

ピタゴラス数

投稿者：山中和義投稿日：2011年 8月29日(月)09時56分46秒

!ピタゴラス数 ! !問題 !自然数m,nが !　0<n<m、m,nのどちらかは偶数である、(m,n)=1（m,nは互いに素） !を満たすとき、 !既約なピタゴラス数(a,b,c)は、(m^2-n^2, 2*m*n, m^2+n^2)で求まる。 ! !a≦b≦cとして、aの小さい順に求めよ。 ! !答え !c-a=(m^2+n^2)-(m^2-n^2)=2*n^2>0、c-b=(m^2+n^2)-(2*m*n)=(m-n)^2>0より、 !a,bは直角を挟む2辺、cを斜辺となる。 !aとbの大小関係はここでは未定として、 !a=m^2-n^2（奇数）、a=2*m*n（偶数）に場合分けして対応する。 !a=m^2-n^2のとき !　a=m^2-n^2=(m-n)*(m+n)から、aを2つの因数s,t（s<t）に分解する。 !　s=m-n、t=m+nより、b,cをs,tで表すと !　b=2*m*n={(m+n)^2-(m-n)^2}/2=(t^2-s^2)/2 !　c=m^2+n^2={(m+n)^2+(m-n)^2}/2=(t^2+s^2)/2 !a=2*m*nのとき !　a/2=m*nから、aを2つの因数m,nに分解する。 FOR a=1 TO 100 !aの小さい順 IF MOD(a,2)=1 THEN !奇数なら FOR s=INT(SQR(a)) TO 1 STEP -1 !aを2つの因数s,tに分解する LET t=a/s IF t=INT(t) AND s<t THEN LET b=(t^2-s^2)/2 !bを求める IF b=INT(b) AND a<=b THEN LET c=(t^2+s^2)/2 !cを求める IF c=INT(c) AND b<=c THEN IF gcd3(a,b,c)=1 THEN PRINT a;b;c !解を表示する END IF END IF END IF NEXT s ELSE !偶数なら LET a2=a/2 FOR n=INT(SQR(a2)) TO 1 STEP -1 !aを2つの因数m,nに分解する LET m=a2/n IF m=INT(m) AND n<m THEN LET b=(m^2-n^2) !bを求める IF b=INT(b) AND a<=b THEN LET c=(m^2+n^2) !cを求める IF c=INT(c) AND b<=c THEN IF gcd3(a,b,c)=1 THEN PRINT a;b;c !解を表示する END IF END IF END IF NEXT n END IF NEXT a END EXTERNAL FUNCTION gcd3(a,b,c) !最大公約数 LET gcd3=gcd(gcd(a,b),c) END FUNCTION EXTERNAL FUNCTION gcd(a,b) !最大公約数 DO UNTIL b=0 LET t=b LET b=MOD(a,b) LET a=t LOOP LET gcd=a END FUNCTION

質問します

投稿者：baa 投稿日：2011年 8月30日(火)23時33分18秒

初めまして、とても素晴らしいソフトを使わせていただき有難うございます。質問です。Windows版のVersion7.5.5ですが、例えば SAMPLEフォルダの GRAPH.bas や、STATEMENフォルダの VARILNG.BASのように、 MAT INPUT 配列名(?)　文を使うと EXTYPE 7318 内部形式ファイルにINPUT文は使えないとエラーが出ます。この MAT INPUT 配列名(?) 文には、何か設定が必要ですか？

Re: 質問します

投稿者：山中和義投稿日：2011年 9月 1日(木)11時02分7秒

> No.1652[元記事へ] > SAMPLEフォルダの GRAPH.bas や、STATEMENフォルダの VARILNG.BAS 「内部形式ファイルにINPUT文は使えない」というエラーが出て動作しなくなっています。

Re: 質問します

投稿者：白石和夫投稿日：2011年 9月 1日(木)20時15分58秒

> No.1653[元記事へ] バグです。調査します。 > > SAMPLEフォルダの GRAPH.bas や、STATEMENフォルダの VARILNG.BAS > > 「内部形式ファイルにINPUT文は使えない」というエラーが出て動作しなくなっています。 > >

Re: 質問します

投稿者：白石和夫投稿日：2011年 9月 1日(木)20時20分27秒

> No.1652[元記事へ] ご報告ありがとうございました。単なるバグです。至急，修正します。 > 例えば SAMPLEフォルダの GRAPH.bas や、STATEMENフォルダの VARILNG.BASのように、 > > > > MAT INPUT 配列名(?)　文を使うと > > > > EXTYPE 7318 > > 内部形式ファイルにINPUT文は使えない > > > > とエラーが出ます。この MAT INPUT 配列名(?) 文には、何か設定が必要ですか？

!Page-2

投稿者：SECOND 投稿日：2011年 9月 1日(木)21時00分38秒

!Page-2 の始め !------------------------------------------ u0 == IDN( 0 階空間の(実,虚,原)各・行vector) ! m0 u0 m0 == f0() ! |re(ta0),im(ta0), 0, 0| |1, 0, 0, 0| ta0 = f0()１階写像空間の実軸単位・行vector ! |re(tb0),im(tb0), 0, 0| |0, 1, 0, 0| tb0 = f0() 〃〃〃虚軸単位・行vector ! | 0 , 0 , X, 0| |0, 0, X, 0| ! |re(to0),im(to0), 0, 1| |0, 0, 0, 1| to0 = f0() 〃〃〃原点位置・行vector ! !----------------------------------------------- mat u=t0*u ! t0 u u ! |re(ta0),im(ta0), 0, 0| |re(a) ,im(a) , 0, 0| |re(a) ,im(a) , 0, 0| ! |re(tb0),im(tb0), 0, 0|*|re(b) ,im(b) , 0, 0|=|re(b) ,im(b) , 0, 0| ! | 0 , 0 , X, 0| | 0 , 0 , X, 0| | 0 , 0 , X, 0| ! |re(to0),im(to0), 0, 1| |re(zo),im(zo), 0, 1| |re(zo),im(zo), 0, 1| ! !----------------------------------------------- draw picture(zo0,zr0,zi0) with u ! picture in 0 u picture in u ! |re(zr0),im(zr0), 0, 1| |re(a) ,im(a) , 0, 0| |re(zr),im(zr), 0, 1| ! |re(zi0),im(zi0), 0, 1|*|re(b) ,im(b) , 0, 0|=|re(zi),im(zi), 0, 1| ! |re(zo0),im(zo0), 0, 1| | 0 , 0 , 0, 0| |re(zo),im(zo), 0, 1| ! |re(zo),im(zo), 0, 1| ! !------------------------------------------------------------------ !４）0 階座標系を、Ｎ階写像して、その中に、0 階の座標値で絵を描く。 ! !　　各階で、次の階の z0,a,b を、０階～１階の相対座標 to_,ta_,tb_ で送る。 !------------------------------------------------------------------ SUB F23x(k, zo,a,b) !　元空間の、zo=原点 a=実軸単位ベクトル b=虚軸単位ベクトル IF 0< k THEN !次階空間の、to_=原点 ta_=実軸単位ベクトル tb_=虚軸単位ベクトル LET r$=r$& "1" CALL F23x(k-1, re(to0)*a+im(to0)*b+zo, re(ta0)*a+im(ta0)*b, re(tb0)*a+im(tb0)*b) !次階のzo,a,b LET r$=r$& "2" CALL F23x(k-1, re(to1)*a+im(to1)*b+zo, re(ta1)*a+im(ta1)*b, re(tb1)*a+im(tb1)*b) IF o1=2 THEN LET r$=r$& "3" CALL F23x(k-1, re(to2)*a+im(to2)*b+zo, re(ta2)*a+im(ta2)*b, re(tb2)*a+im(tb2)*b) END IF ELSE LET col=INT(cx)+1 !N 階の、原点・座標軸で、0 階の絵を描く DRAW f012_n( re(zo0)*a+im(zo0)*b+zo, re(zr0)*a+im(zr0)*b+zo, re(zi0)*a+im(zi0)*b+zo ) IF o1=2 THEN LET cx=cx+3^(3-N) ELSE LET cx=cx+2^(5-N) LET no=no+1 END IF LET r$=r$(1:LEN(r$)-1) END SUB !-------------------------------------------------------------- !３）0 階絵(zo0,zr0,zi0)を、N 階写像した座標値(zo,zr,zi)で描く。 !-------------------------------------------------------------- SUB F23(k, zo,zr,zi) !初期値( zo,zr,zi ) は 0 階集合 IF 0< k THEN LET r$=r$& "1" CALL F23(k-1, f0(zo),f0(zr),f0(zi)) !1～N 階目集合の呼出し LET r$=r$& "2" CALL F23(k-1, f1(zo),f1(zr),f1(zi)) !２分岐型はココまで IF o1=2 THEN LET r$=r$& "3" CALL F23(k-1, f2(zo),f2(zr),f2(zi)) !３分岐型はココまで END IF ELSE IF o1=2 THEN LET col=MOD(cx,3^3)+1 ELSE LET col=MOD(cx,2^5)+1 DRAW f012_n( zo,zr,zi ) !N 階集合 LET cx=cx+1 LET no=no+1 END IF LET r$=r$(1:LEN(r$)-1) END SUB !----------- ３角形 △(zo,zr,zi) を描く。zo に * の印と、no#route(path) を付ける。 ! プロッター !----------- PICTURE f012_n(zo,zr,zi) IF Nmax<=N THEN SET POINT COLOR col PLOT POINTS: zo ELSEIF 4<=N THEN SET LINE COLOR col PLOT LINES: zo; zr; zi; zo ELSE SET LINE COLOR N+1 IF N=Ne THEN SET LINE width 2 PLOT LINES: zo; zr; zi SET LINE width 1 !--- SET LINE STYLE 3 PLOT LINES: zo; zi SET LINE STYLE 1 !--- SET POINT STYLE 3 SET POINT COLOR N+1 PLOT POINTS: zo SET POINT STYLE 1 !--- IF N=Ne THEN SET TEXT font "", 9*bms PLOT label,AT zo:STR$(no)& r$ SET TEXT font "",18*bms END IF END IF END PICTURE END !--------------- ! key pannel !--------------- MODULE m MODULE OPTION ARITHMETIC COMPLEX PUBLIC STRING fn$(60) PUBLIC NUMERIC mlb,mrb, bms, o(5) SHARE NUMERIC bx0(5),bxw(5),by0(5),byw(5),Hn(5),Tn(5), bcol(60), chE ! ASK bitmap SIZE i,j !(ask bitmap size)=(ask pixel size)-1 LET bms=MIN(i,j)/500 ! ! ch.1 DATA END , "N=N-1" , "N=N+1" , コッホの曲線 DATA レヴィのＣ曲線, ドラゴン集合 , ペアノの曲線 , 葉脈曲線 DATA カニの行列 , クリヌキ正五角形, ブロッコリー , 高木関数 DATA Extra-1 雲 , Extra-2 雷 , Tragon トラゴン, シルピンスキーの… !ガスケット DATA "" ! ch.2 DATA "N=0","N=1", 2, 3 DATA 4, 5 , 6, 7 DATA 8, 9 , 10, 11 DATA 12, 13 , 14, 15 DATA 16, 17 DATA "" ! ch.3 DATA call F23, call F23x, draw D23, call dp23, call F23mx DATA "" ! LET i=1 DO READ IF MISSING THEN EXIT DO: fn$(i) IF fn$(i)="" THEN EXIT DO LET chE=chE+1 LET o(chE)=i !top pointer( channel) DO LET i=i+1 READ fn$(i) IF fn$(i)="" THEN EXIT DO LOOP LOOP ! CALL m.init( 1, .01,.05, 4,16, .98/ 4,.14/4) !(ch, x0,y0, H,T, xw,yw) CALL m.init( 2, .01,.01, 18,18, .98/18,.14/4) !組ch, top_cell位置(x0,y0), 横数H,総数T, cell幅(xw,yw) CALL m.init( 3, .01,.96, 5, 5, .98/ 5,.14/4) !stop EXTERNAL SUB keyin( ky,col) ASK VIEWPORT a,b,c,d ASK WINDOW e,f,g,h SET VIEWPORT 0,1,0,1 SET WINDOW 0,1,0,1 LET ky=0 DO WHILE mlb=1 CALL sensor(i,col) IF i<>ky THEN IF 0< ky THEN CALL colkey(IP(ky/100), MOD(ky,100), bcol(o(IP(ky/100))+MOD(ky,100))) IF 0< i THEN CALL colkey(IP(i/100) , MOD(i,100) , col) LET ky=i END IF WAIT DELAY 0 LOOP WAIT DELAY .1 IF 0< ky THEN CALL colkey(IP(ky/100), MOD(ky,100), bcol(o(IP(ky/100))+MOD(ky,100))) SET VIEWPORT a,b,c,d SET WINDOW e,f,g,h END SUB EXTERNAL SUB sensor(i,col) MOUSE POLL mx,my,mlb,mrb FOR ch=1 TO chE LET j=INT((mx-bx0(ch))/bxw(ch)) LET i=INT((my-by0(ch))/byw(ch)) *Hn(ch) +j IF 0<=j AND j< Hn(ch) AND 0<=i AND i< Tn(ch) THEN LET i=i+ch*100 EXIT SUB END IF NEXT ch LET i=0 END SUB EXTERNAL SUB colkey(ch, k, col) ASK TEXT HEIGHT w0 LET w0=pixely(w0)-pixely(w0/17) !11pt.w0/9~23 18pt.w0/13~38 ASK TEXT JUSTIFY w1$,w2$ !--- SET TEXT font "MS UI Gothic",11*bms SET TEXT JUSTIFY "center","half" SET TEXT background "transparent" SET AREA COLOR col DRAW box(ch, k) WITH SHIFT( MOD(k,Hn(ch))*bxw(ch)+bx0(ch), INT(k/Hn(ch))*byw(ch)+by0(ch)) SET TEXT background "opaque" SET TEXT JUSTIFY w1$,w2$ SET TEXT font "",w0 !w0 は save/restore の繰返しで、小さめ→消滅、大きめ→発散。 END SUB !　　　├ bxw ┤ !　　─┏━━━┓ !　 byw┃　　　┃ ! by0→┗━━━┛ !　　　↑ !　　　bx0 EXTERNAL PICTURE box(ch, k ) PLOT AREA :0,0; bxw(ch),0; bxw(ch),byw(ch); 0,byw(ch) PLOT LINES :0,0; bxw(ch),0; bxw(ch),byw(ch); 0,byw(ch); 0,0 PLOT TEXT,AT .5*bxw(ch), .5*byw(ch) :fn$(o(ch)+k) END PICTURE EXTERNAL SUB BG_col(ch, k, col) ASK VIEWPORT a,b,c,d ASK WINDOW e,f,g,h SET VIEWPORT 0,1,0,1 SET WINDOW 0,1,0,1 LET bcol(o(ch)+k)=col CALL colkey(ch, k, col) SET VIEWPORT a,b,c,d SET WINDOW e,f,g,h END SUB EXTERNAL SUB init(ch, x0,y0, H,T, xw,yw) LET Hn(ch)=H LET Tn(ch)=T LET bx0(ch)=worldy(pixelx(x0)) LET by0(ch)=worldy(pixely(y0)) LET bxw(ch)=worldy(pixelx(xw))-worldy(pixelx(0)) LET byw(ch)=worldy(pixely(yw))-worldy(pixely(0)) FOR k=0 TO Tn(ch)-1 LET bcol(o(ch)+k)=0 CALL colkey(ch, k, 0) NEXT k END SUB EXTERNAL SUB clear2 ASK VIEWPORT a,b,c,d ASK WINDOW e,f,g,h SET VIEWPORT 0,1,0,1 SET WINDOW 0,1,0,1 CLEAR FOR ch=1 TO chE FOR k=0 TO Tn(ch)-1 LET bcol(o(ch)+k)=0 CALL colkey(ch, k, 0) NEXT k NEXT ch SET VIEWPORT a,b,c,d SET WINDOW e,f,g,h END SUB END MODULE

フラクタル画像の追跡　Ver.755

投稿者：SECOND 投稿日：2011年 9月 1日(木)21時01分40秒

!フラクタル画像の追跡　Ver.755　(ver.7.5.5 以降で動きます。） ! N=0 ～3 は、 ! 0 階絵に、実数軸( 実線 )、虚数軸( 破線 )、原点( 描点順番＃path 経路の数列) ! の付いた直角３角形を用い、0 階空間や、絵の 3 階までの、変形経路を、全て表示。 ! N=4 ～以降は、 ! 0 階絵の３角形を、grid と同色の薄い色で１つ表示。初期化の形も異なる。 ! 0 階絵の３角形は、３つの頂点を、マウス左ボタン押下げ、ドラッグして変形すると、 ! リアルタイムに、変形の連鎖状態を、観察できる。 N=0 ～3 でも同様。 !　（速度の点で、3 分岐型で N=7 、2 分岐型で N=11 ぐらいまで。）　操作パネルの ! 「題名」を変更、又は、重ねて左クリックすると、変形した３角形は、初期化する。 !---------------------------------------------------------------------------- OPTION ARITHMETIC COMPLEX DECLARE EXTERNAL NUMERIC m.mlb, m.mrb, m.bms, m.o() DECLARE EXTERNAL STRING m.fn$() ! DIM m0(4,4), m1(4,4), m2(4,4), mc(4,4) SET TEXT font "",18*bms SET TEXT BACKGROUND "OPAQUE" !文字の背景を、色指標 0 で塗る。 SET POINT STYLE 1 ! LET algo=2 !Algorithm. 1:call F23 2:call F23x 3:draw D23 4:call dp23 5:call F23mx ! CALL setN(2) !N2= 2, N3=2 、２分岐型,３分岐型のN LET item=9 !1~13 !------------------------------------------- ●開始のスライド・ショーを止めるには、 LET item=101 !demo.101~113 (1~13) ! この２行を、削除する。 CALL setN(12) !N2=12, N3=N2*log(2)/log(3) ! !------------------------------------------- ! !----------------------------------- ! 複素数ｚ入力の Affine 写像式 !----------------------------------- DEF f0(z)= a0*(z-o0) +b0*conj(z-o0) +o0 DEF f1(z)= a1*(z-o1) +b1*conj(z-o1) +o1 DEF f2(z)= a2*(z-o2) +b2*conj(z-o2) +o2 !------------------- ! 写像式係数の設定 !------------------- SUB Let02( a,b,o, v1,v2,v3) LET a=v1 LET b=v2 LET o=v3 END SUB ! 複素数ｚ入力を画素( 行ベクトル1x4 ) 、写像式を行列 m で表現。 !------------------------------------------ ! 変形指示ＭＡＴ文。　4x4 変形行列 m の作成 !　z*m ← a*(z-o) +b*conj(z-o) +o !------------------------------------------ SUB mat02( m(,), a, b, o) MAT m= SCALE( a ) !a*z MAT mc= SCALE(1,-1)*SCALE( b ) !b*conj(z) MAT m= m+mc !f(z)= a*z + b*conj(z) LET m(4,4)= 1 !　システム予約要素（倍率逆数）、加算しない。 MAT m= SHIFT(-o)*m*SHIFT(o) !f(z)= f(z-o)+o END SUB DO SELECT CASE MOD(item,100) CASE 1 !----- !f0(z)= 0*(z ) +(3+SQR(3)*i)/6*conj(z ) !f1(z)= 0*(z-1) +(3-SQR(3)*i)/6*conj(z-1) +1 !----- CALL Let02( a0,b0,o0, 0, COMPLEX(3,SQR(3))/6, 0) CALL Let02( a1,b1,o1, 0, conj(b0) , 1) !----- CALL mat02( m0, a0,b0,o0 ) CALL mat02( m1, a1,b1,o1 ) CALL Affine("コッホの曲線", 0.5, 0.1, 0.6, 13) CASE 2 !題名,中心X,中心Y,半幅,最大N !----- !f0(z)= (1+i)/2*(z ) +0*conj(z ) !f1(z)= (1-i)/2*(z-1) +0*conj(z-1) +1 !----- CALL Let02( a0,b0,o0, COMPLEX(1,1)/2, 0, 0) CALL Let02( a1,b1,o1, conj(a0) , 0, 1) !----- CALL mat02( m0, a0,b0,o0 ) CALL mat02( m1, a1,b1,o1 ) CALL Affine("レヴィのＣ曲線", 0.5, 0.3, 1.1, 16) CASE 3 !題名,中心X,中心Y,半幅,最大N !----- !f0(z)= (1+i)/2*(z ) +0*conj(z ) !f1(z)= (1+i)/2*(z-1) +0*conj(z-1) +1 !----- CALL Let02( a0,b0,o0, COMPLEX(1,1)/2, 0, 0) CALL Let02( a1,b1,o1, a0 , 0, 1) !----- CALL mat02( m0, a0,b0,o0 ) CALL mat02( m1, a1,b1,o1 ) CALL Affine("ドラゴン集合", 0.5, -0.1, 1.2, 16) CASE 4 !題名,中心X,中心Y,半幅,最大N !----- !f0(z)= 0*(z ) +(1+i)/2*conj(z ) !f1(z)= 0*(z-1) +(1-i)/2*conj(z-1) +1 !----- CALL Let02( a0,b0,o0, 0, COMPLEX(1,1)/2, 0) CALL Let02( a1,b1,o1, 0, conj(b0) , 1) !----- CALL mat02( m0, a0,b0,o0 ) CALL mat02( m1, a1,b1,o1 ) CALL Affine("ペアノの曲線", 0.5, 0.2, 0.6, 17) CASE 5 !題名,中心X,中心Y,半幅,最大N !----- !f0(z)= 0*(z ) +EXP(i*PI/7)/SQR(3)*conj(z ) !f1(z)= 0*(z-1) + 2/3*conj(z-1) +1 !----- CALL Let02( a0,b0,o0, 0, EXP(COMPLEX(0,PI/7))/SQR(3), 0) CALL Let02( a1,b1,o1, 0, 2/3 , 1) !----- CALL mat02( m0, a0,b0,o0 ) CALL mat02( m1, a1,b1,o1 ) CALL Affine("葉脈曲線", 0.5, 0, 0.6, 14) CASE 6 !題名,中心X,中心Y,半幅,最大N !----- !f0(z)= (1+i)/2*(z ) + 0*conj(z ) !f1(z)= 0*(z-1) +(1-i)/2*conj(z-1) +1 !----- CALL Let02( a0,b0,o0, COMPLEX(1,1)/2, 0 , 0) CALL Let02( a1,b1,o1, 0 , conj(a0), 1) !----- CALL mat02( m0, a0,b0,o0 ) CALL mat02( m1, a1,b1,o1 ) CALL Affine("カニの行列", 0.35, 0.2, 0.8, 17) CASE 7 !題名,中心X,中心Y,半幅,最大N !----- !f0(z)= 0*(z ) +(1-EXP(-PI/5*i))*conj(z ) !f1(z)= 0*(z-1) +(1-EXP( PI/5*i))*conj(z-1) +1 !----- CALL Let02( a0,b0,o0, 0, 1-EXP(COMPLEX(0,-PI/5)), 0) CALL Let02( a1,b1,o1, 0, conj(b0) , 1) !----- CALL mat02( m0, a0,b0,o0 ) CALL mat02( m1, a1,b1,o1 ) CALL Affine("クリヌキ正五角形", 0.5, 0.25, 0.6, 15) CASE 8 !題名,中心X,中心Y,半幅,最大N !----- !f0(z)= (1+i)/2*(z ) + 0*conj(z ) !f1(z)= 0*(z-1) -(1+i)/2*conj(z-1) +1 !----- CALL Let02( a0,b0,o0, COMPLEX(1,1)/2, 0, 0) CALL Let02( a1,b1,o1, 0 , -a0, 1) !----- CALL mat02( m0, a0,b0,o0 ) CALL mat02( m1, a1,b1,o1 ) CALL Affine("ブロッコリー", 0.6, 0.4, 1.3, 17) CASE 9 !題名,中心X,中心Y,半幅,最大N !----- !f0(z)= (2+i)/4*(z ) +i/4*conj(z ) !f1(z)= (2-i)/4*(z-1) -i/4*conj(z-1) +1 !----- CALL Let02( a0,b0,o0, COMPLEX(2,1)/4, COMPLEX(0,1)/4, 0) CALL Let02( a1,b1,o1, conj(a0) , conj(b0) , 1) !----- CALL mat02( m0, a0,b0,o0 ) CALL mat02( m1, a1,b1,o1 ) CALL Affine("高木関数のグラフ", 0.5, 0.25, 0.6, 13) CASE 10 !題名,中心X,中心Y,半幅,最大N !----- a= 0.4614*(1+i) !f0(z)= a *(z ) +0*conj(z ) !f1(z)= 1/(1+a)*(z-1) +0*conj(z-1) +1 !----- CALL Let02( a0,b0,o0, 0.4614*COMPLEX(1,1), 0, 0) CALL Let02( a1,b1,o1, 1/(1+a0) , 0, 1) !----- CALL mat02( m0, a0,b0,o0 ) CALL mat02( m1, a1,b1,o1 ) CALL Affine("Extra-1　雲", 0.4, 0.2, 0.8, 15) CASE 11 !題名,中心X,中心Y,半幅,最大N !----- a= 0.4614*(1+i) !f0(z)= a*(z ) + 0*conj(z ) !f1(z)= 0*(z-1) +(1-a)/(1-conj(a)^2)*conj(z-1) +1 !----- CALL Let02( a0,b0,o0, 0.4614*COMPLEX(1,1), 0, 0) CALL Let02( a1,b1,o1, 0 , (1-a0)/(1-conj(a0)^2), 1) !----- CALL mat02( m0, a0,b0,o0 ) CALL mat02( m1, a1,b1,o1 ) CALL Affine("Extra-2　雷", 0.35, 0.2, 0.8, 15) CASE 12 !題名,中心X,中心Y,半幅,最大N !----- !f0(z)= exp(i*π/6)/√3*(z ) +0*conj(z ) !f1(z)= exp(i*π/6)/√3*(z-2) +0*conj(z-2) +2 !f2(z)= exp(i*π/6)/√3*(z-(1+i*√3)) +0*conj(z-(1+i*√3)) +(1+i*√3) !----- CALL Let02( a0,b0,o0, EXP(COMPLEX(0,PI/6))/SQR(3), 0, 0 ) CALL Let02( a1,b1,o1, a0, 0, 2 ) CALL Let02( a2,b2,o2, a0, 0, COMPLEX(1,SQR(3)) ) !----- CALL mat02( m0, a0,b0,o0 ) CALL mat02( m1, a1,b1,o1 ) CALL mat02( m2, a2,b2,o2 ) CALL Affine("Tragon トラゴン", .951, 0.45, 2, 11) CASE 13 !題名,中心X,中心Y,半幅,最大N !----- !f0(z)= 1/2*(z ) +0*conj(z ) !f1(z)= 1/2*(z-2) +0*conj(z-2) +2 !f2(z)= 1/2*(z-(1+i*√3)) +0*conj(z-(1+i*√3)) +(1+i*√3) !----- CALL Let02( a0,b0,o0, 1/2, 0, 0 ) CALL Let02( a1,b1,o1, a0, 0, 2 ) CALL Let02( a2,b2,o2, a0, 0, COMPLEX(1,SQR(3)) ) !----- CALL mat02( m0, a0,b0,o0 ) CALL mat02( m1, a1,b1,o1 ) CALL mat02( m2, a2,b2,o2 ) CALL Affine("シルピンスキーのガスケット", 1, 0.7, 1.5, 10) CASE ELSE !題名,中心X,中心Y,半幅,最大N LET item=9 !Start item after Demo.End CALL setN(2) !Start N after - - END SELECT LOOP !---------- SUB Affine(t$, xm, ym, h, N_max) !(題名, 中心X, 中心Y, 半幅, 最大N) DO LET Nmax=N_max ! SET DRAW mode hidden !----------------------- ! clear & restore key pannel !----------------------- CALL m.clear2 LET i=.2 LET j=.95 SET VIEWPORT 0,1, i,j SET WINDOW xm-h,xm+h, ym-h*(.5-i)/.5,ym+h*(j-.5)/.5 DRAW grid(.5,.5) ! !----------------------- ! adjust N at (Nmax, 3 分岐 in 2 分岐) !----------------------- IF o1=2 THEN LET N=N3 ELSE LET N=N2 IF Nmax< N THEN LET N=Nmax IF Nmax<=N THEN LET N$="　Nmax=" ELSE LET N$="　N=" ! !----------------------- ! title !----------------------- CALL m.BG_col(1, MOD(item,100)+2, 5) !item 表示色・ＯＮ CALL m.BG_col(2, N, 5) !N 表示色・ＯＮ CALL m.BG_col(3, algo-1, 5) !algo 表示色・ＯＮ PLOT TEXT,AT xm-h*0.9,ym+h*0.8:" BUSY." PLOT TEXT,AT xm-h*0.5,ym+h*0.8:t$& N$& STR$(N) ! !------------ ! 0 階の描点 !------------ IF item<>ibak THEN LET zo0=0 LET zr0=o1 LET zi0=o1*COMPLEX(0,.25) IF 4<=N THEN IF o1=2 THEN LET zi0=o2 ELSEIF MOD(item,100)=3 THEN LET zi0=COMPLEX(0.5,0.866) ELSEIF MOD(item,100)=8 THEN LET zi0=COMPLEX(0.5,0.5) ELSE LET zi0=COMPLEX(0.5,0.3) END IF END IF LET ibak=item END IF ! LET Ns=N !trace real LET Ne=N !trace end IF 4<=N THEN SET LINE COLOR 15 PLOT LINES: zo0; zr0; zi0; zo0 !０階の絵 ELSE LET Ns=MAX(0, Ne-3) !trace from previous N !------------------------- ! ０～３階の追跡 !------------------------- ! １階の transform axis SET TEXT font "",12*bms SET LINE COLOR "red" ! SET LINE STYLE 3 PLOT LINES: f0(o0-COMPLEX(0,.1)); f0(o0+COMPLEX(0,.5)) PLOT LINES: f1(o1-COMPLEX(0,.1)); f1(o1+COMPLEX(0,.5)) IF o1=2 THEN PLOT LINES: f2(o2-COMPLEX(0,.1)); f2(o2+COMPLEX(0,.5)) SET LINE STYLE 1 PLOT LINES: f0(o0-.1); f0(o0+.5) PLOT LINES: f1(o1-.1); f1(o1+.5) IF o1=2 THEN PLOT LINES: f2(o2-.1);f2(o2+.5) ! PLOT label,AT o1: "o1" IF o1=2 THEN PLOT label,AT o2: "o2" SET TEXT font "",18*bms END IF ! !SET VIEWPORT 0,1, 0,1 !この２行は、ver.7.5.4 まで削除できない。 !SET WINDOW xm-h,xm+h, ym-h,ym+h !　　〃　　　　　〃 ! SET DRAW mode explicit !----------------------- ! plot graph !----------------------- FOR N=Ns TO Ne !trace Ns~Ne LET no=1 LET r$="#" LET cx=0 !--- SELECT CASE algo CASE 1 CALL F23(N, zo0, zr0, zi0) !３点並列 N 階写像。 CASE 2 LET to0=f0(0) !０階での、第１分岐１階の原点vector LET ta0=f0(1)-to0 ! " " " の実軸単位vector LET tb0=f0(COMPLEX(0,1))-to0 ! " " " の虚軸単位vector LET to1=f1(0) !０階での、第２分岐１階の原点vector LET ta1=f1(1)-to1 ! " " " LET tb1=f1(COMPLEX(0,1))-to1 ! " " " LET to2=f2(0) ! " 第３分岐１階の原点vector LET ta2=f2(1)-to2 ! " " " LET tb2=f2(COMPLEX(0,1))-to2 ! " " " CALL F23x(N, 0, 1, COMPLEX(0,1)) !開始の原点vector 実軸単位vector 虚軸単位vector CASE 3 DRAW D23(N) CASE 4 MAT mc=IDN CALL dp23(N, mc) CASE 5 MAT mc=IDN CALL F23mx(N, mc) CASE ELSE END SELECT NEXT N IF Ne=Nmax THEN beep SET LINE COLOR "black" !restore line color to normal ! !--------------------Return with demo. IF 100< item THEN WAIT DELAY 0.5 LET item=item+1 EXIT DO END IF ! !--------------------Normal. PLOT TEXT,AT xm-h*0.9,ym+h*0.8:" Ready " DO mouse poll mx,my,mlb,mrb DO WHILE mlb=0 AND mrb=0 WAIT DELAY 0 mouse poll mx,my,mlb,mrb LET z=COMPLEX(mx,my) LET i$="" IF mrb=1 THEN EXIT DO IF ABS(z-zr0)<=1/20 AND ABS(z-zr0)<=ABS(z-zi0) AND ABS(z-zr0)<=ABS(z-zo0) THEN LET i$="a" IF ABS(z-zi0)<=1/20 AND ABS(z-zi0)<=ABS(z-zr0) AND ABS(z-zi0)<=ABS(z-zo0) THEN LET i$="b" IF ABS(z-zo0)<=1/20 AND ABS(z-zo0)<=ABS(z-zr0) AND ABS(z-zo0)<=ABS(z-zi0) THEN LET i$="o" LOOP LET z=COMPLEX(mx,my) IF i$="a" THEN LET zr0=z ELSEIF i$="b" THEN LET zi0=z ELSEIF i$="o" THEN LET zo0=z ELSE CALL m.keyin( ky, 6) !( Key_data, Click_Echo_back_color) IF mrb=1 THEN LET ky=100 SELECT CASE ky CASE 100 CALL m.BG_col(1, 0, 6) !END 表示色・ＯＮ beep STOP CASE 103 TO 115 !New item "1"～"13" LET item=MOD(ky,100)-2 !New item 更新 LET ibak=0 EXIT SUB CASE 101 CALL setN(-100) CASE 102 CALL setN(+100) CASE 200 TO 217 CALL setN( MOD(ky,100)) CASE 300 TO 304 LET algo=MOD(ky,100)+1 CASE ELSE END SELECT END IF LOOP UNTIL 0< ky OR i$<>"" LOOP END SUB SUB setN(s) IF o1=2 THEN IF 99< ABS(s) THEN LET s=Ne+SGN(s) LET N3=MIN( MAX( 0,s),17) IF 3< N3 THEN LET N2=MIN( ROUND( N3*LOG(3)/LOG(2)),17) ELSE LET N2=N3 ELSE IF 99< ABS(s) THEN LET s=Ne+SGN(s) LET N2=MIN( MAX( 0,s),17) IF 3< N2 THEN LET N3=ROUND( N2*LOG(2)/LOG(3)) ELSE LET N3=N2 END IF END SUB !-------------------------------------------------------------- !１）0 階絵(zo0,zr0,zi0)を、N 階写像した座標値(zo,zr,zi)で描く。 ! ! N 階重ねの行列で一括変形、(zo,zr,zi) は、直接描画。 !-------------------------------------------------------------- SUB dp23(k, t(,)) local w(4,4) IF 0< k THEN MAT w=t*m0 LET r$=r$& "1" CALL dp23(k-1, w) !各階の写像行列 MAT w=t*m1 LET r$=r$& "2" CALL dp23(k-1, w) !２分岐型はココまで IF o1=2 THEN MAT w=t*m2 LET r$=r$& "3" CALL dp23(k-1, w) !３分岐型はココまで END IF ELSE IF o1=2 THEN LET col=MOD(cx,3^3)+1 ELSE LET col=MOD(cx,2^5)+1 DRAW f012_n( zo0,zr0,zi0) WITH t !0 階絵を、行列 t で変形 LET cx=cx+1 !t は、N 階重ねの写像行列 (m0~m1)*(m0~m1)*... LET no=no+1 END IF LET r$=r$(1:LEN(r$)-1) END SUB !-------------------------------------------------------------------- !２）0 階座標系を、N 階変形させて、その中に、0 階の座標値で絵を描く。 ! !　　0 階の絵定義の座標値は、固定されたまま、 !　　それが使用している問題座標系の方を、軸方向や目盛について、行列で変形し、 !　　変形した問題座標系の中で、0 階の絵定義を、元の座標値のまま、描画する。 !　　以上を、多分岐、N 階に展開。それぞれの絵定義は、孤立した座標系。 !-------------------------------------------------------------------- PICTURE D23(k) IF 0< k THEN LET r$=r$& "1" DRAW D23(k-1) WITH m0 !各階の空間変形 LET r$=r$& "2" DRAW D23(k-1) WITH m1 !２分岐型はココまで IF o1=2 THEN LET r$=r$& "3" DRAW D23(k-1) WITH m2 !３分岐型はココまで END IF ELSE LET col=INT(cx)+1 DRAW f012_n( zo0,zr0,zi0) !0 階集合 IF o1=2 THEN LET cx=cx+3^(3-N) ELSE LET cx=cx+2^(5-N) LET no=no+1 END IF LET r$=r$(1:LEN(r$)-1) END PICTURE !------------------------------------------------------------------ !５）0 階座標系を、Ｎ階写像して、その中に、0 階の座標値で絵を描く。 ! !　　F23x(,,,) を行列形式に替えたもの。 !------------------------------------------------------------------ !※m_*u を逆にすると、dp23(,) に一致。　D23() draw picture with ～と同じ。 SUB F23mx(k, u(,)) local w(4,4) IF 0< k THEN LET r$=r$& "1" MAT w=m0*u CALL F23mx(k-1, w) !各階、次の空間 LET r$=r$& "2" MAT w=m1*u CALL F23mx(k-1, w) !２分岐型はココまで IF o1=2 THEN LET r$=r$& "3" MAT w=m2*u CALL F23mx(k-1, w) !３分岐型はココまで END IF ELSE LET col=INT(cx)+1 !u は、N 階座標系の、原点位置（と、各軸の単位ベクトル） DRAW f012_n( zo0,zr0,zi0) WITH u !N 階座標系の中に、0 階座標値の絵 IF o1=2 THEN LET cx=cx+3^(3-N) ELSE LET cx=cx+2^(5-N) LET no=no+1 END IF LET r$=r$(1:LEN(r$)-1) END SUB !Page-2 へ続く

√（ルート）のなかの数字

投稿者：LHS

投稿日：2011年 9月 2日(金)09時31分27秒

いつもお世話になっています。 SHARPのポケコンを使っていますが最近のものはDISKが使えず不便で十進BASICを見つけましたので使っています。 BCDですので計算精度がよく大変気にいっています。ところで √（ルート）のなかの数字の件ですが -2^(1/2)がエラーになることはわかりますが -2^(1/3)がエラーになることは解せません。 SHARPのPC-G850Sではエラーにならないです。 a^(1/3)のような式の場合aの正負の判別をしてそれによって計算を変えなくてはなりません。 if else end if を使わなくてはならず、手間で、面倒なのですが改善はしたほうがいいではないでしょうか？皆さんにご意見を伺ったらどうでしょうか？

Re: √（ルート）のなかの数字

投稿者：山中和義投稿日：2011年 9月 2日(金)11時30分36秒

> No.1659[元記事へ] LHSさんへのお返事です。 > √（ルート）のなかの数字の件ですが > > -2^(1/2)がエラーになることはわかりますが > -2^(1/3)がエラーになることは解せません。 > SHARPのPC-G850Sではエラーにならないです。次はFullBASICの仕様です。べき乗の評価・負数の非整数乗は、3002の続行不能の例外状態・ゼロの負数乗は、3003の続行不能の例外状態・0^0は1とする。・-A^Bは、-(A^B)と解釈する。・A^B^Cは、(A^B)^Cと解釈する。 PRINT (-2)^(1/3)という記述ができませんが、自前のべき乗関数、たとえばpower(x,p,q)、x^(p/q)をつくり　PRINT power(-2,1,3) 　END とすればよいと思います。

Re: √（ルート）のなかの数字

投稿者：白石和夫投稿日：2011年 9月 3日(土)08時31分35秒

> No.1659[元記事へ] a^bは2変数関数です。 bが有理数の場合だけ定義すればよいものとすれば，bを既約分数で表して分母が奇数の場合だけaが負数であることを許す定義も可能ですが，そこから展開される数学は奇怪なものとなります。 bを実数の範囲にまで拡張しようと考えると，a^b=exp(b*log(a))で定義するのが自然ですが，aが負数のときのlog(a)は虚数で，多値となり，BASICの組込関数として用意しようとする場合にはどれを関数値として定めるべきか悩みます。十進BASICの複素数モードで次のプログラムの10行に示すようなpower関数を定義してみると，おそらくお望みの答えとは違う値が得られると思います。 10 OPTION ARITHMETIC complex 20 DEF power(a,b)=EXP(b*LOG(a)) 30 PRINT power(2,5) 40 PRINT power(-2,5) 50 PRINT power(8,1/3) 60 PRINT power(-8,1/3) 70 END 2変数関数のa^bでなく，1変数関数の立方根関数がほしいのであれば，近似値でよければ， 10 DEF CubRoot(x)=SGN(x)*ABS(x)^(1/3) 20 PRINT CubRoot(8),CubRoot(-8) 30 PRINT CubRoot(27),CubRoot(-27) 40 END で求められます。（誤差が生じる理由は，以下を参照）　http://hp.vector.co.jp/authors/VA008683/QA_cubic_root.htm 正確な値を求めたいのであれば，ニュートン法を利用して立方根関数を定義してください。

Re: √（ルート）のなかの数字

投稿者：白石和夫投稿日：2011年 9月 4日(日)11時27分30秒

> No.1661[元記事へ] 補足です。 BASICのa^bの評価において，bを既約分数で表して分母が奇数の場合にaが負数であることを許すように拡張することは可能ですが，非現実的です。なぜかというと，すべての数値を2進浮動小数点数として扱う場合には，分数の計算結果を既約分数に表すと分母は必ず偶数になります。。十進BASICのように数値を10進浮動小数点数で表す場合でも，1/3の計算結果を有限桁で近似した結果を既約分数に直すと，分母は10の倍数になるので偶数です。だから，実際に意味を持つのは，指数が1/5とか1/25，1/125のような場合のみです。ただし，十進BASICには有理数モードがありますが，有理数のみを扱う場合には，結果が有理数になる場合にはべき指数に分数を許すようにすることも理論的には可能です。その意味で，SHARPのPC-G850Sはどういう計算をしているのか興味があります。^(1/3)と書くと3乗根の計算を行うような構文解析を行っているのでしょうか。もしそうだとすると， 10 LET A=-2 20 LET B=1/3 30 PRINT A^B 40 END と 10 LET A=-2 30 PRINT A^(1/3) 40 END とで実行結果が異なるはずです。あるいは，有理数演算を行っているのでしょうか。まさか，3進小数ではないと思いますが。

再帰呼出しでの不具合

投稿者：山中和義投稿日：2011年 9月18日(日)16時53分11秒

十進モードでは、不正な値（答え）になる。 1000桁モードでは、INT関数が桁あふれする。 !多項式に対する拡張ユークリッド互除法 !多項式f(x)=A[m]x^m+ … +A[1]x+A[0]、g(x)=B[n]x^n+ … +B[1]x+B[0]、m≧nとして、 !f(x)S(x)+g(x)T(x)=gcd(f(x),g(x))=C(x)となるS(x),T(x),C(x)を求める。 PUBLIC NUMERIC MAX_DEGREE !次数　※m^2以上 LET MAX_DEGREE=10 !------------------------------ DATA 3 !次数 DATA 1,0,-3,1 !g(x)=x^3-3x+1 DATA 3 DATA 1,1,0,6 !f(x)=x^3+x^2+6 READ M !次数 DIM A(0 TO M) !係数 FOR i=M TO 0 STEP -1 !f(x)=A[m]x^m+ … +A[1]x+A[0] READ A(i) NEXT i READ N !次数 DIM B(0 TO N) !係数 FOR i=N TO 0 STEP -1 !g(x)=B[n]x^n+ … +B[1]x+B[0] READ B(i) NEXT i DIM P(0 TO MAX_DEGREE),Q(0 TO MAX_DEGREE),C(0 TO MAX_DEGREE) MAT P=ZER MAT Q=ZER MAT C=ZER CALL ExGCD(M,A,N,B, pp,P,qq,Q,cc,C) !拡張ユークリッド互除法 MAT PRINT P; !結果を表示する MAT PRINT Q; MAT PRINT C; END !拡張ユークリッド互除法 !　f(x)=A[m]x^m+ … +A[1]x+A[0]、g(x)=B[n]x^n+ … +B[1]x+B[0]、m≧nとして、 !　f(x)S(x)+g(x)T(x)=gcd(f(x),g(x))=C(x)となるS(x),T(x),C(x)を求める。 EXTERNAL SUB ExGCD(aa,A(),bb,B(), ss,S(),tt,T(),cc,C()) !拡張ユークリッド互除法 IF bb=0 AND B(0)=0 THEN !IF b=0 THEN LET S(0)=1 !s=1　※f(x)*1+0*0=f(x)とする LET ss=0 LET T(0)=0 !t=0 LET tt=0 MAT C=A !c=a LET cc=aa ELSE DIM Q(0 TO MAX_DEGREE),R(0 TO MAX_DEGREE) IF aa=0 AND bb=0 THEN !定数項のみ LET Q(0)=INT(A(0)/B(0)) LET qq=0 LET R(0)=MOD(A(0),B(0)) LET rr=0 ELSE CALL poly_div(aa,A,bb,B, qq,Q,rr,R) !q=INT(a/b), r=MOD(a,b) END IF CALL ExGCD(bb,B,rr,R, tt,T,ss,S,cc,C) !k=n-1,…,3,2 まで続ける DIM W(0 TO MAX_DEGREE) CALL poly_mul(ss,S,qq,Q, ww,W) ! t=u-v*q MAT T=T-W LET tt=ww END IF END SUB !補助ルーチン !演算関連 EXTERNAL SUB poly_mul(aa,A(),bb,B(), ss,S()) !乗算 S=A*B　※S≠A、S≠B FOR i=aa TO 0 STEP -1 FOR j=bb TO 0 STEP -1 LET S(i+j)=S(i+j)+A(i)*B(j) !すべての係数をかける NEXT j NEXT i LET ss=aa+bb !次数 END SUB EXTERNAL SUB poly_div(aa,A(),bb,B(), qq,Q(),rr,R()) !除算　※被除数=商*除数+余り IF bb=0 AND B(0)=0 THEN !0なら PRINT "0で割ることはできません。" STOP ELSE MAT Q=ZER !商 MAT R=ZER !余り MAT R=A FOR t=aa TO bb STEP -1 !被除数の次数が除数のより大きいなら IF R(t)<>0 THEN !係数が０以外なら LET k=R(t)/B(bb) !商の係数、その次数 LET w=t-bb LET Q(w)=k !商 FOR i=bb TO 0 STEP -1 !余り　※R=A-k*B LET R(w+i)=R(w+i)-k*B(i) NEXT i END IF NEXT t LET qq=MAX(aa-bb,0) !次数 IF aa>=bb THEN LET rr=MAX(bb-1,0) ELSE LET rr=aa END IF END SUB

Re: 再帰呼出しでの不具合

投稿者：白石和夫投稿日：2011年 9月18日(日)17時56分27秒

> No.1663[元記事へ] 2005行と2065行を追加しました。有理数モードで正しい答えになるようであれば，2000行と2050行の計算誤差が原因ではないでしょうか。 1000 !多項式に対する拡張ユークリッド互除法 1010 1020 !多項式f(x)=A[m]x^m+ … +A[1]x+A[0]、g(x)=B[n]x^n+ … +B[1]x+B[0]、m≧nとして、 1030 !f(x)S(x)+g(x)T(x)=gcd(f(x),g(x))=C(x)となるS(x),T(x),C(x)を求める。 1040 1050 PUBLIC NUMERIC MAX_DEGREE !次数　※m^2以上 1060 LET MAX_DEGREE=10 1070 !------------------------------ 1080 1090 1100 DATA 3 !次数 1110 DATA 1,0,-3,1 !g(x)=x^3-3x+1 1120 DATA 3 1130 DATA 1,1,0,6 !f(x)=x^3+x^2+6 1140 1150 1160 READ M !次数 1170 DIM A(0 TO M) !係数 1180 FOR i=M TO 0 STEP -1 !f(x)=A[m]x^m+ … +A[1]x+A[0] 1190 READ A(i) 1200 NEXT i 1210 1220 READ N !次数 1230 DIM B(0 TO N) !係数 1240 FOR i=N TO 0 STEP -1 !g(x)=B[n]x^n+ … +B[1]x+B[0] 1250 READ B(i) 1260 NEXT i 1270 1280 1290 DIM P(0 TO MAX_DEGREE),Q(0 TO MAX_DEGREE),C(0 TO MAX_DEGREE) 1300 MAT P=ZER 1310 MAT Q=ZER 1320 MAT C=ZER 1330 CALL ExGCD(M,A,N,B, pp,P,qq,Q,cc,C) !拡張ユークリッド互除法 1340 1350 1360 MAT PRINT P; !結果を表示する 1370 MAT PRINT Q; 1380 MAT PRINT C; 1390 1400 END 1410 1420 1430 !拡張ユークリッド互除法 1440 !　f(x)=A[m]x^m+ … +A[1]x+A[0]、g(x)=B[n]x^n+ … +B[1]x+B[0]、m≧nとして、 1450 !　f(x)S(x)+g(x)T(x)=gcd(f(x),g(x))=C(x)となるS(x),T(x),C(x)を求める。 1460 1470 EXTERNAL SUB ExGCD(aa,A(),bb,B(), ss,S(),tt,T(),cc,C()) !拡張ユークリッド互除法 1480 IF bb=0 AND B(0)=0 THEN !IF b=0 THEN 1490 LET S(0)=1 !s=1　※f(x)*1+0*0=f(x)とする 1500 LET ss=0 1510 LET T(0)=0 !t=0 1520 LET tt=0 1530 MAT C=A !c=a 1540 LET cc=aa 1550 ELSE 1560 DIM Q(0 TO MAX_DEGREE),R(0 TO MAX_DEGREE) 1570 IF aa=0 AND bb=0 THEN !定数項のみ 1580 LET Q(0)=INT(A(0)/B(0)) 1590 LET qq=0 1600 LET R(0)=MOD(A(0),B(0)) 1610 LET rr=0 1620 ELSE 1630 CALL poly_div(aa,A,bb,B, qq,Q,rr,R) !q=INT(a/b), r=MOD(a,b) 1640 END IF 1650 1660 CALL ExGCD(bb,B,rr,R, tt,T,ss,S,cc,C) !k=n-1,…,3,2 まで続ける 1670 1680 DIM W(0 TO MAX_DEGREE) 1690 CALL poly_mul(ss,S,qq,Q, ww,W) ! t=u-v*q 1700 MAT T=T-W 1710 LET tt=ww 1720 END IF 1730 END SUB 1740 1750 1760 !補助ルーチン 1770 1780 !演算関連 1790 1800 EXTERNAL SUB poly_mul(aa,A(),bb,B(), ss,S()) !乗算 S=A*B　※S≠A、S≠B 1810 FOR i=aa TO 0 STEP -1 1820 FOR j=bb TO 0 STEP -1 1830 LET S(i+j)=S(i+j)+A(i)*B(j) !すべての係数をかける 1840 NEXT j 1850 NEXT i 1860 LET ss=aa+bb !次数 1870 END SUB 1880 1890 1900 EXTERNAL SUB poly_div(aa,A(),bb,B(), qq,Q(),rr,R()) !除算　※被除数=商*除数+余り 1910 IF bb=0 AND B(0)=0 THEN !0なら 1920 PRINT "0で割ることはできません。" 1930 STOP 1940 ELSE 1950 MAT Q=ZER !商 1960 MAT R=ZER !余り 1970 MAT R=A 1980 FOR t=aa TO bb STEP -1 !被除数の次数が除数のより大きいなら 1990 IF R(t)<>0 THEN !係数が０以外なら 2000 LET k=R(t)/B(bb) !商の係数、その次数 2005 PRINT k 2010 LET w=t-bb 2020 LET Q(w)=k !商 2030 2040 FOR i=bb TO 0 STEP -1 !余り　※R=A-k*B 2050 LET R(w+i)=R(w+i)-k*B(i) 2060 NEXT i 2065 MAT PRINT R 2070 END IF 2080 NEXT t 2090 LET qq=MAX(aa-bb,0) !次数 2100 IF aa>=bb THEN LET rr=MAX(bb-1,0) ELSE LET rr=aa 2110 END IF 2120 END SUB

Re: 再帰呼出しでの不具合

投稿者：山中和義投稿日：2011年 9月18日(日)19時28分52秒

> No.1664[元記事へ] 白石和夫さんへのお返事です。 > 2005行と2065行を追加しました。 > 有理数モードで正しい答えになるようであれば，2000行と2050行の計算誤差が原因ではないでしょうか。 > 1480 IF bb=0 AND B(0)=0 THEN !IF b=0 THEN 1480 IF bb=0 AND ABS(B(0))<=1E-13 THEN !IF b=0 THEN として対応します。通常の整数の場合は、INT関数で０になるのでよいのですが、多項式の場合は、「これに相当する処理がないため、有理数モードでの実行が前提となる」ということですね。お騒がせしました。

Re: 時計のプログラミング

投稿者：きのっぴー投稿日：2011年 9月22日(木)16時39分12秒

> No.186[元記事へ] 出来ました！ありがとうございます

64bitでの動作

投稿者：くぼのん投稿日：2011年 9月23日(金)11時35分7秒

　こんにちは、はじめまして。初歩的な質問で恐縮ですが、今、Win7 XPモードでインストールを行ったところですが、十進BASICは、Win7 64bit版では、動作はどうなるのでしょうか。よろしくお願いします。

Re: 64bitでの動作

投稿者：白石和夫投稿日：2011年 9月23日(金)17時19分8秒

> No.1667[元記事へ] 十進BASICは32ビットアプリケーションですが，Win7 64bit版上で問題なく動作します。

Re: 64bitでの動作

投稿者：くぼのん投稿日：2011年 9月23日(金)20時45分49秒

> No.1668[元記事へ] 白石和夫さんへのお返事です。 > 十進BASICは32ビットアプリケーションですが，Win7 64bit版上で問題なく動作します。こんばんは、くぼのんです。ご回答、ありがとうございました。ささやかながら、十進BASICで、自分の数学の世界を広げたり、深めたりしたいと思います。

モノトーン・クロック

投稿者：SECOND 投稿日：2011年 9月24日(土)06時49分13秒

! デジアナ時計755　(Ver.7.5.5 以降で動きます。) !------------------- ASK bitmap SIZE i,j SET TEXT font "ＭＳゴシック",MIN(i,j)*18/500 SET TEXT JUSTIFY "center","half" SET WINDOW -250,250,-250,250 LET ds=3 !20W at1, 21W at3, 24W at6 !秒針の刻み数／秒、大きい程、消費電力増大 LET sc=2 !時計の大きさ LOCATE VALUE NOWAIT ,AT .4: Bt !文字盤明るさ、初期値(Ver.7.5.5 以降) DRAW disk WITH SCALE(82*sc) !枠 DO LET t=INT(TIME*ds)/ds IF t0<>t THEN LET t0=t LOCATE VALUE NOWAIT ,RANGE .2 TO .6: Bt !文字盤明るさ、調整(Ver.7.5.5 以降) SET COLOR MIX(1) Bt,Bt,Bt SET DRAW mode hidden DRAW disk WITH SCALE(75*sc) !文字盤台（clear 兼） SET COLOR MIX(1) 1,1,1 DRAW logo WITH SCALE(sc/2) !ロゴ Mark DRAW A_Clock WITH SCALE(sc) !時計 SET DRAW mode explicit END IF WAIT DELAY 0 !省電力効果 MOUSE POLL mx,my,mlb,mrb LOOP UNTIL mrb>=1 !右クリックで停止 !------ PICTURE A_Clock FOR i=1 TO 12 LET a=-PI/6*(i-3) PLOT letters,AT 58*COS(a)+.8, 58*SIN(a) :STR$(i) !数字(Ver.7.4.0 以降) NEXT i !---　00:00 からｔ秒の針回転 Gear DRAW hand WITH SCALE(2.5, 0.73)*ROTATE(-t*PI/21600) !時針 DRAW hand WITH ROTATE(-t*PI/1800) !分針 DRAW hand WITH SCALE(0, 1.1)*ROTATE(-t*PI/30) !秒針 DRAW hand WITH SCALE(0.8,0.2)*SHIFT(0,-20)*ROTATE(-t*PI/30) !秒針バランス・ウェイト !--- FOR i=0 TO 59 LET a=PI/30*i DRAW disk WITH SCALE(1-.5*SGN(MOD(i,5)))*SHIFT(72*COS(a),72*SIN(a)) !時分目盛り NEXT i END PICTURE PICTURE hand PLOT AREA: -1,-15; 1,-15; 1,62; -1,62 !３針共用、０時位置の針 END PICTURE PICTURE logo PLOT letters,AT 5,20:"DecimalBasic" PLOT letters,AT 3,-50,USING"%%:%%:%%":IP(t/3600),MOD(IP(t/60),60),MOD(IP(t),60) END PICTURE END !デジタル時刻不要な場合、最後の１行↑(PLOT letters …) を削除。

作図サブルーチン集（図形と方程式）

投稿者：山中和義投稿日：2011年10月12日(水)10時49分40秒

図形と方程式の問題をプログラミングで解法するための作図ツールです。連立方程式や２次方程式を解くのが一般ですが、極力避けた別解をコード化しています。 !図形と方程式 SET WINDOW -8,8,-8,8 !表示領域を設定する　※ DRAW grid !XY座標 PUBLIC NUMERIC cEps !精度　※調整が必要である LET cEPS=1E-8 PUBLIC NUMERIC gcCOLOR,gcSTYLE,gcLINESTYLE !描画色、線種 LET gcCOLOR=1 LET gcLINESTYLE=1 !------------------------------ ここまでがサブルーチン !●円(x+1)^2+y^2=5に、円周上の点(-3,-1)での接線の方程式を求めよ。 LET A=2 !円 LET B=0 LET C=-4 CALL gcDRAWCIRCLE(A,B,C,"",0) !円を描く LET px=-3 !点(-3,-1) LET py=-1 CALL gcDRAWPOINT(px,py,"") !点を描く CALL gcTANGENTLINE1C(px,py,A,B,C, L,M,N) CALL gcDRAWLINE(L,M,N,"",0) !接線を描く END !各処理の階層構造 !基本ルーチン !点 !　作図 gcDRAWPOINT !　中点 gcCENTER !　内分・外分する点 gcDIVIDE !　直線と直線 gcINTERSECTION !直線 !　作図 gcDRAWLINE !　2点を通る gcLINE !　1点を通り、直線に平行 gcLINEP !　1点を通り、直線に垂直 gcLINEX !　直線を一定間隔だけ平行移動させる gcPARALLELLINE !　2直線のなす角を二等分する線 gcA2LINE !　円上の点における接線 gcTANGENTLINE1C !円 !　作図 gcDRAWCIRCLE !　中心と半径 gcCIRCLE !　2点を結ぶ線分を直径とする gcCIRCLE2R !その他 !　2点間の距離 DIST !　点と直線との距離 DIST1L !　2次方程式ax^2+bx+c=0を解く Solve2Equ !下位ルーチン !点 !　1点から直線への垂線の足 gcFOOTofPERPENDICULAR !　1点から2点を通る直線への垂線の足 gcFOOTofPERPENDICULAR2 !交点 !　直線と円 gcINTERSECTION1C !直線 !　1点を通り、2点を通る直線に平行 * gcLINEP2 !　1点を通り、2点を通る直線に垂直 * gcLINEX2 !　1点から2点を結ぶ線分の中点を通る（中線） gcD2LINE !　2点を結ぶ線分の垂直二等分線 gcP2LINE !円 !　2点と半径 gcCIRCLE2 !　3点を通る（3点を頂点とする三角形の外接円） gcCIRCLE3 !中位ルーチン !交点 !　円と円 gcINTERSECTION2C !上位ルーチン !直線 !　円外の点からの接線 gcTANGENTLINE !最上位ルーチン !直線 !　2円の共通接線、接点 gcTANGENTLINE2C !作図ツール（Geometric Constructor） !図形と方程式 !　点 (x,y) !　直線 Lx+My+N=0 !　円 x^2+y^2+Ax+By+C=0 ! !　角度の単位は度、反時計まわりが正とする。 !作図ルーチン EXTERNAL SUB gcDRAWPOINT(x,y,s$) !点(x,y)を描く SET AREA COLOR gcCOLOR DRAW disk WITH SCALE(0.1)*SHIFT(x,y) !※拡大率0.1は調整が必要である IF s$<>"" THEN PLOT TEXT ,AT x,y: s$ END SUB EXTERNAL SUB gcDRAWLINE(L,M,N,s$,o) !直線Lx+My+N=0を描く ASK WINDOW x1,x2,y1,y2 IF (L=0 AND M=0) THEN PRINT "L=M=0なので、直線が成立しません。"; L;M;N ELSEIF M=0 THEN !y軸に平行な直線 SET LINE COLOR gcCOLOR SET LINE STYLE gcLINESTYLE PLOT LINES: -N/L,y1; -N/L,y2 IF s$<>"" THEN PLOT TEXT ,AT -N/L,0: s$ !x切片 ELSE SET LINE COLOR gcCOLOR SET LINE STYLE gcLINESTYLE PLOT LINES: x1,-(L*x1+N)/M; x2,-(L*x2+N)/M IF s$<>"" THEN !注釈 IF L=0 THEN !x軸に平行なら LET x=0 !y切片 LET y=-N/M ELSE !x軸とy軸の両方と交差するなら（いわゆる斜めの直線） SELECT CASE o !記入位置 CASE 0 !y切片 LET x=0 LET y=-N/M CASE 1 !x切片 LET x=-N/L LET y=0 CASE 2 !x切片とy切片との中点 LET x=-N/L*0.5 LET y=-N/M*0.5 CASE ELSE END SELECT END IF PLOT TEXT ,AT x,y: s$ END IF END IF END SUB EXTERNAL SUB gcDRAWCIRCLE(A,B,C,s$,o) !円x^2+y^2+Ax+By+C=0を描く LET RR=(A^2+B^2)/4-C !判別式 IF RR>=0 THEN SET LINE COLOR gcCOLOR SET LINE STYLE gcLINESTYLE LET CX=-A/2 !中心 LET CY=-B/2 LET R=SQR(RR) !半径 FOR i=0 TO 360 !(x-CX)^2+(y-CY)^2=R^2として描く PLOT LINES: R*COS(RAD(i))+CX,R*SIN(RAD(i))+CY; NEXT i PLOT LINES IF s$<>"" THEN !注釈 SELECT CASE o !記入位置 CASE 0 !右 LET x=CX+R LET y=CY CASE 1 !上 LET x=CX LET y=CY+R CASE 2 !右上 LET x=R*SQR(2)/2+CX !45度 LET y=R*SQR(2)/2+CY CASE ELSE END SELECT PLOT TEXT ,AT x,y: s$ END IF ELSE PRINT "半径が負なので、円が成立しません。"; A;B;C END IF END SUB !補助ルーチン EXTERNAL FUNCTION DIST(x1,y1,x2,y2) !2点(x1,y1),(x2,y2)間の距離 LET DIST=SQR((x1-x2)^2+(y1-y2)^2) END FUNCTION !点(x,y)と直線Lx+My+N=0との距離（点から直線へ下した垂線の長さ） EXTERNAL FUNCTION DIST1L(x,y,L,M,N) LET DIST1L=ABS(L*x+M*y+N)/SQR(L^2+M^2) END FUNCTION EXTERNAL SUB Solve2Equ(a,b,c, x1,x2,K) !2次方程式ax^2+bx+c=0を解く IF a=0 THEN PRINT "2次の係数が0なので、2次方程式ではありません。"; a;b;c LET K=0 ELSE LET D=b^2-4*a*c !判別式 IF D>=0 THEN !実数解なら LET x1=(-b+SQR(D))/(2*a) !1つの解 IF D=0 THEN !重解なら LET K=1 ELSE LET x2=(-b-SQR(D))/(2*a) !もう1つの解 LET K=2 END IF ELSE !虚数解なら LET K=0 END IF END IF END SUB !演算ルーチン !●点 EXTERNAL SUB gcCENTER(x1,y1,x2,y2, xx,yy) !点A(x1,y1),B(x2,y2)を結ぶ線分ABの中点 LET xx=(x1+x2)/2 LET yy=(y1+y2)/2 END SUB !点A(x1,y1),B(x2,y2)を結ぶ線分ABをm:nに分ける点（内分・外分する点） EXTERNAL SUB gcDIVIDE(x1,y1,x2,y2,m,n, xx,yy) LET xx=(n*x1+m*x2)/(m+n) !※外分m:nは、m:(-n)となる LET yy=(n*y1+m*y2)/(m+n) END SUB !直線Lx+My+N=0と直線Px+Qy+R=0との交点 !　平行でない、すなわち !　| L M |≠0 なら、交点がある。 !　| P Q | EXTERNAL SUB gcINTERSECTION(L,M,N,P,Q,R, xx,yy,K) LET D=L*Q-M*P !判別式 IF D=0 THEN PRINT "2直線は平行です。"; L;M;N; P;Q;R LET K=0 ELSE LET xx=(M*R-Q*N)/D LET yy=(P*N-L*R)/D LET K=1 END IF END SUB !点(x1,y1)から直線Lx+My+N=0への垂線の足H EXTERNAL SUB gcFOOTofPERPENDICULAR(x1,y1,L,M,N, xx,yy) CALL gcLINEX(x1,y1,L,M,N, P,Q,R) !点を通り、直線と垂直な直線 CALL gcINTERSECTION(L,M,N,P,Q,R, xx,yy,K) !交点 END SUB !点A(x1,y1)から点B(x2,y2),C(x3,y3)を通る直線BCへの垂線の足H EXTERNAL SUB gcFOOTofPERPENDICULAR2(x1,y1,x2,y2,x3,y3, xx,yy) IF (x2=x3 AND y2=y3) THEN PRINT "2点は同一点なので、直線が成立しません。"; x1;y1;x2;y2;x3;y3 ELSE CALL gcLINE(x2,y2,x3,y3, L,M,N) !直線BC CALL gcLINEX(x1,y1,L,M,N, P,Q,R) !点Aを通り、直線BCと垂直な直線 CALL gcINTERSECTION(L,M,N,P,Q,R, xx,yy,K) !交点 END IF END SUB !直線Lx+My+N=0と円x^2+y^2+Ax+By+C=0との交点 !　M≠0のとき !　　y=-(Lx+N)/Mを代入して、x^2 +{-(Lx+N)/M}^2 +Ax +B{-(Lx+N)/M} +C = 0 !　　{L^2+M^2}x^2 +{L(2N-BM)+AM^2}x +{N^2-BMN+CM^2} = 0 !　　xについての2次方程式を解く。 !　M=0のとき（y軸に平行な直線） !　　x=-N/Lより、(-N/L)^2+y^2+A(-N/L)+By+C=0 !　　yについての2次方程式を解く。 EXTERNAL SUB gcINTERSECTION1C(L,M,N,A,B,C, x1,y1,x2,y2,K) IF M=0 THEN !y軸に平行な直線 LET aa=1 LET bb=B LET cc=(-N/L)^2+A*(-N/L)+C CALL Solve2Equ(aa,bb,cc, y1,y2,K) IF K>0 THEN LET x1=-N/L !1点目 IF K=2 THEN LET x2=-N/L !2点目 ELSE PRINT "交点なし" END IF ELSE LET aa=L^2+M^2 LET bb=L*(2*N-B*M)+A*M^2 LET cc=N^2-B*M*N+C*M^2 CALL Solve2Equ(aa,bb,cc, x1,x2,K) IF K>0 THEN LET y1=-(L*x1+N)/M !1点目 IF K=2 THEN LET y2=-(L*x2+N)/M !2点目 ELSE PRINT "交点なし" END IF END IF END SUB !円x^2+y^2+A1x+B1y+C1=0と円x^2+y^2+A2x+B2y+C2=0との交点 !　2円の交点を通る曲線は、(x^2+y^2+A1x+B1y+C1)+k(x^2+y^2+A2x+B2y+C2)=0より、 !　k=-1として、極線は(A1-A2)x+(B1-B2)y+(C1-C2)=0 !　交点は、極線と円1との交点で求まる。 EXTERNAL SUB gcINTERSECTION2C(A1,B1,C1,A2,B2,C2, x1,y1,x2,y2,K) CALL gcINTERSECTION1C(A1-A2,B1-B2,C1-C2,A1,B1,C1, x1,y1,x2,y2,K) END SUB !円外の点(Px,Py)から円x^2+y^2+Ax+By+C=0への接点 !　点(Px,Py)と元の円の中心点を直径とする円 !　(x-Px)(x+A/2)+(y-Py)(y+B/2)=0　∴x^2+y^2+{A/2-Px}x+{B/2-Py}y+{Px(A/2)+Py(B/2)}=0 !　この円と元の円との交点が接点となる。 EXTERNAL SUB gcTANGENTLINE(Px,Py,A,B,C, x1,y1,x2,y2,K) LET D=Px^2+Py^2+A*Px+B*Py+C !判別式 IF D<-cEPS THEN PRINT "点は円内です。"; Px;Py;A;B;C LET K=0 ELSEIF D>cEPS THEN !円外なら CALL gcCIRCLE2R(Px,Py,-A/2,-B/2, S,T,U) CALL gcINTERSECTION2C(S,T,U,A,B,C, x1,y1,x2,y2,K) ELSE !円周上なら LET x1=Px LET y1=Py LET K=1 END IF END SUB 続く

Re: 作図サブルーチン集（図形と方程式）

投稿者：山中和義投稿日：2011年10月12日(水)10時51分52秒

続き !●直線 !2点(x1,y1), (x2,y2)を通る直線Lx+My+N=0 !公式　-(y2-y1)(x-x1)+(x2-x1)(y-y1)=0 より EXTERNAL SUB gcLINE(x1,y1,x2,y2, L,M,N) IF (x1=x2 AND y1=y2) THEN !同一点なら PRINT "異なる2点ではないので、直線が成立しません。"; x1;y1;x2;y2 ELSE LET L=y1-y2 LET M=x2-x1 LET N=x1*y2-y1*x2 END IF END SUB !点(x1,y1)と通り、直線Ax+By+C=0に平行な直線 !公式　直線BCがLx+My+N=0のとき、L(x-x1)+M(y-y1)=0 EXTERNAL SUB gcLINEP(x1,y1,L,M,N, A,B,C) LET A=L LET B=M LET C=-L*x1-M*y1 END SUB !点(x1,y1)と通り、2点(x2,y2), (x3,y3)を通る直線に平行な直線 !公式　直線BCがLx+My+N=0のとき、L(x-x1)+M(y-y1)=0 EXTERNAL SUB gcLINEP2(x1,y1,x2,y2,x3,y3, L,M,N) IF (x2=x3 AND y2=y3) THEN PRINT "2点は同一点なので、直線が成立しません。"; x1;y1;x2;y2;x3;y3 ELSE CALL gcLINE(x2,y2,x3,y3, L,M,N) LET N=-L*x1-M*y1 END IF END SUB !点(x1,y1)と通り、直線Ax+By+C=0に垂直な直線 !公式　直線BCがLx+My+N=0のとき、L(y-y1)=M(x-x1) EXTERNAL SUB gcLINEX(x1,y1,L,M,N, A,B,C) LET A=-M LET B=L LET C=-L*y1+M*x1 END SUB !点(x1,y1)と通り、2点(x2,y2), (x3,y3)を通る直線に垂直な直線 !公式　直線BCがLx+My+N=0のとき、L(y-y1)=M(x-x1) EXTERNAL SUB gcLINEX2(x1,y1,x2,y2,x3,y3, L,M,N) IF (x2=x3 AND y2=y3) THEN PRINT "2点は同一点なので、直線が成立しません。"; x1;y1;x2;y2;x3;y3 ELSE CALL gcLINE(x2,y2,x3,y3, S,T,U) LET L=-T LET M=S LET N=-S*y1+T*x1 END IF END SUB !点A(x1,y1)から点B(x2,y2), C(x3,y3)を結ぶ線分BCの中点を通る直線（中線） EXTERNAL SUB gcD2LINE(x1,y1,x2,y2,x3,y3, L,M,N) IF (x1=x2 AND y1=y2) OR (x1=x3 AND y1=y3) THEN PRINT "2点は同一点なので、線分が成立しません。"; x1;y1;x2;y2;x3;y3 ELSE CALL gcLINE(x1,y1,(x2+x3)/2,(y2+y3)/2, L,M,N) END IF END SUB !点A(x1,y1), B(x2,y2)を結ぶ線分ABの垂直二等分線 EXTERNAL SUB gcP2LINE(x1,y1,x2,y2, L,M,N) IF (x1=x2 AND y1=y2) THEN PRINT "2点は同一点なので、線分が成立しません。"; x1;y1;x2;y2 ELSE CALL gcLINE(x1,y1,x2,y2, A,B,C) !直線AB CALL gcLINEX((x1+x2)/2,(y1+y2)/2,A,B,C, L,M,N) !中点を通り直線ABに垂直 END IF END SUB !直線Ax+By+C=0を一定間隔p（平行線の間隔）だけ平行移動させる !　長さで三角形A,B,√(A^2+B^2)と三角形x,y,pを考える。 !　x方向　√(A^2+B^2) : A = p : x より、x=Ap/√(A^2+B^2) !　y方向　√(A^2+B^2) : B = p : y より、y=Bp/√(A^2+B^2) !　よって、(x,y)を移動量とする平行移動された直線は、A(X-x)+B(Y-y)+C=0 EXTERNAL SUB gcPARALLELLINE(A,B,C,p, L,M,N,dx,dy) LET t=SQR(A^2+B^2) LET L=A LET M=B LET N=C-t*p LET dx=-A*p/t !x軸,y軸成分 LET dy=-B*p/t END SUB !2直線Lx+My+N=0、Px+Qy+R=0のなす角を二等分する線 !　求める直線上の点を(x,y)とする。 !　この点から2直線への距離は等しいので、|Lx+My+N|/√(L^2+M^2)=|Px+Qy+R|/√(P^2+Q^2) !　∴√(P^2+Q^2)(Lx+My+N)=±√(L^2+M^2)(Px+Qy+R) EXTERNAL SUB gcA2LINE(L,M,N,P,Q,R, A,B,C, D,E,F, K) LET s=SQR(P^2+Q^2) LET t=SQR(L^2+M^2) LET A=s*L+t*P !1つ目 LET B=s*M+t*Q LET C=s*N+t*R LET K=1 IF L*Q-M*P<>0 THEN !2直線が交わるなら LET D=s*L-t*P !2つ目 LET E=s*M-t*Q LET F=s*N-t*R LET K=2 END IF END SUB !円x^2+y^2+Ax+By+C=0上の円周上の点(x0,y0)における接線 !公式　円(x+A/2)^2+(y+B/2)^2=(A/2)^2+(B/2)^2-Cより、(x0+A/2)(x+A/2)+(y0+B/2)(y+B/2)=(A^2+B^2)/4-C EXTERNAL SUB gcTANGENTLINE1C(x0,y0,A,B,C, L,M,N) LET RR=(A^2+B^2)/4-C !判別式 IF RR>0 THEN IF ABS(x0^2+y0^2+A*x0+B*y0+C)>cEPS THEN PRINT "点は円周上にありません。"; x0;y0;A;B;C ELSE LET L=x0+A/2 LET M=y0+B/2 LET N=x0*A/2+y0*B/2 +C END IF ELSE PRINT "半径が負または０なので、円が成立しません。"; A;B;C END IF END SUB !●円 EXTERNAL SUB gcCIRCLE(x1,y1,R, A,B,C) !中心(x1,y1)、半径Rの円 IF R>0 THEN LET A=-2*x1 LET B=-2*y1 LET C=x1^2+y1^2-R^2 ELSE PRINT "半径が負または０なので、円が成立しません。"; x1;y1;R END IF END SUB !2点P(x1,y1),Q(x2,y2)を結ぶ線分を直径とする円 !　A=-2(x1+x2)/2、B=-2(y1+y2)/2、C=(x1+x2)^2/4+(y1+y2)^2/4 -{(x1-x2)^2+(y1-y2)^2}/4 より EXTERNAL SUB gcCIRCLE2R(x1,y1,x2,y2, A,B,C) IF (x1=x2 AND y1=y2) THEN !同一点なら PRINT "2点は同一点なので、円が成立しません。"; x1;y1;x2;y2 ELSE LET A=-(x1+x2) LET B=-(y1+y2) LET C=x1*x2+y1*y2 END IF END SUB !2点P(x1,y1),Q(x2,y2)を通る半径Rの円 !　2点を通る直線（半径∞の円）　Lx+My+N=0 !　2点を直径とする円　x^2+y^2+Sx+Ty+U=0 !　これより、2点を通る曲線　(x^2+y^2+Sx+Ty+U)+k(Lx+My+N)=0 とおける。 !　半径がRより、(x+(S+kL)/2)^2+(y+(T+kM)/2)^2={(S+kL)^2+(T+kM)^2}/4-(U+kN)=R^2 !　∴(S+kL)^2+(T+kM)^2-4(U+kN)-4R^2=0 !　∴(L^2+M^2)k^2 +2(SL+TM-2N)k +{(S^2+T^2)-4*(R^2+U)}=0 !　kについての2次方程式を解く。 EXTERNAL SUB gcCIRCLE2(x1,y1,x2,y2,R, A,B,C, D,E,F, K) IF (x1=x2 AND y1=y2) THEN !同一点なら PRINT "2点は同一点なので、円が成立しません。"; x1;y1;x2;y2;R ELSEIF R<=0 THEN PRINT "半径は負または０なので、円が成立しません。"; x1;y1;x2;y2;R ELSE CALL gcLINE(x1,y1,x2,y2, L,M,N) !直線 CALL gcCIRCLE2R(x1,y1,x2,y2, S,T,U) !円 LET aa=L^2+M^2 LET bb=2*(S*L+T*M-2*N) LET cc=(S^2+T^2)-4*(R^2+U) CALL Solve2Equ(aa,bb,cc, k1,k2,K) IF K>0 THEN LET A=S+k1*L LET B=T+k1*M LET C=U+k1*N IF K=2 THEN !2点を結ぶ線分が直径となる場合は１つ LET D=S+k2*L LET E=T+k2*M LET F=U+k2*N END IF ELSE PRINT "半径の長さが短いので、円が成立しません。"; x1;y1;x2;y2;R LET K=0 END IF END IF END SUB !3点P(x1,y1),Q(x2,y2),R(x3,y3)を通る円（3点を頂点とする三角形の外接円） !　線分PQを直径とする円　(x-x1)*(x-x2)+(y-y1)*(y-y2)=0　←式1 !　点P,Qを通る直線（半径∞の円と考える）　(x-x1)*(y2-y1)-(y-y1)*(x2-x1)=0　←式2 !　これより、点P,Qを通る曲線（円）は、(式1)+k*(式2)=0と表される。 !　点Rを通るので、(x3,y3)を代入して、kを定める。 EXTERNAL SUB gcCIRCLE3(x1,y1,x2,y2,x3,y3, A,B,C) IF (x1=x3 AND y1=y2) OR (x2=x3 AND y2=y3) OR (x3=x1 AND y3=y1) THEN !同一点なら PRINT "異なる3点ではないので、円が成立しません。"; x1;y1;x2;y2;x3;y3 ELSEIF (x3-x1)*(y2-y1)=(y3-y1)*(x2-x1) THEN !直線PQと直線PRの傾きが同じなら PRINT "3点は一直線上にあるので、円が成立しません。"; x1;y1;x2;y2;x3;y3 ELSE LET p=(x3-x1)*(x3-x2)+(y3-y1)*(y3-y2) LET q=(x3-x1)*(y2-y1)-(y3-y1)*(x2-x1) LET k=-p/q !!!PRINT k !debug LET ox=((x1+x2)-k*(y2-y1))/2 !中心点o（外心） LET oy=((y1+y2)+k*(x2-x1))/2 LET R=DIST(ox,oy,x1,y1) !半径oA CALL gcCIRCLE(ox,oy,R, A,B,C) END IF END SUB !2円x^2+y^2+A1x+B1y+C1=0、x^2+y^2+A2x+B2y+C2=0の共通接線 !　2円の配置 !　外側で交わらない !　　2つの共通外接線、4つの接点 !　　2つの共通内接線、4つの接点 !　外接 !　　2つの共通外接線、4つの接点 !　　1つの内接線、1つの接点 !　交わる !　　2つの共通外接線、4つの接点 !　内接 !　　1つの接線、1つの接点 !　内側で交わらない !　　接線、接点なし ! !※接点(PX(1),PY(1))と接点(PX(2),PY(2))を通る接線は、L(1)x+M(1)y+N(1)=0となる。 EXTERNAL SUB gcTANGENTLINE2C(A1,B1,C1,A2,B2,C2, L(),M(),N(),K, PX(),PY(),K2) LET RR1=(A1^2+B1^2)/4-C1 !判別式 LET RR2=(A2^2+B2^2)/4-C2 IF (RR1>0 AND RR2>0) THEN !円と円 LET R1=SQR(RR1) !円1の半径 LET R2=SQR(RR2) !円2の半径 LET cx1=-A1/2 !円1の中心 LET cy1=-B1/2 LET cx2=-A2/2 !円2の中心 LET cy2=-B2/2 LET d=DIST(cx1,cy1,cx2,cy2) !線分o1o2の長さ（中心間の距離） LET t=ABS(R1-R2) IF t<d THEN !外側で交わらない、外接、交わる !--- 共通外接線 IF R1=R2 THEN !※半径が同じなので、接線は平行となる CALL gcLINE(cx1,cy1,cx2,cy2, S,T,U) !直線o1o2 CALL gcPARALLELLINE(S,T,U, R1, L(1),M(1),N(1),dx,dy) !間隔R1の直線 LET PX(1)=cx1+dx !接点 LET PY(1)=cy1+dy LET PX(2)=cx2+dx !接点 LET PY(2)=cy2+dy CALL gcPARALLELLINE(S,T,U,-R1, L(2),M(2),N(2),dx,dy) !反対側 LET PX(3)=cx1+dx !接点 LET PY(3)=cy1+dy LET PX(4)=cx2+dx !接点 LET PY(4)=cy2+dy ELSE !※直線o1o2を共通な辺として、半径を1辺とする相似な三角形を考える CALL gcDIVIDE(cx1,cy1,cx2,cy2,R1,-R2, xx,yy) !線分o1o2の外分点 CALL gcTANGENTLINE(xx,yy,A1,B1,C1, PX(1),PY(1),PX(3),PY(3),K) !この点から円1に接線を引く CALL gcDIVIDE(PX(1),PY(1),xx,yy,R1-R2,R2, PX(2),PY(2)) !接点と外分点から円2の接点を算出する CALL gcDIVIDE(PX(3),PY(3),xx,yy,R1-R2,R2, PX(4),PY(4)) CALL gcLINE(PX(1),PY(1),PX(2),PY(2), L(1),M(1),N(1)) !接線 CALL gcLINE(PX(3),PY(3),PX(4),PY(4), L(2),M(2),N(2)) END IF LET K=2 LET K2=4 !--- 共通内接線 LET tt=R1+R2 IF tt<d THEN !離れている（外側で交わらない） CALL gcDIVIDE(cx1,cy1,cx2,cy2,R1,R2, xx,yy) !線分o1o2の内分点 CALL gcTANGENTLINE(xx,yy,A1,B1,C1, PX(5),PY(5),PX(7),PY(7),K) !この点から円1に接線を引く CALL gcDIVIDE(PX(5),PY(5),xx,yy,R1+R2,-R2, PX(6),PY(6)) !接点と内分点から円2の接点を算出する CALL gcDIVIDE(PX(7),PY(7),xx,yy,R1+R2,-R2, PX(8),PY(8)) CALL gcLINE(PX(5),PY(5),PX(6),PY(6), L(3),M(3),N(3)) !接線 CALL gcLINE(PX(7),PY(7),PX(8),PY(8), L(4),M(4),N(4)) LET K=4 LET K2=8 ELSEIF ABS(tt-d)<=cEPS THEN !外接している CALL gcDIVIDE(cx1,cy1,cx2,cy2,R1,R2, PX(5),PY(5)) !線分o1o2をR1:R2に分ける点 CALL gcLINE(cx1,cy1,cx2,cy2, P,Q,R) !その点を通り、線分o1o2に垂直 CALL gcLINEX(PX(5),PY(5),P,Q,R, L(3),M(3),N(3)) LET K=3 LET K2=5 ELSE !交わる !nop END IF ELSEIF ABS(t-d)<=cEPS THEN !内接している CALL gcDIVIDE(cx1,cy1,cx2,cy2,R1,-R2, PX(1),PY(1)) !線分o1o2をR1:-R2に分ける点 CALL gcLINE(cx1,cy1,cx2,cy2, P,Q,R) !その点を通り、線分o1o2に垂直 CALL gcLINEX(PX(1),PY(1),P,Q,R, L(1),M(1),N(1)) LET K=1 LET K2=1 ELSE !含まれる（内側で交わらない） IF d=0 THEN PRINT "同心円で"; PRINT "接線はありません。" LET K=0 END IF ELSE PRINT "半径が負または０なので、円が成立しません。"; A1;B1;C1; A2;B2;C2 LET K=0 LET K2=0 END IF END SUB

Re: 作図サブルーチン集（図形と方程式）

投稿者：山中和義投稿日：2011年10月12日(水)11時01分47秒

> No.1672[元記事へ] いくつかの使用例です。サブルーチン部分は省略します。 ●サンプル１ !図形と方程式 SET WINDOW -8,8,-8,8 !表示領域を設定する　※ DRAW grid !XY座標 PUBLIC NUMERIC cEps !精度　※調整が必要である LET cEPS=1E-8 PUBLIC NUMERIC gcCOLOR,gcSTYLE,gcLINESTYLE !描画色、線種 LET gcCOLOR=1 LET gcLINESTYLE=1 !------------------------------ ここまでがサブルーチン !●3直線4x+3y+12=0, 3x-4y+9=0, 2x-y-4=0で作られる三角形の面積を求めよ。 LET gcCOLOR=1 LET L1=4 !直線1 LET M1=3 LET N1=12 CALL gcDRAWLINE(L1,M1,N1,"L1",2) !直線を描く LET gcCOLOR=2 LET L2=3 !直線2 LET M2=-4 LET N2=9 CALL gcDRAWLINE(L2,M2,N2,"L2",0) !直線を描く LET gcCOLOR=4 LET L3=2 !直線3 LET M3=-1 LET N3=-4 CALL gcDRAWLINE(L3,M3,N3,"L3",1) !直線を描く LET gcCOLOR=1 CALL gcINTERSECTION(L1,M1,N1,L2,M2,N2, xx1,yy1,K) !直線1と直線2との交点 PRINT xx1;yy1 !debug CALL gcDRAWPOINT(xx1,yy1,"") CALL gcINTERSECTION(L1,M1,N1,L3,M3,N3, xx2,yy2,K) !直線1と直線3との交点 PRINT xx2;yy2 !debug CALL gcDRAWPOINT(xx2,yy2,"") LET D=DIST(xx1,yy1,xx2,yy2) !底辺の長さ PRINT D !debug CALL gcINTERSECTION(L2,M2,N2,L3,M3,N3, xx,yy,K) !直線2と直線3との交点 PRINT xx;yy !debug CALL gcDRAWPOINT(xx,yy,"") LET H=DIST1L(xx,yy,L1,M1,N1) !高さ PRINT "面積="; D*H/2 !面積 END ●サンプル２ !図形と方程式 SET WINDOW -8,8,-8,8 !表示領域を設定する　※ DRAW grid !XY座標 PUBLIC NUMERIC cEps !精度　※調整が必要である LET cEPS=1E-8 PUBLIC NUMERIC gcCOLOR,gcSTYLE,gcLINESTYLE !描画色、線種 LET gcCOLOR=1 LET gcLINESTYLE=1 !------------------------------ ここまでがサブルーチン !●点(1,3)から、円x^2+y^2=5に引いた接線の方程式を求めよ。 LET gcCOLOR=4 LET px=1 !点(1,3) LET py=3 CALL gcDRAWPOINT(px,py,"") !点を描く LET A=0 !円 LET B=0 LET C=-5 CALL gcDRAWCIRCLE(A,B,C,"",0) !円を描く CALL gcTANGENTLINE(px,py,A,B,C, x1,y1,x2,y2,K) LET gcCOLOR=1 IF k>0 THEN PRINT x1;y1 !接点 CALL gcLINE(px,py,x1,y1, P,Q,R) !接線を描く CALL gcDRAWLINE(P,Q,R,"",0) IF K=2 THEN !2つ目 PRINT x2;y2 !接点 CALL gcLINE(px,py,x2,y2, P,Q,R) !接線を描く CALL gcDRAWLINE(P,Q,R,"",0) END IF END IF END ●サンプル３ !図形と方程式 SET WINDOW -8,8,-8,8 !表示領域を設定する　※ DRAW grid !XY座標 PUBLIC NUMERIC cEps !精度　※調整が必要である LET cEPS=1E-8 PUBLIC NUMERIC gcCOLOR,gcSTYLE,gcLINESTYLE !描画色、線種 LET gcCOLOR=1 LET gcLINESTYLE=1 !------------------------------ ここまでがサブルーチン !●2円(x+1)^2+(y+2)^2=5、(x-2)^2+(y-3)^2=3の共通接線の方程式を求めよ。 LET gcCOLOR=1 CALL gcCIRCLE(-1,-2,SQR(5), A1,B1,C1) !円1 CALL gcDRAWCIRCLE(A1,B1,C1,"C1",0) CALL gcCIRCLE(4,2,3, A2,B2,C2) !円2　外部で交わらない !CALL gcCIRCLE(2,3,4, A2,B2,C2) !円2　交わる !CALL gcCIRCLE(3,4,5, A2,B2,C2) !円2　外接 !CALL gcCIRCLE2R(-1,-2,-2,-4, A2,B2,C2) !円2　内接 !CALL gcCIRCLE2R(-0.5,-0.5,-2,-3, A2,B2,C2) !円2　内部で交わらない CALL gcDRAWCIRCLE(A2,B2,C2,"C2",0) DIM LL(4),MM(4),NN(4) DIM TX(8),TY(8) CALL gcTANGENTLINE2C(A1,B1,C1,A2,B2,C2, LL,MM,NN,K, TX,TY,K2) PRINT K;K2 LET gcCOLOR=4 FOR i=1 TO K !接線を描く CALL gcDRAWLINE(LL(i),MM(i),NN(i),"",0) NEXT i FOR i=1 TO K2 !接点を描く PRINT i;":"; TX(i);TY(i) CALL gcDRAWPOINT(TX(i),TY(i),"") NEXT i END

Re: 作図サブルーチン集（図形と方程式）追加

投稿者：山中和義投稿日：2011年10月13日(木)11時38分41秒

> No.1673[元記事へ] 追加　線分、点対称、線対称、平面図形（三角形） ●サンプル !図形と方程式、平面図形 SET WINDOW -8,8,-8,8 !表示領域を設定する　※ DRAW grid !XY座標 PUBLIC NUMERIC cEps !精度　※調整が必要である LET cEPS=1E-8 PUBLIC NUMERIC gcCOLOR,gcSTYLE,gcLINESTYLE !描画色、線種 LET gcCOLOR=1 LET gcLINESTYLE=1 !------------------------------ ここまでがサブルーチン !●3点を頂点とする三角形 LET Xa=-5 LET Ya=-6 LET Xb=3 LET Yb=-3 LET Xc=-1 LET Yc=3 CALL gcLINE(Xa,Ya,Xb,Yb, L,M,N) !直線AB CALL gcDRAWLINE(L,M,N,"",0) CALL gcLINE(Xa,Ya,Xc,Yc, P,Q,R) !直線AC CALL gcDRAWLINE(P,Q,R,"",0) LET gcCOLOR=4 CALL gcTRIANGLE(Xa,Ya,Xb,Yb,Xc,Yc,"ABC") !三角形を描く LET gcCOLOR=2 CALL gcINCENTER(Xa,Ya,Xb,Yb,Xc,Yc, Xi,Yi,R) !内心 CALL gcDRAWPOINT(Xi,Yi,"I") CALL gcCIRCLE(Xi,Yi,R, P,Q,R) CALL gcDRAWCIRCLE(P,Q,R,"",0) LET gcCOLOR=3 CALL gcCIRCUMCENTER(Xa,Ya,Xb,Yb,Xc,Yc, Xo,Yo,R) !外心 CALL gcDRAWPOINT(Xo,Yo,"O") CALL gcCIRCLE(Xo,Yo,R, P,Q,R) CALL gcDRAWCIRCLE(P,Q,R,"",0) LET gcCOLOR=4 CALL gcGRAVITY(Xa,Ya,Xb,Yb,Xc,Yc, Xg,Yg) !重心 CALL gcDRAWPOINT(Xg,Yg,"G") LET gcCOLOR=5 CALL gcORTHOCENTER(Xa,Ya,Xb,Yb,Xc,Yc, Xh,Yh) !垂心 CALL gcDRAWPOINT(Xh,Yh,"H") LET gcCOLOR=1 CALL gcEXCENTER(Xa,Ya,Xb,Yb,Xc,Yc, Xi,Yi,R) !傍心 CALL gcDRAWPOINT(Xi,Yi,"i") CALL gcCIRCLE(Xi,Yi,R, P,Q,R) CALL gcDRAWCIRCLE(P,Q,R,"",0) CALL gcLINE(Xo,Yo,Xh,Yh, A,B,C) CALL gcDRAWLINE(A,B,C, "",0) END !※※※※※　ここに前出のサブルーチンを組み込んでください。 !------------------------- オプション !各処理の階層構造 !基本ルーチン !線分（2点を結ぶ） !　作図 gcDRAWSEGMENT !　直線との交点 gcINTERSECTION1S !点対称 !　点 gcSYMMETRY !　直線 gcSYMMETRY_L !　円 gcSYMMETRY_C !線対称 !　点 gcSYMMETRY2 !計測 !　2直線のなす角 gcCALC_ANGLE2L !下位ルーチン !線対称 !　直線 gcSYMMETRY2_L !　円 gcSYMMETRY2_C !線分 (x1,y1)+(x2-x1,y2-y1)*t　0≦t≦1　媒介変数表示 !作図ルーチン EXTERNAL SUB gcDRAWSEGMENT(x1,y1,x2,y2,s$,o) !2点(x1,y1),(x2,y2)を結ぶ線分を描く SET LINE COLOR gcCOLOR PLOT LINES: x1,y1; x2,y2 IF s$<>"" THEN !注釈 SELECT CASE o !記入位置 CASE 0 !点1 LET x=x1 LET y=y1 CASE 1 !点2 LET x=x2 LET y=y2 CASE 2 !中点 LET x=(x1+x2)/2 LET y=(y1+y2)/2 CASE ELSE END SELECT PLOT TEXT ,AT x,y: s$ END IF END SUB !演算ルーチン !直線Lx+My+N=0と2点(x1,y1)と(x2,y2)を結ぶ線分との交点 EXTERNAL SUB gcINTERSECTION1S(L,M,N,x1,y1,x2,y2, xx,yy,K) IF (x1=x2 AND y1=y2) THEN PRINT "2点は同一点なので、線分が成立しません。"; x1;y1;x2;y2 ELSE LET s=L*x1+M*y1+N !点(x1,y1)の直線に対する位置（右側、線上、左側） LET t=L*x2+M*y2+N !点(x2,y2) IF s=0 AND t=0 THEN !重なる PRINT "直線と線分が重なります。" LET K=0 ELSEIF s=0 AND t<>0 THEN !点(x1,y1)が直線上（T型） LET xx=x1 LET yy=y1 LET K=1 ELSEIF t=0 AND s<>0 THEN !点(x2,y2)が直線上（T型） LET xx=x2 LET yy=y2 LET K=1 ELSEIF s*t<0 THEN !反対側なので、交わる（X型） !点と直線との距離（|s|/√(L^2+M^2) : |t|/√(L^2+M^2)）、相似三角形から CALL gcDIVIDE(x1,y1,x2,y2,ABS(s),ABS(t), xx,yy) LET K=1 ELSE !同じ側なので、交差しない LET K=0 END IF END IF END SUB !●対称 !点対称 EXTERNAL SUB gcSYMMETRY(X,Y,PX,PY, QX,QY) !点Aに対する点対称の点 LET QX=2*PX-X LET QY=2*PY-Y END SUB !点Aに対する点対称の直線 !　点A(px,py)、直線AX+BY+C=0、対称点B(x,y)とすると、(X+x)/2=px、(Y+y)/2=py !　X=2px-x、Y=2py-yを直線の式に代入して、A(2px-x)+B(2py-x)+C=0　∴Ax+By+(-2Apx-2Bpy-C)=0 EXTERNAL SUB gcSYMMETRY_L(A,B,C,PX,PY, L,M,N) LET L=A LET M=B LET N=-2*(A*PX+B*PY)-C END SUB !点Aに対する点対称の円 !　点A(px,py)、対称点B(x,y)とすると、(X+x)/2=px、(Y+y)/2=py　∴X=2px-x、Y=2py-y !　(2px-x)^2+(2px-y)^2+A(2px-x)+B(2py-y)+C=0 !　∴x^2+y^2+(-4px-A)x+(-py-B)y+(4px^2+4py^2+2Apx+2Bpy+C)=0 EXTERNAL SUB gcSYMMETRY_C(A,B,C,PX,PY, P,Q,R) LET P=-4*PX-A LET Q=-4*PY-B LET R=2*PX*(2*PX+A)+2*PY*(2*PY+B)+C END SUB !線対称 EXTERNAL SUB gcSYMMETRY2(L,M,N,PX,PY, QX,QY) !線対称（Lx+My+N=0）の点 IF (L=0 AND M=0) THEN PRINT "L=M=0なので、直線が成立しません。"; L;M;N ELSE LET m1=M*M-L*L !直線Lx+My+N=0 LET m2=-2*L*M LET m3=L*L+M*M LET QX=(m1*PX+m2*PY-2*L*N)/m3 LET QY=(m2*PX-m1*PY-2*M*N)/m3 END IF END SUB EXTERNAL SUB gcSYMMETRY2_L(L,M,N,A,B,C, P,Q,R) !線対称（Lx+My+N=0）の直線 IF (L=0 AND M=0) THEN PRINT "L=M=0なので、直線が成立しません。"; L;M;N ELSE IF ABS(A)>ABS(B) THEN !y=±xの傾きより大きいなら　※y軸に平行な直線を含む CALL gcSYMMETRY2(L,M,N,-(B*5+C)/A, 5, PX,PY) !y=±5の点 CALL gcSYMMETRY2(L,M,N,-(B*(-5)+C)/A,-5, QX,QY) CALL gcLINE(PX,PY,QX,QY, P,Q,R) ELSE CALL gcSYMMETRY2(L,M,N, 5,-(A*5+C)/B, PX,PY) !x=±5の点 CALL gcSYMMETRY2(L,M,N,-5,-(A*(-5)+C)/B, QX,QY) CALL gcLINE(PX,PY,QX,QY, P,Q,R) END IF END IF END SUB EXTERNAL SUB gcSYMMETRY2_C(L,M,N,A,B,C, P,Q,R) !線対称（Lx+My+N=0）の円 IF (L=0 AND M=0) THEN PRINT "L=M=0なので、直線が成立しません。"; L;M;N ELSE LET RR=(A^2+B^2)/4-C !判別式 IF RR>=0 THEN CALL gcSYMMETRY2(L,M,N,-A/2,-B/2, QX,QY) !中心の位置 CALL gcCIRCLE(QX,QY,SQR(RR), P,Q,R) !中心、半径の円 ELSE PRINT "半径が負なので、円が成立しません。"; A;B;C END IF END IF END SUB !●計測 !2直線 L1x+M1y+N1=0、L2x+M2y+N2=0 がなす角　※単位は度 !　直線1の傾きの角度をθ1とすると、y=(-L1/M1)x-N1=(tanθ1)x-N1 !　直線2の傾きの角度をθ2とすると、y=(-L2/M2)x-N2=(tanθ2)x-N2 !　tan(θ2-θ1)=(tanθ2-tanθ1)/{1+(tanθ2)(tanθ1)}より EXTERNAL FUNCTION gcCALC_ANGLE2L(L1,M1,N1,L2,M2,N2) IF M1=0 AND M2=0 THEN !直線1と直線2が共にY軸と平行なら LET gcCALC_ANGLE2L=0 ELSEIF M1=0 THEN !直線1がY軸と平行なら LET gcCALC_ANGLE2L=DEG( ATN(-L2/M2) )-90 ELSEIF M2=0 THEN !直線2がY軸と平行なら LET gcCALC_ANGLE2L=90-DEG( ATN(-L1/M1) ) ELSE LET t1=-L1/M1 !直線1の傾き LET t2=-L2/M2 !直線2の傾き IF 1+t2*t1=0 THEN LET gcCALC_ANGLE2L=90 !直角 ELSE LET t=(t2-t1)/(1+t2*t1) !θ2-θ1 LET gcCALC_ANGLE2L=DEG( ATN(t) ) END IF END IF END FUNCTION !------------------------- オプション !各処理の階層構造 !基本ルーチン !下位ルーチン !　作図 gcTRIANGLE !　ヘロンの公式 gcHERON !中位ルーチン !　内心 gcINCENTER !　外心 gcCIRCUMCENTER !　重心 gcGRAVITY !　垂心 gcORTHOCENTER !　傍心 gcEXCENTER !三角形　3点A(Xa,Ya), B(Xb,Yb), C(Xc,Yc)を頂点とする !作図ルーチン EXTERNAL SUB gcTRIANGLE(Xa,Ya,Xb,Yb,Xc,Yc,N$) !頂点A,B,Cの三角形を描く CALL gcDRAWSEGMENT(Xa,Ya,Xb,Yb,N$(1:1),0) !頂点、辺を描く CALL gcDRAWSEGMENT(Xb,Yb,Xc,Yc,N$(2:2),0) CALL gcDRAWSEGMENT(Xc,Yc,Xa,Ya,N$(3:3),0) END SUB !演算ルーチン EXTERNAL SUB gcHERON(Xa,Ya,Xb,Yb,Xc,Yc, a,b,c,S) !3辺a,b,cと三角形の面積S LET a=DIST(Xb,Yb,Xc,Yc) !辺BCの長さ LET b=DIST(Xc,Yc,Xa,Ya) !辺CA LET c=DIST(Xa,Ya,Xb,Yb) !辺AB IF a+b>c AND b+c>a AND c+a>b THEN LET t=(a+b+c)/2 !ヘロンの公式より、面積S LET S=SQR(t*(t-a)*(t-b)*(t-c)) ELSE PRINT "三角形が成立しません。"; a;b;c LET S=0 !!!STOP END IF END SUB !●三角形の心 EXTERNAL SUB gcINCENTER(Xa,Ya,Xb,Yb,Xc,Yc, Xi,Yi,R) !三角形ABCの内心（三角形ABCに内接する円の中心と半径） CALL gcHERON(Xa,Ya,Xb,Yb,Xc,Yc, a,b,c,S) !3辺a,b,cと三角形の面積S LET t=a+b+c LET Xi=(a*Xa+b*Xb+c*Xc)/t !内心の位置ベクトル LET Yi=(a*Ya+b*Yb+c*Yc)/t LET R=2*S/t !S=△IAB+△IBC+△ICA=1/2*c*r+1/2*a*r+1/2*b*r=r*(a+b+c)/2より END SUB EXTERNAL SUB gcCIRCUMCENTER(Xa,Ya,Xb,Yb,Xc,Yc, Xo,Yo,R) !三角形ABCの外心（三角形ABCに外接する円の中心と半径） CALL gcHERON(Xa,Ya,Xb,Yb,Xc,Yc, a,b,c,S) !3辺a,b,cと三角形の面積S LET sin2A=2*S*(b^2+c^2-a^2)/(b*c)^2 !sin2A=2*cosA*sinA、余弦定理cosA=(b^2+c^2-a^2)/(2*b*c)、面積S=1/2*b*c*sinAより LET sin2B=2*S*(c^2+a^2-b^2)/(c*a)^2 LET sin2C=2*S*(a^2+b^2-c^2)/(a*b)^2 LET t=sin2A+sin2B+sin2C LET Xo=(sin2A*Xa+sin2B*Xb+sin2C*Xc)/t !外心の位置ベクトル LET Yo=(sin2A*Ya+sin2B*Yb+sin2C*Yc)/t LET R=a*b*c/(4*S) !正弦定理a/sinA=b/sinB=c/sinC=2*Rと面積S=1/2*b*c*sinAより END SUB EXTERNAL SUB gcGRAVITY(Xa,Ya,Xb,Yb,Xc,Yc, Xg,Yg) !三角形ABCの重心 LET Xg=(Xa+Xb+Xc)/3 !重心の位置ベクトル LET Yg=(Ya+Yb+Yc)/3 END SUB EXTERNAL SUB gcORTHOCENTER(Xa,Ya,Xb,Yb,Xc,Yc, Xh,Yh) !三角形ABCの垂心 CALL gcHERON(Xa,Ya,Xb,Yb,Xc,Yc, a,b,c,S) !3辺a,b,cと三角形の面積S LET T1=b^2+c^2-a^2 IF T1=0 THEN !∠Aが直角なら LET Xh=Xa !垂心の位置ベクトル LET Yh=Ya ELSE LET T2=c^2+a^2-b^2 IF T2=0 THEN !∠Bが直角なら LET Xh=Xb LET Yh=Yb ELSE LET T3=a^2+b^2-c^2 IF T3=0 THEN !∠Cが直角なら LET Xh=Xc LET Yh=Yc ELSE LET tanA=2*S/T1 !tanA=sinA/cosAと余弦定理cosA=(b^2+c^2-a^2)/(2*b*c)と面積S=1/2*b*c*sinAより LET tanB=2*S/T2 LET tanC=2*S/T3 LET t=tanA+tanB+tanC LET Xh=(tanA*Xa+tanB*Xb+tanC*Xc)/t !垂心の位置ベクトル LET Yh=(tanA*Ya+tanB*Yb+tanC*Yc)/t END IF END IF END IF END SUB EXTERNAL SUB gcEXCENTER(Xa,Ya,Xb,Yb,Xc,Yc, Xi,Yi,R) !三角形ABCの傍心（点Aを頂角、点B,Cを外角とする） CALL gcHERON(Xa,Ya,Xb,Yb,Xc,Yc, a,b,c,S) !3辺a,b,cと三角形の面積S LET t=(-a)+b+c LET Xi=((-a)*Xa+b*Xb+c*Xc)/t !傍心の位置ベクトル LET Yi=((-a)*Ya+b*Yb+c*Yc)/t LET R=2*S/t !S=(s-a)*Ra、s=(a+b+c)/2より END SUB

のこぎり波のプログラムについて

投稿者：zyam63

投稿日：2011年10月15日(土)04時40分27秒

のこぎり波のプログラムを教えて頂けませんか。わたしの作ったのは以下のようなのです。 SET WINDOW -10,10,-10,10 DRAW grid(1,1) FOR x=-3*PI TO 3*PI STEP 0.001 LET p= (-1)^(0)*SIN(1*x)/1 LET q= (-1)^(1)*SIN(2*x)/2 LET r= (-1)^(2)*SIN(3*x)/3 LET s= (-1)^(3)*SIN(4*x)/4 LET t= (-1)^(4)*SIN(5*x)/5 LET u= (-1)^(5)*SIN(6*x)/6 LET v= (-1)^(6)*SIN(7*x)/7 LET w= (-1)^(7)*SIN(8*x)/8 LET e= (-1)^(8)*SIN(9*x)/9 LET f= (-1)^(9)*SIN(10*x)/10 LET g= (-1)^(10)*SIN(11*x)/11 LET h= (-1)^(11)*SIN(12*x)/12 LET i= (-1)^(12)*SIN(13*x)/13 LET j= (-1)^(13)*SIN(14*x)/14 LET k= (-1)^(14)*SIN(15*x)/15 LET l= (-1)^(15)*SIN(16*x)/16 LET y=o+p+q+r+s+t+u+v+w+z+e+f+g+h+i+j+k+l PLOT x,y NEXT x END

Re: のこぎり波のプログラムについて

投稿者：山中和義投稿日：2011年10月15日(土)08時55分6秒

> No.1675[元記事へ] zyam63さんへのお返事です。 !のこぎり波は正弦波を合成することで近似する SET WINDOW -10,10,-10,10 DRAW grid FOR x=-10 TO 10 STEP 1/2^8 LET s=0 FOR k=1 TO 50 !周期2π　Σ[k=1,∞]{sin(k*x)/k} LET s=s+SIN(k*x)/k NEXT k PLOT LINES: x,s*2/PI; !振幅1 NEXT x PLOT LINES !床関数よる SET LINE COLOR 4 FOR x=-10 TO 10 STEP 1/2^8 !※刻み幅 LET t=-(x-PI)/(2*PI) !周期2π、振幅1 PLOT LINES: x,2*(t-INT(t+1/2)); !※折れ線近似 NEXT x PLOT LINES END

Re: のこぎり波のプログラムについて

投稿者：zyam63

投稿日：2011年10月15日(土)17時16分47秒

> No.1676[元記事へ] 山中様、ありがとうございます。 nを可変にして、収束の様子を見るようにしました。三角関数の合成の加算をどうすればよいのか分からなかったので助かりました。 !のこぎり波は正弦波を合成することで近似する SET WINDOW -10,10,-10,10 DRAW grid INPUT n FOR x=-3*PI TO 3*PI STEP 0.001 LET s=0 FOR k=1 TO n !周期2π　Σ[k=1,∞]{sin(k*x)/k} LET s=s+(-1)^(n-1)*SIN(k*x)/k NEXT k PLOT LINES: x,s ! s*2/PI; !振幅1 NEXT x PLOT LINES END >

四則演算ゲーム（計算パズル）

投稿者：山中和義投稿日：2011年10月16日(日)10時31分53秒

四則演算ゲーム　4つの1桁の数に対して、四則（+,-,×,÷）、括弧、べき乗、平方根を使って、　ある数Nを求める式をつくる。例　1,3,4,6から24を表す計算式は、6÷(1-3÷4)=24　※難問 ●四則演算、括弧、べき乗による場合通常の式の表現（中置表現）では、括弧の組合せを考えるのは容易ではありません。この場合は数が４つなので何とかなると思います。そこで、一部の電卓やプログラム言語の数式処理で採用されている後置表記（逆ポーランド表記）を使ってみます。　後置表記（逆ポーランド表記）による数式　例　　(1+2)*3-4　→　12+3*4- 　利点　　括弧を使わずにすべての式を表現できる。　　数式を計算するプログラムが容易に作れる。場合の数　4つの数の並びは、4!通り　式「12A3B4C」のABCの位置に入る演算子（四則、べき乗）の並びは、5^3通り　式「12A3B4C」のABCの位置に入る演算子の個数　0≦A≦1, 0≦B≦2-A, C=3-(A+B) これらに注意して、コーディングしてみます。 1000 !四則演算ゲーム 1010 DATA 1,3,4,6 !4つの数 1020 DIM X(4) 1030 MAT READ X 1040 1050 1060 FOR N=0 TO 100 !求める数 1070 !!PRINT "N=";N 1080 1090 1100 DIM idx(4) !参照位置 1110 LET h=0 1120 DO WHILE h<FACT(4) !数字の並びは、4!通り 1130 CALL Num2PermFactorial(h, idx,4) 1140 !!!MAT PRINT idx; !debug 1150 1160 1170 LET OP$="+-*/^" !演算子 1180 LET L=LEN(OP$) 1190 1200 FOR i=0 TO L^3-1 !L進法による「演算子の並び」のパターンを生成する 1210 !!!PRINT i !debug 1220 1230 LET P$="" !演算子の並び 1240 LET t=i 1250 FOR k=1 TO 3 !個数は3個　※進数変換 1260 LET w=MOD(t,L)+1 1270 LET P$=P$&OP$(w:w) 1280 LET t=INT(t/L) 1290 NEXT k 1300 !!!PRINT P$ !debug 1310 1320 FOR A=0 TO 1 !式「12A3B4C」に入る演算子の個数 1330 FOR B=0 TO 2-A 1340 LET C=3-(A+B) !残り 1350 !!!PRINT A;B;C !debug 1360 1370 !パターンから必要な個数だけ切り出して、式をつくる 1380 LET s$=STR$(X(idx(1))) !1番目の数 1390 LET s$=s$&STR$(X(idx(2))) !2番目の数 1400 LET s$=s$&P$(1:A) 1410 LET s$=s$&STR$(X(idx(3))) !3番目の数 1420 LET s$=s$&P$(1+A:A+B) 1430 LET s$=s$&STR$(X(idx(4))) !4番目の数 1440 LET s$=s$&P$(1+A+B:A+B+C) 1450 !!!PRINT s$ !debug 1460 1470 CALL calc(s$,X, v) !式を計算する 1480 IF ABS(v-N)<=1E-12 THEN !該当するなら、解となる 1490 PRINT s$;"=";v 1500 1510 EXIT DO !※最初に見つかった１つのみ 1520 END IF 1530 1540 NEXT B 1550 NEXT A 1560 1570 NEXT i 1580 1590 LET h=h+1 !次の並びへ 1600 LOOP 1610 1620 NEXT N 1630 1640 END 1650 1660 1670 EXTERNAL SUB calc(s$,X(), v) !後置表記の式を計算する 1680 DIM STK(4) !スタック 1690 LET SP=0 !スタックポインタ 1700 LET v=-99999999 !エラーの場合の値 1710 FOR i=1 TO LEN(s$) !式を計算する 1720 SELECT CASE s$(i:i) 1730 CASE "+","＋" !加算 1740 LET STK(SP-1)=STK(SP-1)+STK(SP) 1750 LET SP=SP-1 1760 CASE "-","－" !減算 1770 LET STK(SP-1)=STK(SP-1)-STK(SP) 1780 LET SP=SP-1 1790 CASE "*","×" !乗算 1800 LET STK(SP-1)=STK(SP-1)*STK(SP) 1810 LET SP=SP-1 1820 CASE "/","÷" !除算 1830 IF STK(SP)=0 THEN EXIT SUB !0による割り算 1840 LET STK(SP-1)=STK(SP-1)/STK(SP) 1850 LET SP=SP-1 1860 1870 CASE "^" !べき乗 1880 IF STK(SP-1)=0 AND STK(SP)<=0 THEN EXIT SUB !0の負数乗、0の0乗 1890 IF STK(SP-1)<0 AND STK(SP)<>INT(STK(SP)) THEN EXIT SUB !負数の非整数乗 1900 WHEN EXCEPTION IN 1910 LET STK(SP-1)=STK(SP-1)^STK(SP) 1920 LET SP=SP-1 1930 USE 1940 EXIT SUB !オーバーフロー、アンダーフロー 1950 END WHEN 1960 1970 CASE "√" !平方根 1980 IF STK(SP)<0 THEN EXIT SUB !負数 1990 LET STK(SP)=SQR(STK(SP)) 2000 2010 CASE " " 2020 !nop 2030 2040 CASE IS >="0", IS <="9" !1桁の数値 2050 LET SP=SP+1 2060 LET STK(SP)=VAL(s$(i:i)) 2070 2080 CASE ELSE 2090 END SELECT 2100 NEXT i 2110 IF SP<>1 THEN PRINT "error!!!" 2120 LET v=STK(1) !結果 2130 END SUB 2140 2150 2160 EXTERNAL SUB Num2PermFactorial(h, A(),N) !番号から順列パターンを生成する　※辞書式順序 2170 LET v=h !非負の10進数整数を階乗進数へ 2180 FOR j=1 TO N 2190 LET t=INT(v/j) 2200 LET A(N-j+1)=v-t*j +1 !階乗進数の各桁の値＋１　A[1..N]=(N-1)! … 3! 2! 1! 0! 2210 LET v=t 2220 NEXT j 2230 FOR j=N-1 TO 1 STEP -1 !順列パターンへ 2240 FOR k=j+1 TO N 2250 IF A(k)>=A(j) THEN LET A(k)=A(k)+1 2260 NEXT k 2270 NEXT j 2280 END SUB ●べき乗を含まない場合 1170 LET OP$="+-*/" !演算子と変更（べき乗演算子を削除）してください。 ●平方根を含む場合式を計算する部分は既に組み込んでいますので、後は式の生成のみです。同様に、組合せを考えればよいのですが、組合せの階層が増えてプログラムが複雑になります。そこで、手動で切り抜ける方法を紹介します。 (√1)+2+3+4型 1380 LET s$=STR$(X(idx(1)))&"√" !1番目の数 1390 LET s$=s$&STR$(X(idx(2))) !2番目の数 1400 LET s$=s$&P$(1:A) 1410 LET s$=s$&STR$(X(idx(3))) !3番目の数 1420 LET s$=s$&P$(1+A:A+B) 1430 LET s$=s$&STR$(X(idx(4))) !4番目の数 1440 LET s$=s$&P$(1+A+B:A+B+C) √(1+2+3)+4型 1380 LET s$=STR$(X(idx(1))) !1番目の数 1390 LET s$=s$&STR$(X(idx(2))) !2番目の数 1400 LET s$=s$&P$(1:A) 1410 LET s$=s$&STR$(X(idx(3))) !3番目の数 1420 LET s$=s$&P$(1+A:A+B)&"√" 1430 LET s$=s$&STR$(X(idx(4))) !4番目の数 1440 LET s$=s$&P$(1+A+B:A+B+C) のように平方根を各数の後や演算子の後に組み合わせて追加すればよいと思います。

Re: 四則演算ゲーム（計算パズル）

投稿者：山中和義投稿日：2011年10月17日(月)11時35分56秒

> No.1678[元記事へ] 後置表記では、読み難いので通常の式に変換するルーチンを追加しておきます。 6134/-/= 24　→　6/(1-3/4)= 24 変更部分（使用例） 1490 PRINT s$;"=";v を 1490 CALL rpn2std(s$,t$) 1495 PRINT t$;"=";v とする。追加部分　前出のプログラムの最後に追加して下さい。 2290 2300 2310 EXTERNAL SUB rpn2std(s$, t$) !後置表記を中置表記で表す 2320 DIM STK$(4),STK2(4) !スタック 2330 LET SP=0 !スタックポインタ 2340 FOR i=1 TO LEN(s$) !式を計算する 2350 LET OP$=s$(i:i) 2360 SELECT CASE OP$ 2370 CASE "+","＋" !加算 2380 LET STK$(SP-1)=STK$(SP-1) & OP$ & STK$(SP) !「1+2」とする　※(1+2)+3や1+(2+3)は1+2+3とする 2390 LET STK2(SP-1)=1 !優先順位（ +,- ＜ *,/ ＜ ^ ＜ √ ＜数値）　※値が大きい程、先に計算する 2400 LET SP=SP-1 2410 CASE "-","－" !減算 2420 LET L$=STK$(SP-1) !左項 2430 LET R$=STK$(SP) !右項 2440 CALL paren(R$, FLG) 2450 IF STK2(SP)<2 AND FLG=-1 THEN !右項が+,-で、括弧が付いていなければ 2460 LET R$="(" & R$ & ")" !※1-(2±3)の場合 2470 END IF 2480 LET STK$(SP-1)=L$ & OP$ & R$ 2490 LET STK2(SP-1)=1 2500 LET SP=SP-1 2510 CASE "*","×", "/","÷" !乗算、除算 2520 LET L$=STK$(SP-1) !左項 2530 LET R$=STK$(SP) !右項 2540 CALL paren(L$, FLG) 2550 IF STK2(SP-1)<2 AND FLG=-1 THEN !左項が+,-で、括弧が付いていなければ 2560 LET L$="(" & L$ & ")" 2570 END IF 2580 CALL paren(R$, FLG) 2590 IF STK2(SP)<=2 AND FLG=-1 THEN !右項 2600 LET R$="(" & R$ & ")" !※1*(2*3)や1*(2/3)や1/(2*3)や1/(2/3)の場合も含む 2610 END IF 2620 LET STK$(SP-1)=L$ & OP$ & R$ 2630 LET STK2(SP-1)=2 2640 LET SP=SP-1 2650 2660 CASE "^" !べき乗 2670 LET L$=STK$(SP-1) !左項 2680 LET R$=STK$(SP) !右項 2690 CALL paren(L$, FLG) 2700 IF STK2(SP-1)<=4 AND FLG=-1 THEN !左項が+,-,*,/,^で、括弧が付いていなければ 2710 LET L$="(" & L$ & ")" !※(1^2)^3の場合も含む 2720 END IF 2730 CALL paren(R$, FLG) 2740 IF STK2(SP)<=4 AND FLG=-1 THEN !右項 2750 LET R$="(" & R$ & ")" !※1^(2^3)の場合も含む 2760 END IF 2770 LET STK$(SP-1)=L$ & OP$ & R$ 2780 LET STK2(SP-1)=4 2790 LET SP=SP-1 2800 2810 CASE "√" !平方根 2820 LET L$=STK$(SP) 2830 CALL paren(L$, FLG) !括弧が付いていなければ 2840 IF FLG=-1 THEN LET L$="(" & L$ & ")" !引数　※(1+2)*3や(1+2)*(3+4)の場合も含む 2850 LET STK$(SP)=OP$ & L$ 2860 LET STK2(SP)=5 2870 2880 CASE " " 2890 !nop 2900 2910 CASE IS >="0", IS <="9" !1桁の数値 2920 LET SP=SP+1 !push it 2930 LET STK$(SP)=OP$ 2940 LET STK2(SP)=9 2950 2960 CASE ELSE 2970 PRINT "未定義の文字です。"; OP$ 2980 END SELECT 2990 NEXT i 3000 IF SP<>1 THEN PRINT "error!!!" 3010 LET t$=STK$(1) !結果 3020 3030 SUB paren(s$, FLG) !括弧が付いているかどうか確認する　※(1+2)*3や(1+2)*(3+4)は「なし」 3040 LET FLG=0 3050 IF s$(1:1)<>"(" OR (s$(1:1)="(" AND POS(s$,")")<LEN(s$)) THEN LET FLG=-1 !括弧なし 3060 END SUB 3070 END SUB

改訂版　正多面体(4,6,8,12,20)、切頂20面体( 32面体・フラーレン・サッカーボール)

投稿者：SECOND 投稿日：2011年10月18日(火)02時54分18秒

!４）自己相似写像で描く、立体と展開図のアニメ－ション。　2011.10 Updated !--------------------------------------------------------- !改訂版　正多面体(4,6,8,12,20)、切頂20面体( 32面体・フラーレン・サッカーボール) ! ＜ドラッグ応答性の改善。　回る多面体を上下左右にドラッグしてみて下さい＞ !１）どの方向へも、多面体の重心を中心に回転し、 !２）又、その累積による応答変化も、無くした。 !３）左ボタンが離され、常時回転に戻るまでに、間を空けた。 !４）表示中の立体 → 右クリックで → その立体の平面展開図を表示するようにした。 !　　展開図のときに、右クリックすると、プログラム終了。 !５）アニメ速度が、パソコンの種類で変らないよう、周期偏差積分の自動制御を付けた。 ! ※構文の大幅な見直しと整理、６面体の追加。 OPTION ARITHMETIC NATIVE SET TEXT JUSTIFY "center","half" SET WINDOW -1.5, 1.5, -1.4, 1.6 DIM rotx(4,4), rotx2(4,4), Axys(4,4), shxyz(4,4), Abak(4,4) DIM Vi(4), Vo(4), m(4,4), D3( 32+1, 0 TO 6+1, 3), msk(6, 0 TO 60), cg(6,3), D1(7,2) DIM p3(0 TO 3, 2), p4(0 TO 4, 2), p5(0 TO 5, 2), p6(0 TO 6, 2) ! CALL polygon(3, 1/2, ir3, p3) !正３角形, 中心(0,0)底辺(-1/2,-ir3)~(1/2,-ir3) CALL polygon(4, 1/2, ir4, p4) !正４角形, 中心(0,0)底辺(-1/2,-ir4)~(1/2,-ir4) CALL polygon(5, 1/6, ir5, p5) !正５角形, 中心(0,0)底辺(-1/6,-ir5)~(1/6,-ir5) CALL polygon(6, 1/6, ir6, p6) !正６角形, 中心(0,0)底辺(-1/6,-ir6)~(1/6,-ir6) SUB polygon(n, s, ir, p(,)) !n=角数, s=底辺/2, ir=内接円半径, p(,)=頂点座標 LET a=PI/n LET r=s/SIN(a) LET ir=r*COS(a) FOR i=1 TO n LET p(i,1)=r*COS((2*i-1)*a-PI/2) LET p(i,2)=r*SIN((2*i-1)*a-PI/2) NEXT i END SUB MAT rotx=IDN MAT rotx2=IDN LET Vi(4)=1 ! MAT Axys=IDN LET Ax=-PI/3 !開始の常時回転軸( 画面垂直からのｘ軸回転) LET opA=0.3 !回転体開度の振幅 LET opS=0.95 !回転体開度のバイアス LET t0=TIME DO SET DRAW mode hidden CLEAR PLOT label,AT 0, 1.52:"左 click 一時停止、drag 手動回転。右 click 展開図。" LET sq=0 LET sq0=0 SELECT CASE s CASE 0 TO 1 LET item=1 CALL control_ CALL mat_rotx(rotx, op1*PI/4.305) !３２面体　　残部６角～残部６角折り角 CALL mat_rotx(rotx2, op1*PI/4.815) !　　　　　切頭部５角～残部６角折り角 DRAW D32 WITH ROTATE(Az)*shxyz*Axys IF s=0 THEN CALL priority(2) ELSE CALL priority(7) CASE 2 LET item=2 CALL control_ CALL mat_rotx(rotx, op1*PI/4.305) !正２０面体　３角～３角折り角 DRAW D20 WITH ROTATE(Az)*shxyz*Axys CALL priority(2) CASE 3 LET item=3 CALL control_ CALL mat_rotx(rotx, op1*PI/2.8376) !正１２面体　５角～５角折り角 DRAW D12 WITH SCALE(1.9)*ROTATE(Az)*shxyz*Axys CALL priority(2) CASE 4 LET item=4 CALL control_ CALL mat_rotx(rotx, op1*PI/2.552) !正８面体　　３角～３角折り角 DRAW D20 WITH SCALE(1.4)*ROTATE(Az)*shxyz*Axys CALL priority(2) CASE 5 LET item=5 CALL control_ CALL mat_rotx(rotx, op1*PI/2) !正６面体　　４角～４角折り角 DRAW D06 WITH ROTATE(Az)*shxyz*Axys CALL priority(2) CASE 6 LET item=6 CALL control_ CALL mat_rotx(rotx, op1*PI/1.644) !正４面体　　３角～３角折り角 DRAW D20 WITH SCALE(1.5)*ROTATE(Az)*shxyz*Axys CALL priority(2) END SELECT SET DRAW mode explicit !---------------------- IF mlb=0 AND DEL=0 THEN LET Az=Az-PI/64 LET sx=sx+PI/48 IF 2*PI<=sx THEN LET sx=0 LET s=MOD(s+1, 7) LET flt=0 END IF LET op1=MIN(MAX( opA*COS(sx)+opS ,0),1) ELSEIF mlb=1 THEN LET DEL=7 !「左 click 一時停止」解除から再開までの遅延回数 ELSE LET DEL=DEL-1 END IF !-------------------- IF msk(item,0)=0 THEN !各item は初回、標準折り角 op1=1 で採取画位置を → msk(item,1~sq0) LET msk(item,0)=1 !← 完了マーク。以降 msk(,) をマスクにして画を取捨。 MAT Axys=Abak END IF !----------- LET bmrb=mrb mouse poll mx,my,mlb,mrb !------------ WAIT DELAY t2 !t2:制御出力の、休止秒。 LET t1=TIME !t1:前の周期の終り。※TIME は約.05秒毎の、更新。P3-500MHz 98SE IF t1< t0 THEN LET t0=t0-86400 LET t2=t2+(.08-t1+t0)/20 !設定周期.08秒－検出周期(t1-t0)＝偏差 →t2( 積分 Gain=1/20 ) ! PRINT USING"#.### #.###":t2,t1-t0 !t2:制御_休止秒, t1-t0:検出周期。---debug LET t0=t1 !t0:次の周期の始め＝前の周期の終り !--------------debug--- IF sqb<>sq THEN PRINT USING"## ### #.###":sq,sq0,t2 !sq:採取画数, sq0:写像_全画数, t2:制御_休止秒 LET sqb=sq END IF LOOP UNTIL opAbak>0 AND bmrb=0 AND mrb=1 SUB flatx(s0,za,x0,y0,hw) IF s=s0 THEN IF opAbak=0 THEN SET WINDOW x0-hw,x0+hw,y0-hw,y0+hw LET opAbak=opA LET opSbak=opS LET opA=.525 !平面図開度の振幅 LET opS=.475 !平面図開度のバイアス MAT Abak=Axys !LET sx=0 END IF MAT Axys=IDN LET Az=za DRAW grid WITH ROTATE(Az) PLOT label,AT x0-.48*hw, y0+.95*hw:"左 click 一時停止。右 click 終了。" END IF END SUB SUB control_ IF flt=1 THEN CALL flatx( 0,-PI/6, -.57,-1.5, 2.4) !(s0,za,x0,y0,hw) !32 平面展開図セットアップ CALL flatx( 1,-PI/6, -.57,-1.5, 2.4) !(s0,za,x0,y0,hw) !32 　　〃 CALL flatx( 2, PI/12, -1.28,-1.98, 2.9) !(s0,za,x0,y0,hw) !20 　　〃 CALL flatx( 3, PI/.78, -2.06,-2.32, 2.95) !(s0,za,x0,y0,hw) !12 　　〃 CALL flatx( 4,-PI/1.71,-1.43,-1.42, 2.3) !(s0,za,x0,y0,hw) ! 8 　　〃 CALL flatx( 5,-PI/2, -1.5,-1.0, 2.1) !(s0,za,x0,y0,hw) ! 6 　　〃 CALL flatx( 6,-PI/1.17, -.91,-.688, 1.7) !(s0,za,x0,y0,hw) ! 4 　　〃 EXIT SUB ELSEIF 0< opAbak THEN SET WINDOW -1.5, 1.5, -1.4, 1.6 LET opA=opAbak LET opS=opSbak MAT Axys=Abak LET opAbak=0 END IF IF msk(item,0)=0 THEN !-----initial setup MAT Abak=Axys MAT Axys=IDN MAT shxyz=IDN LET op1=1 !各item 初回を、op1=1 (標準折り角)に強制。 ELSE IF bmrb=0 AND mrb=1 THEN !平面図の開始 (右クリックの Leading Edge.) LET flt=1 LET sx=0 EXIT SUB END IF !-----click_drag----- CALL mat_shxyz( cg(item,1),cg(item,2),cg(item,3)) !重心を原点へ移動する行列 shxyz 作成 IF mlb=1 THEN LET Ax= -(my-mybak)*PI/2 !ドラッグ方向から、軸方向と回転量 LET Ay= +(mx-mxbak)*PI/2 END IF LET mxbak=mx LET mybak=my !----- LET ar0=SQR(Ax^2+Ay^2) !回転の角度(∝マウス・ドラッグの長さ) IF ar0<>0 THEN LET DIRar0=ANGLE(Ax,Ay) !軸の角度 CALL mat_rotx(rotx, ar0) MAT Axys=Axys*ROTATE(-DIRar0)*rotx*ROTATE(DIRar0) !ドラッグ累積 (方向,回転) LET Ax=0 LET Ay=0 END IF !with ～～*shxyz*Axys の順序で使用。 END IF END SUB SUB priority( flg) !paint flg( 7= 5_6_mono, Others= color) IF msk(item,0)=0 THEN !-----initial setup CALL centerG !初回は、多面体重心計算のみ、描画なし。 ELSE FOR j=1 TO sq !z 最小(奥) から描く。 LET z=1e9 FOR i=1 TO sq IF D3(i,0,3)< z THEN LET z=D3(i,0,3) LET ib=i END IF NEXT i LET D3(ib,0,3)=1e9 IF flg=7 THEN LET c=6-D3(ib,7,1) ELSE LET c=ib+1 !サッカーボール(flg=7)、５角(c=1),６角(c=0) SET AREA COLOR c !各面の色 ASK COLOR MIX(c) r,g,b IF .3*r+.59*g+.11*b< .5 THEN SET TEXT COLOR 0 ELSE SET TEXT COLOR 1 !明るさに対比する文字色 FOR i=1 TO D3(ib,7,1) LET D1(i,1)=D3(ib,i,1) LET D1(i,2)=D3(ib,i,2) NEXT i LET D1(i,1)=D3(ib,1,1) LET D1(i,2)=D3(ib,1,2) MAT PLOT AREA ,LIMIT i:D1 MAT PLOT LINES ,LIMIT i:D1 PLOT label,AT D3(ib,0,1),D3(ib,0,2):STR$(ib) NEXT j SET TEXT COLOR 1 END IF END SUB SUB centerG !cg(item,1~3) …各多面体の重心座標(x,y,z) LET cg(item,1)=0 LET cg(item,2)=0 LET cg(item,3)=0 FOR i=1 TO sq LET cg(item,1)=cg(item,1)+D3(i,0,1) !D3(i,0,1~3) …各面の重心座標(x,y,z) LET cg(item,2)=cg(item,2)+D3(i,0,2) LET cg(item,3)=cg(item,3)+D3(i,0,3) NEXT i LET cg(item,1)=cg(item,1)/sq LET cg(item,2)=cg(item,2)/sq LET cg(item,3)=cg(item,3)/sq END SUB PICTURE getpos(n, p(,)) !return with ･･･採取画 msk(item,sq0)=1, 重複画 msk(item,sq0)=0 LET sq0=sq0+1 !呼出し順番 IF msk(item,0)=1 AND msk(item,sq0)=0 THEN EXIT PICTURE LET sq=sq+1 !採取画順番 MAT m=TRANSFORM FOR j=0 TO n !各面の、0=重心 1~n=頂点 LET Vi(1)=p(j,1) LET Vi(2)=p(j,2) MAT Vo=Vi*m LET D3(sq,j,1)=Vo(1) LET D3(sq,j,2)=Vo(2) LET D3(sq,j,3)=Vo(3) NEXT j LET D3(sq,7,1)=n IF msk(item,0)=1 THEN EXIT PICTURE FOR i=1 TO sq-1 IF (D3(i,0,1)-D3(sq,0,1))^2+(D3(i,0,2)-D3(sq,0,2))^2+(D3(i,0,3)-D3(sq,0,3))^2< .05 THEN EXIT FOR NEXT i IF sq<=i THEN LET msk(item,sq0)=1 ELSE LET sq=sq-1 !採取画位置の記憶と、重複画の除去 END PICTURE PICTURE D32 DRAW getpos(6, p6) !　基６角 IF msk(item,sq0)=0 THEN EXIT PICTURE DRAW getpos(5, p5) WITH SHIFT(0,ir5)*rotx2*SHIFT(0,ir6) !　上５角 IF msk(item,sq0)=0 THEN EXIT PICTURE DRAW getpos(5, p5) WITH SHIFT(0,ir5)*rotx2*SHIFT(0,ir6)*ROTATE(-PI*2/3) !右下５角 DRAW D32 WITH SHIFT(0,ir6)*rotx*SHIFT(0,ir6)*ROTATE(-PI/3) !右上６角 DRAW D32 WITH SHIFT(0,ir6)*rotx*SHIFT(0,ir6)*ROTATE(PI/3) !左上６角 END PICTURE PICTURE D20 DRAW getpos(3, p3) !　基３角 IF msk(item,sq0)=0 THEN EXIT PICTURE DRAW D20 WITH SHIFT(0,ir3)*rotx*SHIFT(0,ir3)*ROTATE(-PI/3) !右上３角 DRAW D20 WITH SHIFT(0,ir3)*rotx*SHIFT(0,ir3)*ROTATE(PI/3) !左上３角 END PICTURE PICTURE D12 DRAW getpos(5, p5) !　基５角 IF msk(item,sq0)=0 THEN EXIT PICTURE DRAW D12 WITH SHIFT(0,ir5)*rotx*SHIFT(0,ir5)*ROTATE(-.2*PI) !右上５角 DRAW D12 WITH SHIFT(0,ir5)*rotx*SHIFT(0,ir5)*ROTATE(.2*PI) !左上５角 DRAW D12 WITH SHIFT(0,ir5)*rotx*SHIFT(0,ir5)*ROTATE(-.6*PI) !右下５角 END PICTURE PICTURE D06 DRAW getpos(4, p4) !　基４角 IF msk(item,sq0)=0 THEN EXIT PICTURE DRAW D06 WITH SHIFT(0,ir4)*rotx*SHIFT(0,ir4)*ROTATE(-PI/2) !　右４角 DRAW D06 WITH SHIFT(0,ir4)*rotx*SHIFT(0,ir4) !　上４角 END PICTURE !--------------------------------- ! ｘ軸で回転する行列 → 配列引数 !(x,y,z,1)| 1, 0, 0, 0 | ! | 0, cos(a), sin(a), 0 | ! | 0,-sin(a), cos(a), 0 | ! | 0, 0, 0, 1 | !--------------------------------- SUB mat_rotx(m(,), a) LET m(2,2)=COS(a) LET m(3,2)=-SIN(a) LET m(2,3)=SIN(a) LET m(3,3)=COS(a) !他の要素は、呼出し側で管理 END SUB !----------------------------- ! 平行移動。(sx,sy,sz) → 原点 !(x,y,z,1)| 1, 0, 0, 0 | ! | 0, 1, 0, 0 | ! | 0, 0, 1, 0 | ! | -sx,-sy,-sz, 1 | !----------------------------- SUB mat_shxyz( sx,sy,sz) LET shxyz(4,1)=-sx LET shxyz(4,2)=-sy LET shxyz(4,3)=-sz !他の要素は、呼出し側で管理 END SUB END

行を揃えるには？

投稿者：西岡省吾

投稿日：2011年10月22日(土)06時29分38秒

RESTORE LET P=0 LET R=0 LET x=3 5 LET P=P+1 LET R=R+1 READ A$ IF LEFT$(A$,1)="x" THEN LET p=p-1 IF left$(A$,1)="v" THEN LET p=p-1 IF left$(A$,1)="l" THEN LET p=p-1 IF left$(a$,1)="x" THEN LET x=x+1 IF left$(a$,1)="v" THEN LET v=v+1 IF left$(A$,1)="l" THEN LET l=l+1 PRINT a$; 8 INPUT b$ IF B$=a$ THEN PRINT p;a$;r;x IF INT(p/10)=p/10 AND b$=a$ THEN GOTO 30 IF b$=a$ THEN GOTO 10 IF b$<>a$ THEN GOTO 23 10 beep 3000.3000,70 GOTO 5 13 DATA migiasi,katahaba,zenkutu,kabenite,ryoutewokunde,atamanousiro,migitenohiji,migiasiosiri,hidariasiwomata,nekkorogatte3 DATA migiasiwoonaka,ryouasinoura,ara-,udetate,batu,migitekubi,migiasiwo,tewokunde,katano,kubino 23 beep 3000.4000,200 24 beep 300.4000,200 25 beep 3000.4000,200 GOTO 8 30 beep 3000.4000,1000 GOTO 5 END

線積分について

投稿者：永野護投稿日：2011年10月22日(土)13時55分42秒

十進BASICとは直接は関係ないのですが、質問させてください。ベクトル解析の話ですが、被積分関数をz=f(x,y)=x+y,積分路をy=x^2(0=<x=<1),としたとき線積分∫（x+y)dsの値はいくらになるのでしょうか。

Re: 行を揃えるには？

投稿者：白石和夫投稿日：2011年10月22日(土)16時05分16秒

> No.1681[元記事へ] 行番号には同じ桁数の整数のみを用いる，最初の行，END行にも行番号を付加しておくことが有効です。また，オプションメニュー－自動修正の「インデント」のチェックを外して，自力でインデントを管理するのも有効です。ただし，GOTO文の使用が不可避でないかぎり行番号を使わないのがおそらく最善の策です。たとえば， RESTORE LET P=0 LET R=0 LET x=3 DO LET P=P+1 LET R=R+1 READ A$ IF LEFT$(A$,1)="x" THEN LET p=p-1 IF left$(A$,1)="v" THEN LET p=p-1 IF left$(A$,1)="l" THEN LET p=p-1 IF left$(a$,1)="x" THEN LET x=x+1 IF left$(a$,1)="v" THEN LET v=v+1 IF left$(A$,1)="l" THEN LET l=l+1 PRINT a$; DO INPUT b$ IF B$=a$ THEN PRINT p;a$;r;x IF INT(p/10)=p/10 THEN beep 3000.4000,1000 ELSE beep 3000.3000,70 END IF EXIT DO END IF beep 3000.4000,200 beep 300.4000,200 beep 3000.4000,200 LOOP LOOP DATA migiasi,katahaba,zenkutu,kabenite,ryoutewokunde,atamanousiro,migitenohiji,migiasiosiri,hidariasiwomata,nekkorogatte3 DATA migiasiwoonaka,ryouasinoura,ara-,udetate,batu,migitekubi,migiasiwo,tewokunde,katano,kubino END

Re: 線積分について

投稿者：白石和夫投稿日：2011年10月24日(月)08時12分26秒

> No.1682[元記事へ] > 被積分関数をz=f(x,y)=x+y,積分路をy=x^2(0=<x=<1),としたとき > 線積分∫（x+y)dsの値はいくらになるのでしょうか。 xの区間[0,1]を1000000等分し，区間の中央でのf(x,y)の値を用いて近似すると， 100 DEF f(x,y)=x+y 110 DEF g(x)=x^2 120 LET t=0 130 LET dx=1/1000000 140 FOR x=0 TO 1-dx STEP dx 150 LET dy=g(x+dx)-g(x) 160 LET ds=SQR(dx^2 + dy^2) 170 LET t=t+f(x+dx/2,g(x+dx/2))*ds 180 NEXT x 190 PRINT t 200 END

線積分について

投稿者：永野護投稿日：2011年10月24日(月)10時33分53秒

数値積分のプログラムありがとうございました。お忙しいところ、お手数をおかけしました。敬具

お願い

投稿者：リアス投稿日：2011年10月25日(火)22時25分0秒

点数０～１００を入力して、その成績を評価するプログラムを作成してくれませんか？例　優　80点以上100点以下　良　70点以上79点以下　可　60点以上69点以下不可　59点以下

Re: お願い

投稿者：山中和義投稿日：2011年10月26日(水)08時46分58秒

> No.1686[元記事へ] リアスさんへのお返事です。 > 点数０～１００を入力して、その成績を評価するプログラムを作成してくれませんか？ > 例 > 　優　80点以上100点以下 > 　良　70点以上79点以下 > 　可　60点以上69点以下 > 不可　59点以下 INPUT PROMPT "得点を入力してください。": P IF P>=80 THEN PRINT "優" ELSEIF P>=70 THEN PRINT "良" ELSEIF P>=60 THEN PRINT "可" ELSE PRINT "不可" END IF END

感謝

投稿者：リアス投稿日：2011年10月26日(水)12時12分38秒

お忙しいところ、お手数をおかけしました。ありがとうございました。

Re: 作図サブルーチン集（2次関数とグラフ）追加

投稿者：山中和義投稿日：2011年10月29日(土)19時29分43秒

> No.1674[元記事へ] !図形と方程式 SET WINDOW -8,8,-8,8 !表示領域を設定する　※ DRAW grid !XY座標 PUBLIC NUMERIC cEps !精度　※調整が必要である LET cEPS=1E-8 PUBLIC NUMERIC cINF !∞ LET cINF=999999 PUBLIC NUMERIC gcCOLOR,gcSTYLE,gcLINESTYLE !描画色、線種 LET gcCOLOR=1 LET gcLINESTYLE=1 !------------------------------ ここまでがサブルーチン DIM L(5),M(5),N(5) !作業用 DIM xx(8),yy(8) !●3点を通る LET gcCOLOR=4 LET x1=-4 !1点目 LET y1=0 LET x2=1 !2点目 LET y2=-2 LET x3=2 !3点目 LET y3=2 CALL gcDRAWPOINT(x1,y1,"") !点1を描く CALL gcDRAWPOINT(x2,y2,"") !点2 CALL gcDRAWPOINT(x3,y3,"") !点3 CALL gcFNC2P3(x1,y1,x2,y2,x3,y3, A,B,C) CALL gcDRAWFNC2(A,B,C,-cINF,cINF) !2次関数を描く END !↓↓↓↓↓※※※※※　ここに前出のサブルーチンの抜粋部分 !作図ツール（Geometric Constructor） !図形と方程式 !　点 (x,y) !　直線 Lx+My+N=0 !　円 x^2+y^2+Ax+By+C=0 ! !　角度の単位は度、反時計まわりが正とする。 !作図ルーチン EXTERNAL SUB gcDRAWPOINT(x,y,s$) !点(x,y)を描く ASK WINDOW x1,x2,y1,y2 SET AREA COLOR gcCOLOR DRAW disk WITH SCALE(0.1)*SHIFT(x,y) !※拡大率0.1は調整が必要である IF s$<>"" THEN PLOT TEXT ,AT x,y: s$ END SUB EXTERNAL SUB gcDRAWLINE(L,M,N,s$,o) !直線Lx+My+N=0を描く IF (L=0 AND M=0) THEN PRINT "L=M=0なので、直線が成立しません。"; L;M;N ELSE ASK WINDOW x1,x2,y1,y2 SET LINE COLOR gcCOLOR SET LINE STYLE gcLINESTYLE IF ABS(L)>ABS(M) THEN !y=±xの傾きより大きいなら　※y軸に平行な直線を含む PLOT LINES: -(M*y1+N)/L,y1; -(M*y2+N)/L,y2 ELSE PLOT LINES: x1,-(L*x1+N)/M; x2,-(L*x2+N)/M END IF IF s$<>"" THEN !注釈 IF M=0 THEN !y軸に平行なら LET x=-N/L !x切片 LET y=0 ELSEIF L=0 THEN !x軸に平行なら LET x=0 !y切片 LET y=-N/M ELSE !x軸とy軸の両方と交差するなら（いわゆる斜めの直線） SELECT CASE o !記入位置 CASE 0 !y切片 LET x=0 LET y=-N/M CASE 1 !x切片 LET x=-N/L LET y=0 CASE 2 !x切片とy切片との中点 LET x=-N/L*0.5 LET y=-N/M*0.5 CASE ELSE END SELECT END IF PLOT TEXT ,AT x,y: s$ END IF END IF END SUB EXTERNAL SUB gcDRAWCIRCLE(A,B,C,s$,o) !円x^2+y^2+Ax+By+C=0を描く LET RR=(A^2+B^2)/4-C !判別式 IF RR>=0 THEN SET LINE COLOR gcCOLOR SET LINE STYLE gcLINESTYLE LET CX=-A/2 !中心 LET CY=-B/2 LET R=SQR(RR) !半径 FOR i=0 TO 360 !(x-CX)^2+(y-CY)^2=R^2として描く PLOT LINES: R*COS(RAD(i))+CX,R*SIN(RAD(i))+CY; NEXT i PLOT LINES IF s$<>"" THEN !注釈 SELECT CASE o !記入位置 CASE 0 !右 LET x=CX+R LET y=CY CASE 1 !上 LET x=CX LET y=CY+R CASE 2 !右上 LET x=R*SQR(2)/2+CX !45度 LET y=R*SQR(2)/2+CY CASE ELSE END SELECT PLOT TEXT ,AT x,y: s$ END IF ELSE PRINT "半径が負なので、円が成立しません。"; A;B;C END IF END SUB !補助ルーチン EXTERNAL FUNCTION DIST(x1,y1,x2,y2) !2点(x1,y1),(x2,y2)間の距離 LET DIST=SQR((x1-x2)^2+(y1-y2)^2) END FUNCTION !点(x,y)と直線Lx+My+N=0との距離（点から直線へ下した垂線の長さ） EXTERNAL FUNCTION DIST1L(x,y,L,M,N) LET DIST1L=ABS(L*x+M*y+N)/SQR(L^2+M^2) END FUNCTION EXTERNAL SUB Solve2Equ(a,b,c, x1,x2,K) !2次方程式ax^2+bx+c=0を解く IF a=0 THEN PRINT "2次の係数が0なので、2次方程式ではありません。"; a;b;c LET K=0 ELSE LET D=b^2-4*a*c !判別式 IF D>=0 THEN !実数解なら LET x1=(-b+SQR(D))/(2*a) !1つの解 IF D=0 THEN !重解なら LET K=1 ELSE LET x2=(-b-SQR(D))/(2*a) !もう1つの解 LET K=2 END IF ELSE !虚数解なら LET K=0 END IF END IF END SUB !演算ルーチン !●点 !点A(x1,y1),B(x2,y2)を結ぶ線分ABをm:nに分ける点（内分・外分する点） EXTERNAL SUB gcDIVIDE(x1,y1,x2,y2,m,n, xx,yy) LET xx=(n*x1+m*x2)/(m+n) !※外分m:nは、m:(-n)となる LET yy=(n*y1+m*y2)/(m+n) END SUB !●直線 !2点(x1,y1), (x2,y2)を通る直線Lx+My+N=0 !公式　-(y2-y1)(x-x1)+(x2-x1)(y-y1)=0 より EXTERNAL SUB gcLINE(x1,y1,x2,y2, L,M,N) IF (x1=x2 AND y1=y2) THEN !同一点なら PRINT "異なる2点ではないので、直線が成立しません。"; x1;y1;x2;y2 ELSE LET L=y1-y2 LET M=x2-x1 LET N=x1*y2-y1*x2 END IF END SUB !↑↑↑↑↑※※※※※　ここに前出のサブルーチンの抜粋部分つづく

Re: 作図サブルーチン集（2次関数とグラフ）追加

投稿者：山中和義投稿日：2011年10月29日(土)19時31分12秒

> No.1689[元記事へ] !------------------------- オプション !2次関数 y=Ax^2+Bx+C（一般形） !作図ルーチン EXTERNAL SUB gcDRAWFNC2(A,B,C,d1,d2) !2次関数y=Ax^2+Bx+C、x=[d1,d2]を描く IF A=0 THEN PRINT "A=0なので、2次関数ではありません。"; A;B;C ELSE ASK WINDOW x1,x2,y1,y2 LET x1=MAX(x1,d1) LET x2=MIN(x2,d2) SET LINE COLOR gcCOLOR FOR x=x1 TO x2 STEP 1/2^8 !※折れ線による PLOT LINES: x,A*x^2+B*x+C; NEXT x PLOT LINES END IF END SUB !補助ルーチン EXTERNAL FUNCTION gcFNC2VAL(x,A,B,C) !2次関数Ax^2+Bx+Cの値 LET gcFNC2VAL=A*x^2+B*x+C END FUNCTION !演算ルーチン EXTERNAL SUB gcFNC2(aa,p,q, A,B,C) !標準形（基本形）　軸x=p、頂点(p,q)として、y=a(x-p)^2+q LET A=aa LET B=-2*aa*p LET C=aa*p^2+q END SUB EXTERNAL SUB gcFNC2F(aa,x1,x2, A,B,C) !因数分解形（分離形）　y=a(x-x1)(x-x2) LET A=aa LET B=-(x1+x2)*aa LET C=x1*x2*aa END SUB !3点A(x1,y1),B(x2,y2),C(x3,y3)を通る2次関数 !　点A,Bを通る直線は、y=(y2-y1)(x-x1)/(x2-x1)+y1なので、 !　点A,Bを通る2次関数は、y=k(x-x1)(x-x2)+(y2-y1)(x-x1)/(x2-x1)+y1とおける。 !　∵点(x1,0)、(x2,0)を通る2次関数は、y=k(x-x1)(x-x2)となる。 !　　これを平行移動させて、点(x1,y1)、(x2,y2)を通るようにしたものである。 !　点Cを通るので、代入して、kを求める。 EXTERNAL SUB gcFNC2P3(x1,y1,x2,y2,x3,y3, A,B,C) IF (x1=x2 AND y1=y2) OR (x2=x3 AND y2=y3) OR (x3=x1 AND y3=y1) THEN !同一点なら PRINT "異なる3点ではないので、2次関数が成立しません。"; x1;y1;x2;y2;x3;y3 ELSE LET k=( y3 -(y2-y1)*(x3-x1)/(x2-x1) -y1 )/( (x3-x1)*(x3-x2) ) LET A=k LET B=-k*(x1+x2)+(y2-y1)/(x2-x1) LET C=k*x1*x2-(y2-y1)*x1/(x2-x1)+y1 END IF END SUB !2次関数y=Ax^2+Bx+Cと直線Lx+My+N=0との交点 EXTERNAL SUB gcFNC2INTERSECTION(A,B,C,L,M,N, xx(),yy(),K) IF M=0 THEN !y軸に平行な直線 LET t=-N/L LET xx(1)=t LET yy(1)=A*t^2+B*t+C LET K=1 ELSE CALL Solve2Equ(A,B+L/M,C+N/M, x1,x2,K) IF K>0 THEN LET xx(1)=x1 LET yy(1)=-(L*x1+N)/M !直線の式に代入する IF K=2 THEN LET xx(2)=x2 LET yy(2)=-(L*x2+N)/M END IF END IF END IF END SUB !2次関数y=A1x^2+B1x+C1と2次関数y=A2x^2+B2x+C2との交点 EXTERNAL SUB gcFNC2INTERSECTION1F(A1,B1,C1,A2,B2,C2, xx(),yy(),K) IF A1=A2 AND B1=B2 THEN !軸上を平行移動したもの IF C1=C2 THEN PRINT "2次関数は同一なので、交点は2次関数そのものです。（無限個）"; A1;B1;C1A2;B2;C2 ELSE PRINT "交点なし" END IF LET K=0 ELSE !下に凸下に凸、下に凸上に凸、上に凸上に凸の場合 CALL Solve2Equ(A1-A2,B1-B2,C1-C2, x1,x2,K) IF K>0 THEN LET xx(1)=x1 LET yy(1)=gcFNC2VAL(x1,A1,B1,C1) !A1*x1^2+B1*x1+C1 IF K=2 THEN LET xx(2)=x2 LET yy(2)=gcFNC2VAL(x2,A1,B1,C1) !A1*x2^2+B1*x2+C2 END IF END IF END IF END SUB !2次関数y=Ax^2+Bx+Cと円x^2+y^2+Px+Qy+R=0との交点 EXTERNAL SUB gcFNC2INTERSECTION1C(A,B,C,P,Q,R, xx(),yy(),K) END SUB !2次関数y=Ax^2+Bx+C上の点(x,Ax^2+Bx+C)における接線 !　Y-y=f'(x)(X-x)より、Y-(Ax^2+Bx+C)=(2Ax+B)(X-x) EXTERNAL SUB gcFNC2TANGENTLINE(x0,y0,A,B,C, L,M,N) IF ABS(A*x0^2+B*x0+C-y0)>cEPS THEN PRINT "点は2次関数上にありません。"; x0;y0;A;B;C ELSE LET L=-(2*A*x0+B) LET M=1 LET N=A*x0^2-C END IF END SUB !点(x,y)から2次関数y=Ax^2+Bx+Cへの接線 !　y軸と平行な直線（x=p）ではないので、点(x,y)を通る傾きmの直線は、Y-y=m(X-x)とおける。 !　AX^2+BX+C=m(X-x)+y　∴AX^2+(B-m)X+(C+mx-y)=0　←式1 !　重根を持つので、判別式D=(B-m)^2-4A(C+mx-y)=0　∴m^2-(4Ax+2B)m+(B^2-4AC+4Ay)=0 !　mについての2次方程式を解く。2つの解をm1,m2とする。 !　m1={ (4Ax+2B) + √{(4Ax+2B)^2-4(B^2-4AC+4Ay)} }/2 !　　=(2Ax+B) + 2√{ A((A^2x^2+Bx+C) -y) } !　　=(2Ax+B)+2√(Ad)　ただし、d={(A^2x^2+Bx+C) -y}とする。 !　接点のX座標X1は、式1より、 !　 -(B-m1)/(2A) !　=-B/(2A)+m1/(2A) !　=-B/(2A)+{(2Ax+B)+2√(Ad)}/(2A) !　={-B+(2Ax+B)}/(2A)+√(d/A) !　=x+√(d/A) !　同様に、X2=x-√(d/A) EXTERNAL SUB gcFNC2TANGENTLINE1F(x,y,A,B,C, L(),M(),N(),K, xx(),yy(),K2) LET d=(A*x^2+B*x+C)-y !点と2次関数とのX=x上での符号付き距離 IF SGN(A)*d<0 THEN !点が下に凸なら上側、上に凸なら下側の場合 PRINT "接線なし" LET K=0 LET K2=0 ELSE LET t=SQR(ABS(d/A)) !√(d/A) LET xx(1)=x-SGN(A)*t !接点　※x座標が小さい方 LET yy(1)=gcFNC2VAL(xx(1),A,B,C) !A*xx(1)^2+B*xx(1)+C LET xx(2)=x+SGN(A)*t LET yy(2)=gcFNC2VAL(xx(2),A,B,C) !A*xx(2)^2+B*xx(2)+C LET K2=2 CALL gcLINE(x,y,xx(1),yy(1), L(1),M(1),N(1)) !接線 CALL gcLINE(x,y,xx(2),yy(2), L(2),M(2),N(2)) LET K=2 END IF END SUB !2次関数y=A1x^2+B1x+C1と2次関数y=A2x^2+B2x+C2との共通接線 !　2頂点及び共通接線の2接点を結ぶ線分を-A2:A1の比に分ける点は一致する !　y=A1(x+B1/(2A1))^2-(B1/(4A1))+C1 !　y=A2(x+B2/(2A2))^2-(B2/(4A2))+C2 EXTERNAL SUB gcFNC2TANGENTLINE2F(A1,B1,C1, A2,B2,C2, L(),M(),N(),K, xx(),yy(),K2) IF A1=A2 AND B1=B2 THEN !軸上を平行移動したもの IF C1=C2 THEN PRINT "2次関数は同一なので、共通接線は無限個です。"; A1;B1;C1A2;B2;C2 ELSE PRINT "共通接線なし" END IF LET K=0 LET K2=0 ELSEIF A1=A2 THEN !共に上に（下に）凸で、開きが同じなら LET m1=((A2*B1^2-A1*B2^2)-4*A1*A2*(C1-C2))/(2*(A2*B1-A1*B2)) !1次関数なので LET L(1)=-m1 LET M(1)=1 LET N(1)=(B1-m1)^2/(4*A1)-C1 !式1に代入 LET K=1 LET t=-(B1-m1)/(2*A1) !2次関数1の接点 LET xx(1)=t LET yy(1)=gcFNC2VAL(t,A1,B1,C1) !A1*t^2+B1*t+C1 LET t=-(B2-m1)/(2*A2) !2次関数2の接点 LET xx(2)=t LET yy(2)=gcFNC2VAL(t,A2,B2,C2) !A2*t^2+B2*t+C2 LET K2=2 ELSE LET x1=-B1/(2*A1) !頂点 LET y1=gcFNC2VAL(x1,A1,B1,C1) LET x2=-B2/(2*A2) !頂点 LET y2=gcFNC2VAL(x2,A2,B2,C2) CALL gcDIVIDE(x1,y1,x2,y2,-A2,A1,x,y) !2頂点を-A2:A1に外分する点 IF ABS( gcFNC2VAL(x,A1,B1,C1) )<=cEPS THEN ! !2次関数上の点なら（2次関数は接する） CALL gcFNC2TANGENTLINE(x,y,A1,B1,C1, LL,MM,NN) LET L(1)=LL LET M(1)=MM LET N(1)=NN LET K=1 FOR i=1 TO 2 !2次関数1,2の接点 LET xx(i)=x LET yy(i)=y NEXT i LET K2=2 ELSE DIM px(2),py(2) CALL gcFNC2TANGENTLINE1F(x,y,A1,B1,C1, L,M,N,K, px,py,K2) !2次関数1の接線と接点 IF K>0 THEN FOR i=1 TO K2 !copy it LET xx(2*i-1)=px(i) LET yy(2*i-1)=py(i) NEXT i CALL gcFNC2TANGENTLINE1F(x,y,A2,B2,C2, L,M,N,K, px,py,K3) !2次関数2の接線と接点 FOR i=1 TO K3 !copy it LET xx(2*i)=px(i) LET yy(2*i)=py(i) NEXT i LET K2=K2+K3 END IF END IF END IF END SUB !2次関数y=Ax^2+Bx+Cと円x^2+y^2+Px+Qy+R=0との共通接線 EXTERNAL SUB gcFNC2TANGENTLINE1C(A,B,C, P,Q,R, L(),M(),N(),K) END SUB

目の錯覚体験

投稿者：GAI 投稿日：2011年10月30日(日)13時11分59秒

テレビの番組で目の錯覚の特集があっていて、白と黒の長方形が上下に位置して、同じスピードで右から左へ移動している。それだけだと、上と下の長方形は目には同じ速さで滑らかに揃って移動していることが認識できる。これに背景に白と黒のストライプ（縦の帯が交互に並ぶ）の模様を付けたのを配置すると、そのときは前の白と黒の長方形を同じ条件で移動させて見ると、今度はそれぞれの長方形がぎくしゃくした動きをしているように見えてくる。また動きのスピードも異なっているように感じる。これを体験できるプログラムを作って頂きたいです。

Re: 目の錯覚体験

投稿者：山中和義投稿日：2011年10月30日(日)14時52分54秒

> No.1691[元記事へ] GAIさんへのお返事です。 ●サンプル LET W=800 !画面の大きさ LET H=300 SET bitmap SIZE W,H SET WINDOW 0,W-1,0,H-1 LET A=80 !長方形の横の長さ LET B=120 !縦 LET C=40 !縦の縞模様の幅 FOR t=0 TO W !左から右へ SET DRAW mode hidden !ちらつき防止開始 CLEAR SET AREA COLOR 1 FOR x=0 TO W STEP 2*C !縦の縞模様を描く　※左下が原点 PLOT AREA: x,0; x,H; x+C,H; x+C,0; x,0 NEXT x SET AREA COLOR 0 !白の長方形を描く LET y=H/4-B/2 PLOT AREA: t,y; t,y+B; t+A,y+B; t+A,y; t,y SET AREA COLOR 1 !黒の長方形を描く LET y=H*3/4-B/2 PLOT AREA: t,y; t,y+B; t+A,y+B; t+A,y; t,y SET DRAW mode explicit !ちらつき防止終了 !!!WAIT DELAY 0.1 NEXT t END

Ｎ角形の Simson Line（シムソン線）

投稿者：SECOND 投稿日：2011年11月 3日(木)15時50分10秒

!Ｎ角形の Simson Line（シムソン線）　Ver7.5.4 以降で動きます。 !定理（シムソン）円に内接する三角形 ABC 、同円周上に点Ｐ。 ! ＿BC ＿CA ＿AB 各辺の線（３本）へ !点Ｐから引いた垂線の交点（３個）は、同一直線上にある。 !この直線を、点Ｐの三角形 ABC に対するシムソン線。 !定理（四角形）　円に内接する四角形 ABCD 、同円周上に点Ｐ。 !点Ｐの △BCD △ACD △ABD △ABC に対するシムソン線（４本）へ !点Ｐから引いた垂線の交点（４個）は、同一直線上にある。 !この直線を、点Ｐの四角形 ABCD に対するシムソン線。 !定理（五角形）　円に内接する五角形 ABCDE 、同円周上に点Ｐ。 !点Ｐの □BCDE □ACDE □ABDE □ABCE □ABCD に対するシムソン線（５本）へ !点Ｐから引いた垂線の交点（５個）は、同一直線上にある。 !この直線を、点Ｐの五角形 ABCDE に対するシムソン線。 !---------------------------------------------------------- !　　（Ｎ角形）　円に内接するＮ角形、同円周上に点Ｐ。 !点Ｐの (Ｎ-1)角形 *Ｎ個に対するシムソン線（Ｎ本）へ !点Ｐから引いた垂線の交点（Ｎ個）は、同一直線上にある？？ !この直線を、点ＰのＮ角形に対するシムソン線？？ !---------------------------------------------------------- ! k 角形での Simson Line の本数Ｓk ! k=3 k=4 k=5 k=6 k=7 ... k=n ! Ｓ3=1 Ｓ4=4*Ｓ3+1=5 Ｓ5=5*Ｓ4+1=26 Ｓ6=6*Ｓ5+1=157 Ｓ7=7*Ｓ6+1=1100 ... Ｓn= n*Ｓn-1 +1 !Ｎ角について、実際のグラフを描く。が、８角形位から、画面がパンクぎみで、 !N=11 で止めてある。（必要なら、注釈マーク ※N ※N-1 の個所で変える） !------------------------ OPTION ARITHMETIC COMPLEX SET BEAM MODE "IMMORTAL" LET N=11 !※N DIM p(N), px(N) ! PRINT "シムソン線の直線性検査" PRINT "線上の交点(1,2,3,4,…)間ベクトルの、" PRINT "絶対値積／内積。" PRINT "|3-2||2-1|/(3-2・2-1)　|4-3||3-2|/(4-3・3-2)　…" SET TEXT COLOR "red" RANDOMIZE FOR K0=3 TO N ! ---make sample LET P0=EXP(COMPLEX(0, RND*2*PI) ) !Ｐ点サンプル作成 P0 FOR i=1 TO K0 !K0角形サンプル作成 p() IF i=1 THEN LET b0=.3/K0 LET b=0 ELSE LET w=(1-b)/(K0-i+2) DO LET a=RND LOOP UNTIL .7*w< a AND a< 1.4*w LET b=b+a END IF LET p(i)=EXP(COMPLEX(0, (b0+b)*2*PI+arg(P0)) ) NEXT i !---start with whole view CALL s_main(0, 1.5) !(画面中心, 半幅) !---checking simson px() on the straight PRINT K0;"角形: "; FOR i=3 TO K0 PRINT ABS(px(i)-px(i-1))*ABS(px(i-1)-px(i-2))/DOTc( px(i)-px(i-1), px(i-1)-px(i-2) ); NEXT i PRINT !---repeat with zoom up IF 4< K0 THEN LET w$=CONFIRM$("次は､同"& STR$(K0)& "角形のズームアップ") IF w$="NO" THEN STOP CALL s_main((px(1)+px(K0))/2, ABS(px(K0)-px(1))) !(画面中心, 半幅) END IF !---how to start next K0+1? IF K0< N THEN LET w$=CONFIRM$("次は､"& STR$(K0+1)& "角形") IF w$="NO" THEN STOP END IF NEXT K0 SUB s_main(c,hw) SET WINDOW re(c)-hw, re(c)+hw ,im(c)-hw ,im(c)+hw !zooming CLEAR SET LINE COLOR "black" DRAW circle !円周　、描画 CALL GRAPH_p(K0, p) !K0角形、描画 CALL simson(K0, p,px) !シムソン線、描画 !--- SET POINT COLOR "red" SET POINT STYLE 6 PLOT POINTS: P0 !P0点、描画 PLOT label ,AT P0:"P" END SUB SUB simson(K, p(),px()) !( 角数 K, K角形 p(), →シムソン線 px() ) local i, s(10),sx(10) !※N-1 !s(K-1),sx(K-1)の使用量だが、副プログラムでの変数は×。手書き！ !--- FOR i=1 TO K !K角形 p()の下の、(K-1)角形 s()を、K通り作成 ! --- FOR j=1 TO i-1 !ｉ番目頂点の抜けた(K-1)角形 s()を、１個作成。 LET s(j)=p(j) NEXT j FOR j=i+1 TO K LET s(j-1)=p(j) NEXT j !--- IF K=3 THEN !※K角形 p()が３角の時、i番目の２角形 s()の扱い。(形態は線分) LET sx(1)=s(1) !　それに対する P0点からの垂線は２本とも s()自身に交わるため、 LET sx(2)=s(2) ! ２角形 s()に対するシムソン線 sx()は、自身 s()に重なるとする。 ELSE ! ２角形を考える事で、３角も、Ｎ角の連続として扱える。 CALL simson(K-1, s,sx) !i番目の(K-1)角形 s()に対するシムソン線 sx()を自己呼出しで採取。 CALL GRAPH_p(K-1, s) !i番目の(K-1)角形 s() の描画。 END IF !--- !(K-1)角形 s()に対するシムソン線 sx()は、その下の、 ! ! 角形 s()に対するシムソン線への(K-1)個の垂線交点の配列。 LET px(i)=pxab(P0, sx(1),sx(K-1)) !px(i)= P0点から sx(1)~sx(K-1)線に引く１個の垂線交点。 PLOT LINES: P0;px(i) ! P0点から sx(1)~sx(K-1)線に引く１個の垂線の描画。 !--- IF 0< DOTc(px(i)-sx(1), px(i)-sx(K-1)) THEN !交点px(i)が sx(1)~sx(K-1)線の延長上なら破線の描画。 SET LINE STYLE 3 IF ABS(px(i)-sx(1))< ABS(px(i)-sx(K-1)) THEN PLOT LINES:px(i);sx(1) ELSE PLOT LINES:px(i);sx(K-1) SET LINE STYLE 1 END IF NEXT i CALL GRAPH_px(K, p,px) !K角形 p()についてのシムソン線 px()の描画 END SUB SUB GRAPH_px(K, p(),px()) SET LINE COLOR K0-K+1 SET POINT COLOR K0-K+1 !---simson line IF K=K0 THEN SET LINE width 2 SET POINT STYLE 7 ELSE SET LINE width 1 SET POINT STYLE 6 END IF FOR i=1 TO K !シムソン線 px()の描画。 IF 1< i THEN PLOT LINES: px(i-1);px(i) !交点間、px(i-1)~px(i)線 PLOT POINTS: px(i) !px(i)交点 IF K=K0 THEN PLOT label,AT px(i):STR$(i) !交点番号 NEXT i END SUB SUB GRAPH_p(K, p()) SET LINE COLOR K0-K+2 IF K=K0 THEN SET LINE width 2 FOR i=1 TO K !K角形 p()の描画。 PLOT LINES: p(i);p(MOD(i,K)+1) !頂点間、p(i)~p(i+1)線 IF K=K0 THEN PLOT label,AT p(i):CHR$(64+i) !頂点名、A,B,,, NEXT i SET LINE width 1 END SUB FUNCTION pxab(p, a, b) LET h1=(b-a)/ABS(b-a) !h1= a~b 線に平行な単位ベクトル (ａ→ｂ方向） LET n1=COMPLEX(-im(h1),re(h1)) !n1= a~b 線に垂直な単位ベクトル (ａ→ｂの左方向) LET pxab= DOTc( a-p, n1 )*n1 +p !pxab= p 点から a~b 線に引く垂線の交点 END FUNCTION DEF DOTc(a,b)=re(a)*re(b)+im(a)*im(b) !内積(a・b) …complex END

ASK PIXEL SIZE の不具合？

投稿者：日高投稿日：2011年11月 6日(日)11時13分15秒

画素数を取得する命令文 ASK PIXEL SIZE (x1,y1;x2,y2) a,b が、座標系によっては負の値を返します。 100 SET BITMAP SIZE 401,401 ! 110 SET WINDOW 0,1,0,1 120 CALL pixel ! 130 SET WINDOW 1,0,0,1 140 CALL pixel ! 150 SET WINDOW 0,1,30,10 160 CALL pixel ! 170 SET WINDOW 9,4,30,10 180 CALL pixel ! 190 SUB pixel 200 ASK WINDOW L,R,B,T 210 ASK PIXEL SIZE (L,B;R,T) w,h 220 PRINT w;h, 230 PLOT POINTS: L+(R-L)/4,B+(T-B)/4;L+(R-L)/2,B+(T-B)/2 240 ASK PIXEL SIZE (L+(R-L)/4,B+(T-B)/4;L+(R-L)/2,B+(T-B)/2) w,h 250 PRINT w;h, !描画領域の1/4の画素数 260 ASK PIXEL SIZE w,h !十進BASIC独自拡張 270 PRINT w;h 280 END SUB ! 290 END

Re: ASK PIXEL SIZE の不具合？

投稿者：白石和夫投稿日：2011年11月 6日(日)12時17分23秒

> No.1694[元記事へ] ご報告ありがとうございました。座標系の逆転を考えていなかったのは見落としでした。修正します。 SET WINDOW 4,0,4,0 ASK PIXEL SIZE (4,4;0,0) a,b PRINT a,b END

Re: ASK PIXEL SIZE の不具合？

投稿者：白石和夫投稿日：2011年11月 6日(日)15時12分49秒

> No.1695[元記事へ] 修正しました。他に（あるいは新たな）不具合を見つけたときはお知らせください。

Re: ASK PIXEL SIZE の不具合？

投稿者：日高投稿日：2011年11月 6日(日)22時11分58秒

白石和夫さんへのお返事です。早々にご対応いただきありがとうございます。十進BASICは仕事でも使わせていただいております。助かりました。 [参考] 今までの ASK PIXEL SIZE (x1,y1;x2,y2) a,b の値がほしい場合は、おそらく次の式で得られます。 LET a=PIXELX(MAX(x1,x2))-PIXELX(MIN(x1,x2))+1 LET b=PIXELY(MAX(y1,y2))-PIXELY(MIN(y1,y2))+1 [追加] 修正パッチとして次の２行を加筆すれば、新旧どちらのバージョンでも正しい値になります。自作プログラムの配布などでは、ぜひ加筆して配布を。 ASK PIXEL SIZE (x1,y1;x2,y2) a,b LET a=ABS(a-1)+1 LET b=ABS(b-1)+1

Re: ASK PIXEL SIZE の不具合？

投稿者：白石和夫投稿日：2011年11月 7日(月)16時47分10秒

> No.1696[元記事へ] BASICAccをお使いの方は，以下のファイルでSourceフォルダ内のファイルを上書き更新してください。 IEの場合は，右クリックして「対象をファイルに保存」を選択してください。

http://www.geocities.jp/thinking_math_education/BASICAcc_Fixes/graphlib.pas

くりぬき図形

投稿者：しばっち投稿日：2011年11月13日(日)19時57分48秒

くりぬき図形(シェルピンスキーのカーペット) !'ボクセル表現(VOXEL) LET L=6^4 INPUT PROMPT "LEVEL =":N !' LEVEL 3で146MB FILE GETSAVENAME F$,"dxfファイル|*.dxf" IF F$="" THEN STOP IF POS(UCASE$(F$),".DXF")=0 THEN LET F$=F$ & ".dxf" OPEN #1:NAME F$ ERASE #1 PRINT #1:"0" PRINT #1:"SECTION" PRINT #1:"2" PRINT #1:"ENTITIES" CALL RECURSIVE(N,X,Y,Z,L,#1) PRINT #1:"0" PRINT #1:"ENDSEC" PRINT #1:"0" PRINT #1:"EOF" CLOSE #1 END EXTERNAL SUB RECURSIVE(N,X,Y,Z,L,#1) IF N=0 THEN CALL CUBE(#1,X-L/3,Y+L/3,Z+L/3,L/3) CALL CUBE(#1,X, Y+L/3,Z+L/3,L/3) CALL CUBE(#1,X+L/3,Y+L/3,Z+L/3,L/3) CALL CUBE(#1,X-L/3,Y, Z+L/3,L/3) CALL CUBE(#1,X+L/3,Y, Z+L/3,L/3) CALL CUBE(#1,X-L/3,Y-L/3,Z+L/3,L/3) CALL CUBE(#1,X, Y-L/3,Z+L/3,L/3) CALL CUBE(#1,X+L/3,Y-L/3,Z+L/3,L/3) CALL CUBE(#1,X-L/3,Y+L/3,Z-L/3,L/3) CALL CUBE(#1,X, Y+L/3,Z-L/3,L/3) CALL CUBE(#1,X+L/3,Y+L/3,Z-L/3,L/3) CALL CUBE(#1,X-L/3,Y, Z-L/3,L/3) CALL CUBE(#1,X+L/3,Y, Z-L/3,L/3) CALL CUBE(#1,X-L/3,Y-L/3,Z-L/3,L/3) CALL CUBE(#1,X, Y-L/3,Z-L/3,L/3) CALL CUBE(#1,X+L/3,Y-L/3,Z-L/3,L/3) CALL CUBE(#1,X-L/3,Y+L/3,Z,L/3) CALL CUBE(#1,X+L/3,Y+L/3,Z,L/3) CALL CUBE(#1,X-L/3,Y-L/3,Z,L/3) CALL CUBE(#1,X+L/3,Y-L/3,Z,L/3) ELSE CALL RECURSIVE(N-1,X-L/3,Y+L/3,Z+L/3,L/3,#1) CALL RECURSIVE(N-1,X, Y+L/3,Z+L/3,L/3,#1) CALL RECURSIVE(N-1,X+L/3,Y+L/3,Z+L/3,L/3,#1) CALL RECURSIVE(N-1,X-L/3,Y, Z+L/3,L/3,#1) CALL RECURSIVE(N-1,X+L/3,Y, Z+L/3,L/3,#1) CALL RECURSIVE(N-1,X-L/3,Y-L/3,Z+L/3,L/3,#1) CALL RECURSIVE(N-1,X, Y-L/3,Z+L/3,L/3,#1) CALL RECURSIVE(N-1,X+L/3,Y-L/3,Z+L/3,L/3,#1) CALL RECURSIVE(N-1,X-L/3,Y+L/3,Z-L/3,L/3,#1) CALL RECURSIVE(N-1,X, Y+L/3,Z-L/3,L/3,#1) CALL RECURSIVE(N-1,X+L/3,Y+L/3,Z-L/3,L/3,#1) CALL RECURSIVE(N-1,X-L/3,Y, Z-L/3,L/3,#1) CALL RECURSIVE(N-1,X+L/3,Y, Z-L/3,L/3,#1) CALL RECURSIVE(N-1,X-L/3,Y-L/3,Z-L/3,L/3,#1) CALL RECURSIVE(N-1,X, Y-L/3,Z-L/3,L/3,#1) CALL RECURSIVE(N-1,X+L/3,Y-L/3,Z-L/3,L/3,#1) CALL RECURSIVE(N-1,X-L/3,Y+L/3,Z,L/3,#1) CALL RECURSIVE(N-1,X+L/3,Y+L/3,Z,L/3,#1) CALL RECURSIVE(N-1,X-L/3,Y-L/3,Z,L/3,#1) CALL RECURSIVE(N-1,X+L/3,Y-L/3,Z,L/3,#1) END IF END SUB 以下省略 EXTERNAL SUB CUBE(#1,X,Y,Z,L) END SUB http://6317.teacup.com/basic/bbs/1630 からコピペしてください

素数

投稿者：しばっち投稿日：2011年11月13日(日)19時58分37秒

素数を求める !'ボクセル表現(VOXEL) PUBLIC NUMERIC R OPTION BASE 0 DIM A(3) FILE GETSAVENAME F$,"dxfファイル|*.dxf" IF F$="" THEN STOP IF POS(UCASE$(F$),".DXF")=0 THEN LET F$=F$ & ".dxf" LET R=10 !'半径 OPEN #1:NAME F$ ERASE #1 PRINT #1:"0" PRINT #1:"SECTION" PRINT #1:"2" PRINT #1:"ENTITIES" FOR I=0 TO R FOR J=0 TO R FOR K=0 TO R IF ABS(I)+ABS(J)+ABS(K)>1 AND SQR(I*I+J*J+K*K)<=R THEN LET A(0)=I LET A(1)=J LET A(2)=K IF ISQUATERNIONPRIME(A)<>0 THEN CALL CUBE(#1,A(0),A(1),A(2),1) LET A(0)=-I LET A(1)=J LET A(2)=K IF ISQUATERNIONPRIME(A)<>0 THEN CALL CUBE(#1,A(0),A(1),A(2),1) LET A(0)=I LET A(1)=-J LET A(2)=K IF ISQUATERNIONPRIME(A)<>0 THEN CALL CUBE(#1,A(0),A(1),A(2),1) LET A(0)=I LET A(1)=J LET A(2)=-K IF ISQUATERNIONPRIME(A)<>0 THEN CALL CUBE(#1,A(0),A(1),A(2),1) LET A(0)=-I LET A(1)=-J LET A(2)=K IF ISQUATERNIONPRIME(A)<>0 THEN CALL CUBE(#1,A(0),A(1),A(2),1) LET A(0)=-I LET A(1)=J LET A(2)=-K IF ISQUATERNIONPRIME(A)<>0 THEN CALL CUBE(#1,A(0),A(1),A(2),1) LET A(0)=I LET A(1)=-J LET A(2)=-K IF ISQUATERNIONPRIME(A)<>0 THEN CALL CUBE(#1,A(0),A(1),A(2),1) LET A(0)=-I LET A(1)=-J LET A(2)=-K IF ISQUATERNIONPRIME(A)<>0 THEN CALL CUBE(#1,A(0),A(1),A(2),1) END IF NEXT K NEXT J NEXT I PRINT #1:"0" PRINT #1:"ENDSEC" PRINT #1:"0" PRINT #1:"EOF" CLOSE #1 END EXTERNAL FUNCTION ISQUATERNIONPRIME(A()) OPTION BASE 0 DIM B(3),S(3) LET ISQUATERNIONPRIME=0 FOR I=-R*1.5 TO R*1.5 !'探索範囲を広めに FOR J=-R*1.5 TO R*1.5 FOR K=-R*1.5 TO R*1.5 IF SQR(I*I+J*J+K*K)<=R AND ABS(I)+ABS(J)+ABS(K)>1 THEN LET B(0)=I LET B(1)=J LET B(2)=K CALL DIV(S,A,B) IF FRAC(S(0))=0 AND FRAC(S(1))=0 AND FRAC(S(2))=0 AND FRAC(S(3))=0 AND ABS(S(0))+ABS(S(1))+ABS(S(2))+ABS(S(3))>1 THEN EXIT FUNCTION END IF END IF NEXT K NEXT J NEXT I LET ISQUATERNIONPRIME=-1 END FUNCTION EXTERNAL FUNCTION FRAC(X) !'小数部 LET FRAC=X-INT(X) END FUNCTION EXTERNAL SUB MUL(S(),A(),B()) !'クォータニオン(4元数)掛算 OPTION BASE 0 DIM SS(3) LET SS(0)=A(0)*B(0)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3) LET SS(1)=A(0)*B(1)+A(1)*B(0)+A(2)*B(3)-A(3)*B(2) LET SS(2)=A(0)*B(2)-A(1)*B(3)+A(2)*B(0)+A(3)*B(1) LET SS(3)=A(0)*B(3)+A(1)*B(2)-A(2)*B(1)+A(3)*B(0) MAT S=SS END SUB EXTERNAL SUB DIV(S(),A(),B()) OPTION BASE 0 DIM BB(3) LET BB(0)=B(0) LET BB(1)=-B(1) LET BB(2)=-B(2) LET BB(3)=-B(3) CALL MUL(S,A,BB) MAT S=(1/(B(0)^2+B(1)^2+B(2)^2+B(3)^2))*S END SUB 以下省略 EXTERNAL SUB CUBE(#1,X,Y,Z,L) END SUB

波形表示

投稿者：しばっち投稿日：2011年11月13日(日)19時59分28秒

サンプル波形の表示 !'XSIZE/(SAMPLING/FREQ)=表示周期(3周期) LET XSIZE=600 CALL GINIT(XSIZE,400) SET WINDOW 0 , XSIZE-1 , -1.5,1.5 LET SAMPLING=8000 !'サンプリング周波数 LET FREQ=40 !'周波数 SET TEXT FONT "" , 18 FOR MODE=1 TO 7 FOR I=1 TO XSIZE LET X1=FREQ*(I-1)/SAMPLING*2*PI LET X2=FREQ*I/SAMPLING*2*PI LET Y1=SIN(X1) LET Y2=SIN(X2) CALL LINE(I-1,Y1,I,Y2,7) SELECT CASE MODE CASE 1 PLOT LABEL,AT XSIZE/2,1.3 : "のこぎり波" LET Y1=SAW(X1) LET Y2=SAW(X2) CALL LINE(I-1,Y1,I,Y2,4) CASE 2 PLOT LABEL,AT XSIZE/2,1.3 : "方形波" LET Y1=SQUAREW(X1) LET Y2=SQUAREW(X2) CALL LINE(I-1,Y1,I,Y2,6) CASE 3 PLOT LABEL,AT XSIZE/2,1.3 : "三角波" LET Y1=TRIANGLEW(X1) LET Y2=TRIANGLEW(X2) CALL LINE(I-1,Y1,I,Y2,5) CASE 4 PLOT LABEL,AT XSIZE/2,1.3 : "パルス波" LET Y1=PULSEW(X1) LET Y2=PULSEW(X2) CALL LINE(I-1,Y1,I,Y2,1) CASE 5 PLOT LABEL,AT XSIZE/2,1.3 : "台形波" LET Y1=TRAPEZOIDALW(X1) LET Y2=TRAPEZOIDALW(X2) CALL LINE(I-1,Y1,I,Y2,3) CASE 6 PLOT LABEL,AT XSIZE/2,1.3 : "階段状" LET Y1=STEPWISE(X1,4) LET Y2=STEPWISE(X2,4) CALL LINE(I-1,Y1,I,Y2,2) CASE 7 PLOT LABEL,AT XSIZE/2,1.3 : "ワイヤストラス" LET Y1=WEIERSTRASS(X1,15) LET Y2=WEIERSTRASS(X2,15) CALL LINE(I-1,Y1,I,Y2,8) END SELECT NEXT I WAIT DELAY 3 !'表示時間(秒) CLEAR NEXT MODE END EXTERNAL FUNCTION PULSEW(X) !'パルス波 PULSE WAVE IF ABS(ABS(SIN(X))-1)<.000001 THEN LET PULSEW=SGN(SIN(X)) ELSE LET PULSEW=0 END FUNCTION EXTERNAL FUNCTION SQUAREW(X) !'方形波 SQUARE WAVE LET SQUAREW=SGN(SIN(X)) END FUNCTION !'EXTERNAL FUNCTION SQUAREW(X,N) !'FOR I=1 TO N !' LET S=S+SIN((2*I-1)*X)/(2*I-1) !'NEXT I !'LET SQUAREW=S*4/PI !'END FUNCTION EXTERNAL FUNCTION TRIANGLEW(X) !'三角波 TRIANGLE WAVE LET NN=MOD(X,PI) IF NN>PI/2 THEN LET NN=PI-NN LET TRIANGLEW=NN/(PI/2)*SGN(SIN(X)) END FUNCTION !'EXTERNAL FUNCTION TRIANGLEW(X,N) !'FOR I=1 TO N !' LET S=S+SIN(I*PI/2)*SIN(I*X)/I/I !'NEXT I !'LET TRIANGLEW=S*8/PI/PI !'END FUNCTION EXTERNAL FUNCTION SAW(X) !'のこぎり波 LET SAW=MOD(X,PI)/(PI/2)-1 END FUNCTION !'EXTERNAL FUNCTION SAW(X,N) !'FOR I=1 TO N !' LET S=S+SIN(I*X)/I !'NEXT I !'LET SAW=S/(PI/2) !'END FUNCTION EXTERNAL FUNCTION TRAPEZOIDALW(X) !'台形波 TRAPEZOIDAL WAVE LET NN=X-INT(X/PI)*PI IF NN>PI/2 THEN LET NN=PI-NN LET TRAPEZOIDALW=MIN(1,MAX(-1,NN*SGN(SIN(X))) ) END FUNCTION !'EXTERNAL FUNCTION TRAPEZOIDALW(X,N) !'LET ALPHA=1 !'FOR I=1 TO N !' LET S=S+SIN((2*I-1)*ALPHA)/(2*I-1)^2*SIN((2*I-1)*X) !'NEXT I !'LET TRAPEZOIDALW=S*4/(ALPHA*PI) !'END FUNCTION EXTERNAL FUNCTION STEPWISE(X,NN) !'階段状 LET STEPWISE=INT(NN*SIN(X))/NN END FUNCTION EXTERNAL FUNCTION WEIERSTRASS(X,N) !'ワイヤストラス LET B=11 FOR I=0 TO N LET S=S+.5^(I+1)*SIN(B^I*X) NEXT I LET WEIERSTRASS=S END FUNCTION EXTERNAL SUB GINIT(XSIZE,YSIZE) SET BITMAP SIZE XSIZE,YSIZE 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 CLEAR END SUB EXTERNAL SUB LINE(XS,YS,XE,YE,C) SET COLOR C PLOT LINES PLOT LINES: XS,YS;XE,YE END SUB

波形生成

投稿者：しばっち投稿日：2011年11月13日(日)20時00分9秒

サンプル波形の生成 OPTION CHARACTER BYTE LET CHANNEL=1 !'モノラル LET SAMPLEBIT=16 !'ビット数 LET HEADERSIZE=16 LET WAVETYPE=1 !'LET PATH$="C:\WINDOWS\TEMP\" !'作業用フォルダ、RAMディスクなど DIM A$(7),FR(6),TYPE$(8) MAT READ A$ DATA "8kHz","11.25kHz","22.5kHz","32kHz","44.1kHz","48kHz","プログラム終了" MAT READ FR DATA 8000,11025,22050,32000,44100,48000 MAT READ TYPE$ DATA 正弦波,三角波,方形波,台形波,のこぎり波,階段状,パルス波,ワイヤストラス DO LOCATE CHOICE (A$):MODE IF MODE=7 THEN STOP LOCATE VALUE ,RANGE 0 TO FR(MODE)/2 ,AT 440 : FREQ SELECT CASE MODE !'サンプリング周波数 CASE 1 LET SAMPLINGFREQ=8000 CASE 2 LET SAMPLINGFREQ=11025 CASE 3 LET SAMPLINGFREQ=22050 CASE 4 LET SAMPLINGFREQ=32000 CASE 5 LET SAMPLINGFREQ=44100 CASE 6 LET SAMPLINGFREQ=48000 END SELECT LOCATE CHOICE (TYPE$):MODE LET SAMPLESIZE = SAMPLEBIT / 8 * CHANNEL LET DATARATE = SAMPLESIZE * SAMPLINGFREQ LET VOL=.1 !'音量 ※スピーカ破損の可能性あり。音量に気をつけること LET LEVEL=2^(SAMPLEBIT-1)*VOL LET SECOND=3 !'再生時間(3秒間) !' LOCATE VALUE ,RANGE 1 TO 10,AT 3 : SECOND LET PCMSIZE=INT(DATARATE*SECOND) LET WAVEFILESIZE = PCMSIZE + 36 OPEN #1:NAME PATH$ & TYPE$(MODE) & ".wav" ERASE #1 PRINT #1:"RIFF"; PRINT #1:MKL$(WAVEFILESIZE); PRINT #1:"WAVEfmt "; PRINT #1:MKL$(HEADERSIZE); PRINT #1:MKI$(WAVETYPE); PRINT #1:MKI$(CHANNEL); PRINT #1:MKL$(SAMPLINGFREQ); PRINT #1:MKL$(DATARATE); PRINT #1:MKI$(SAMPLESIZE); PRINT #1:MKI$(SAMPLEBIT); PRINT #1:"data"; PRINT #1:MKL$(PCMSIZE); FOR I=0 TO INT(SAMPLINGFREQ*SECOND)-1 LET X=I*FREQ/SAMPLINGFREQ*2*PI SELECT CASE MODE CASE 1 LET DAT=SIN(X) CASE 2 LET DAT=TRIANGLEW(X) CASE 3 LET DAT=SQUAREW(X) CASE 4 LET DAT=TRAPEZOIDALW(X) CASE 5 LET DAT=SAW(X) CASE 6 LET DAT=STEPWISE(X,4) CASE 7 LET DAT=PULSEW(X) CASE 8 LET DAT=WEIERSTRASS(X,15) END SELECT LET DAT=DAT*LEVEL PRINT #1:MKI$(INT(DAT)); NEXT I CLOSE #1 PLAYSOUND PATH$ & TYPE$(MODE) & ".wav" !'再生 !'FILE DELETE PATH$ & TYPE$(MODE) & ".wav" LOOP END EXTERNAL FUNCTION PULSEW(X) !'パルス波 PULSE WAVE IF ABS(ABS(SIN(X))-1)<.0001 THEN LET PULSEW=SGN(SIN(X)) ELSE LET PULSEW=0 END FUNCTION EXTERNAL FUNCTION SQUAREW(X) !'方形波 SQUARE WAVE LET SQUAREW=SGN(SIN(X)) END FUNCTION EXTERNAL FUNCTION TRIANGLEW(X) !'三角波 TRIANGLE WAVE LET NN=MOD(X,PI) IF NN>PI/2 THEN LET NN=PI-NN LET TRIANGLEW=NN/(PI/2)*SGN(SIN(X)) END FUNCTION EXTERNAL FUNCTION SAW(X) !'のこぎり波 LET SAW=MOD(X,PI)/(PI/2)-1 END FUNCTION EXTERNAL FUNCTION TRAPEZOIDALW(X) !'台形波 TRAPEZOIDAL WAVE LET NN=X-INT(X/PI)*PI IF NN>PI/2 THEN LET NN=PI-NN LET TRAPEZOIDALW=MIN(1,MAX(-1,NN*SGN(SIN(X))) ) END FUNCTION EXTERNAL FUNCTION STEPWISE(X,NN) !'階段状 LET STEPWISE=INT(NN*(SIN(X)+1))/NN-1 END FUNCTION EXTERNAL FUNCTION WEIERSTRASS(X,N) !'ワイヤストラス LET B=11 FOR I=0 TO N LET S=S+.5^(I+1)*SIN(B^I*X) NEXT I LET WEIERSTRASS=S END FUNCTION EXTERNAL FUNCTION MKI$(A) OPTION CHARACTER BYTE DECLARE STRING A$,B$ IF A<0 THEN LET A=A+65536 LET A$=CHR$(MOD(A,256)) LET B$=CHR$(INT(A/256)) LET MKI$=A$ & B$ END FUNCTION EXTERNAL FUNCTION MKL$(A) OPTION CHARACTER BYTE DECLARE STRING A$,B$,C$,D$ IF A<0 THEN LET A=A+2^32 LET A$=CHR$(MOD(A,256)) LET B$=CHR$(MOD(INT(A/256),256)) LET C$=CHR$(MOD(INT(A/65536),256)) LET D$=CHR$(MOD(INT(A/16777216),256)) LET MKL$=A$ & B$ & C$ & D$ END FUNCTION

電話をかける

投稿者：しばっち投稿日：2011年11月13日(日)20時01分10秒

DTMF信号音の生成(ピッポッパッ音) ※できるだけ受話器とスピーカーを近づけて行ってください ※電話がかかれば、当然ながら通話料が発生します ※電話のかけ間違い? にご注意ください http://ja.wikipedia.org/wiki/DTMF OPTION CHARACTER BYTE DIM LOFREQ(12),HIFREQ(12) FOR I=1 TO 12 READ LOFREQ(I),HIFREQ(I) !'周波数(Hz)データ NEXT I DATA 697,1209 !'1 DATA 697,1336 !'2 DATA 697,1447 !'3 DATA 770,1209 !'4 DATA 770,1336 !'5 DATA 770,1447 !'6 DATA 852,1209 !'7 DATA 852,1336 !'8 DATA 852,1447 !'9 DATA 941,1336 !'0 DATA 941,1209 !'* DATA 941,1447 !'# LET CHANNEL=1 LET SAMPLEBIT=16 LET HEADERSIZE=16 LET WAVETYPE=1 LET SAMPLINGFREQ=22050 !'サンプリング周波数 LET SAMPLESIZE = SAMPLEBIT / 8 * CHANNEL LET DATARATE = SAMPLESIZE * SAMPLINGFREQ LET VOL=.95 LET LEVEL=2^(SAMPLEBIT-1)*VOL !'LET PATH$="C:WINDOWS\TEMP\" !'作業用フォルダ、RAMディスクなど LET TELNUM$="TEL 117" !'電話番号(時報)　兼ファイル名 LET SECOND1=.3 !'信号音継続時間(秒) LET SECOND2=.1 !'区切り時間(秒) FOR I=1 TO LEN(TELNUM$) IF POS("0123456789*#",MID$(TELNUM$,I,1))>0 THEN LET NUM$=NUM$ & MID$(TELNUM$,I,1) !'電話番号のみを取り出す NEXT I LET SECOND=LEN(NUM$)*(SECOND1+SECOND2) LET PCMSIZE=INT(DATARATE*SECOND) LET WAVEFILESIZE = PCMSIZE + 36 OPEN #1:NAME PATH$ & TELNUM$ & ".wav" ERASE #1 PRINT #1:"RIFF"; PRINT #1:MKL$(WAVEFILESIZE); PRINT #1:"WAVEfmt "; PRINT #1:MKL$(HEADERSIZE); PRINT #1:MKI$(WAVETYPE); PRINT #1:MKI$(CHANNEL); PRINT #1:MKL$(SAMPLINGFREQ); PRINT #1:MKL$(DATARATE); PRINT #1:MKI$(SAMPLESIZE); PRINT #1:MKI$(SAMPLEBIT); PRINT #1:"data"; PRINT #1:MKL$(PCMSIZE); FOR J=1 TO LEN(NUM$) LET K=POS("1234567890*#",MID$(NUM$,J,1)) FOR I=0 TO INT(SAMPLINGFREQ*SECOND1)-1 LET DAT=LEVEL*(.5*SIN(LOFREQ(K)*I/SAMPLINGFREQ*2*PI)+.5*SIN(HIFREQ(K)*I/SAMPLINGFREQ*2*PI)) PRINT #1: MKI$(INT(DAT)); NEXT I FOR I=0 TO INT(SAMPLINGFREQ*SECOND2)-1 !'無音(区切り) PRINT #1: MKI$(0); NEXT I NEXT J CLOSE #1 PLAYSOUND PATH$ & TELNUM$ & ".wav" !'再生 !'FILE DELETE PATH$ & TELNUM$ & ".wav" END EXTERNAL FUNCTION MKI$(A) OPTION CHARACTER BYTE DECLARE STRING A$,B$ IF A<0 THEN LET A=A+65536 LET A$=CHR$(MOD(A,256)) LET B$=CHR$(INT(A/256)) LET MKI$=A$ & B$ END FUNCTION EXTERNAL FUNCTION MKL$(A) OPTION CHARACTER BYTE DECLARE STRING A$,B$,C$,D$ IF A<0 THEN LET A=A+2^32 LET A$=CHR$(MOD(A,256)) LET B$=CHR$(MOD(INT(A/256),256)) LET C$=CHR$(MOD(INT(A/65536),256)) LET D$=CHR$(MOD(INT(A/16777216),256)) LET MKL$=A$ & B$ & C$ & D$ END FUNCTION

無限音階

投稿者：しばっち投稿日：2011年11月13日(日)20時01分50秒

無限音階(シェパードトーン) 音程が上がり続けるように聞こえる(かな?) http://www-antenna.ee.titech.ac.jp/~hira/hobby/edu/sonic_wave/sh_tone/index-j.html DIM FREQ(7) MAT READ FREQ !' ド　レ　ミファソ　ラ　シ DATA 261.626,293.665,329.628,349.228,195.998,220,246.942 !'各音の周波数(Hz) ※ソ、ラ、シはオクターブ下 !'LET PATH$="C:\WINDOWS\TEMP\" !'作業用フォルダ、RAMディスクなど LET CHANNEL=1 !'モノラル LET SAMPLEBIT=16 !'ビット数(-32768～32767) LET HEADERSIZE=16 LET WAVETYPE=1 LET SAMPLINGFREQ=22050 !'サンプリング周波数 LET SAMPLESIZE = SAMPLEBIT / 8 * CHANNEL LET DATARATE = SAMPLESIZE * SAMPLINGFREQ LET VOL=.5 !'音量 LET LEVEL=2^(SAMPLEBIT-1)*VOL LET N=3 !'ドレミファ・・・の繰り返し回数 LET SECOND=.5 !'各音の継続時間(0.5秒) LET PCMSIZE=INT(DATARATE*SECOND*7*N) LET WAVEFILESIZE = PCMSIZE + 36 OPEN #1:NAME PATH$ & "無限音階.wav" ERASE #1 PRINT #1:"RIFF"; PRINT #1:MKL$(WAVEFILESIZE); PRINT #1:"WAVEfmt "; PRINT #1:MKL$(HEADERSIZE); PRINT #1:MKI$(WAVETYPE); PRINT #1:MKI$(CHANNEL); PRINT #1:MKL$(SAMPLINGFREQ); PRINT #1:MKL$(DATARATE); PRINT #1:MKI$(SAMPLESIZE); PRINT #1:MKI$(SAMPLEBIT); PRINT #1:"data"; PRINT #1:MKL$(PCMSIZE); FOR J=1 TO N FOR I=1 TO 7 LET M=SAMPLINGFREQ*SECOND-1 FOR K=0 TO M LET X=K/M LET ENVELOPE=1-X^6 LET DAT=0 FOR L=1 TO 8 LET DAT=DAT+SIN(2^(L-3)*FREQ(I)*K/SAMPLINGFREQ*2*PI)/8 NEXT L LET DAT=DAT*LEVEL*ENVELOPE PRINT #1:MKI$(INT(DAT)); NEXT K NEXT I NEXT J CLOSE #1 PLAYSOUND PATH$ & "無限音階.wav" !'再生 !'FILE DELETE PATH$ & "無限音階.wav" END EXTERNAL FUNCTION MKI$(A) OPTION CHARACTER BYTE DECLARE STRING A$,B$ IF A<0 THEN LET A=A+65536 LET A$=CHR$(MOD(A,256)) LET B$=CHR$(INT(A/256)) LET MKI$=A$ & B$ END FUNCTION EXTERNAL FUNCTION MKL$(A) OPTION CHARACTER BYTE DECLARE STRING A$,B$,C$,D$ IF A<0 THEN LET A=A+2^32 LET A$=CHR$(MOD(A,256)) LET B$=CHR$(MOD(INT(A/256),256)) LET C$=CHR$(MOD(INT(A/65536),256)) LET D$=CHR$(MOD(INT(A/16777216),256)) LET MKL$=A$ & B$ & C$ & D$ END FUNCTION

「故郷」

投稿者：しばっち投稿日：2011年11月13日(日)20時02分43秒

OPTION CHARACTER BYTE LET CHANNEL=1 !'モノラル LET SAMPLEBIT=16 !'ビット数 LET HEADERSIZE=16 LET WAVETYPE=1 !'LET PATH$="C:\WINDOWS\TEMP\" !'作業用フォルダ、RAMディスクなど LET SAMPLINGFREQ=16000 !'サンプリング周波数 LET TEMPO=80 !'テンポ DO READ IF MISSING THEN EXIT DO:A$,T$ LET PLAYTIME=PLAYTIME+LENGTH(T$) !'演奏時間(秒) LOOP LET SAMPLESIZE = SAMPLEBIT / 8 * CHANNEL LET DATARATE = SAMPLESIZE * SAMPLINGFREQ LET VOL=.5 !'音量 LET LEVEL=2^(SAMPLEBIT-1)*VOL LET PCMSIZE=INT(DATARATE*PLAYTIME) LET WAVEFILESIZE = PCMSIZE + 36 OPEN #1:NAME PATH$ & "故郷.wav" ERASE #1 PRINT #1:"RIFF"; PRINT #1:MKL$(WAVEFILESIZE); PRINT #1:"WAVEfmt "; PRINT #1:MKL$(HEADERSIZE); PRINT #1:MKI$(WAVETYPE); PRINT #1:MKI$(CHANNEL); PRINT #1:MKL$(SAMPLINGFREQ); PRINT #1:MKL$(DATARATE); PRINT #1:MKI$(SAMPLESIZE); PRINT #1:MKI$(SAMPLEBIT); PRINT #1:"data"; PRINT #1:MKL$(PCMSIZE); RESTORE DO READ IF MISSING THEN EXIT DO:A$,T$ LET FREQ=GETFREQ(A$) LET M=SAMPLINGFREQ*LENGTH(T$)-1 !'※Mが整数であること(非整数になる場合、再生エラーとなる可能性あり) FOR J=0 TO M LET X=J/M LET ENVELOPE=1-X^6 LET DAT=LEVEL*SIN(J*FREQ/SAMPLINGFREQ*2*PI)*ENVELOPE PRINT #1:MKI$(INT(DAT)); NEXT J LOOP DATA C,4,C,4,C,4,D,4.,E,8,D,4,E,4,E,4,F,4,G,2,R,4 DATA F,4,G,4,A,4,E,4.,F,8,E,4,D,4,D,4,-B,4,C,2,R,4 DATA D,8,C,8,D,4,-G,4,C,8,D,8,E,4,E,4,F,8,E,8,F,4.,A,8 DATA G,8,F,8,E,4,R,4,G,4,G,4,G,4,C,4.,D,8,E,4,F,4,F,4,D,4,C,2,R,4 CLOSE #1 PLAYSOUND PATH$ & "故郷.wav" !'再生 !'FILE DELETE PATH$ & "故郷.wav" FUNCTION LENGTH(T$) SELECT CASE T$ CASE "2" !'2分音符 LET LENGTH=60/TEMPO*2 CASE "2." !'付点2分音符 LET LENGTH=60/TEMPO*2+60/TEMPO CASE "4" !'4分音符 LET LENGTH=60/TEMPO CASE "4." !'付点4分音符 LET LENGTH=60/TEMPO+60/TEMPO/2 CASE "8" LET LENGTH=60/TEMPO/2 CASE "8." LET LENGTH=60/TEMPO/2+60/TEMPO/4 CASE "16" LET LENGTH=60/TEMPO/4 END SELECT END FUNCTION END EXTERNAL FUNCTION GETFREQ(KEY$) !'音名 → 周波数(Hz) RESTORE DO READ K$,FREQ IF KEY$=K$ THEN LET GETFREQ=FREQ EXIT FUNCTION END IF LOOP DATA -C,130.813,-D,146.832,-E,164.814,-F,174.614,-G,195.998,-A,220,-B,246.942 DATA C,261.626,D,293.665,E,329.628,F,349.228,G,391.996,A,440,B,493.884 DATA +C,523.251,+D,587.33,+E,659.255,+F,698.456,+G,783.991,+A,880,R,0 END FUNCTION EXTERNAL FUNCTION MKI$(A) OPTION CHARACTER BYTE DECLARE STRING A$,B$ IF A<0 THEN LET A=A+65536 LET A$=CHR$(MOD(A,256)) LET B$=CHR$(INT(A/256)) LET MKI$=A$ & B$ END FUNCTION EXTERNAL FUNCTION MKL$(A) OPTION CHARACTER BYTE DECLARE STRING A$,B$,C$,D$ IF A<0 THEN LET A=A+2^32 LET A$=CHR$(MOD(A,256)) LET B$=CHR$(MOD(INT(A/256),256)) LET C$=CHR$(MOD(INT(A/65536),256)) LET D$=CHR$(MOD(INT(A/16777216),256)) LET MKL$=A$ & B$ & C$ & D$ END FUNCTION

「埴生の宿」

投稿者：しばっち投稿日：2011年11月13日(日)20時03分34秒

「埴生の宿」差し替えデータのみ該当部分を書き換えてください LET TEMPO=120 DATA C,4,E,4.,F,8,F,4.,G,8,G,2,E,4,G,4,F,4.,E,8,F,4,D,4,E,2,R,4 DATA C,4,E,4.,F,8,F,4.,G,8,G,2,E,4,G,4,F,4.,E,8,F,4,D,4,C,2,R,4 DATA G,4,+C,4.,B,8,A,4.,G,8,G,2,E,4,G,4,F,4.,E,8,F,4,D,4 DATA E,2,R,4,G,4,+C,4.,B,8,A,4.,G,8,G,2,E,4,G,4,G,2,F,4,D,4,C,2.,R,4 DATA G,2.,R,4,F,2,D,2,C,2,D,2,E,2,R,4,G,4,+C,4.,B,8,A,4. DATA G,8,G,2,E,4,G,4,G,4,A,4,F,4,D,4,C,2.,R,4

「歓びのうた」

投稿者：しばっち投稿日：2011年11月13日(日)20時04分15秒

「歓びのうた」差し替えデータのみ該当部分を書き換えてください LET TEMPO=120 DATA E,4,E,4,F,4,G,4,G,4,F,4,E,4,D,4,C,4,C,4,D,4,E,4,E,4.,D,8,D,4.,R,8 DATA E,4,E,4,F,4,G,4,G,4,F,4,E,4,D,4,C,4,C,4,D,4,E,4,D,4.,C,8,C,4.,R,8 DATA D,2,E,4,C,4,D,4,E,8,F,8,E,4,C,4,D,4,E,8,F,8,E,4,D,4,C,4,D,4,-G,8,R,8 DATA E,2,E,4,F,4,G,4,G,4,F,4,E,4,D,4,C,4,C,4,D,4,E,4,D,4.,C,8,C,8,G,8,F,8,E,8 DATA D,2,E,4,C,4,D,4,E,8,F,8,E,4,C,4,D,4,E,8,F,8,E,4,D,4,C,4,D,4,-G,8,R,8,E,2 DATA E,4,F,4,G,4,G,4,F,4,E,4,D,4,C,4,C,4,D,4,E,4,D,4.,C,8,C,2

三角比

投稿者：しばっち投稿日：2011年11月13日(日)20時04分51秒

直角三角形ABCにおいて C/A=SIN(θ) B/A=COS(θ)とする A/(A+B+C),B/(A+B+C),C/(A+B+C)を求める (A)/(A+B+C)→(A/A)/(A/A+B/A+C/A)→1/(1+COS(θ)+SIN(θ)) DIM A$(3),B$(3) FOR I=1 TO 3 READ A$(I),B$(I) NEXT I DATA "A","A+B+C" DATA "B","A+B+C" DATA "C","A+B+C" PRINT REPEAT$(" ",8); FOR I=1 TO 3 PRINT "(";A$(I);")/(";B$(I);")";REPEAT$(" ",12); NEXT I PRINT FOR TH=0 TO 360 PRINT TH;"° "; FOR I=1 TO 3 CALL CALC(A$(I),B$(I),RAD(TH)) NEXT I PRINT NEXT TH END EXTERNAL SUB CALC(A$,B$,TH) WHEN EXCEPTION IN LET K$=STR$(CALCSUB(A$,TH)/CALCSUB(B$,TH)) PRINT LEFT$(K$ & REPEAT$(" ",23),23); USE PRINT " ERROR!! "; END WHEN END SUB EXTERNAL FUNCTION CALCSUB(E$,TH) SELECT CASE UCASE$(E$) CASE "A" LET CALCSUB=1 CASE "B" LET CALCSUB=COS(TH) CASE "C" LET CALCSUB=SIN(TH) CASE "A+B" LET CALCSUB=1+COS(TH) CASE "A+C" LET CALCSUB=1+SIN(TH) CASE "B+C" LET CALCSUB=SIN(TH)+COS(TH) CASE "A+B+C" LET CALCSUB=1+SIN(TH)+COS(TH) END SELECT END FUNCTION

ローマ字入力

投稿者：しばっち投稿日：2011年11月13日(日)20時05分38秒

ローマ字 to 平仮名変換 DIM ROME$(500), NIHON$(500) DO LET K = K + 1 READ ROME$(K), NIHON$(K) LOOP UNTIL ROME$(K)="" CALL SORT(ROME$, NIHON$, K) INPUT PROMPT "文字列=": A$ !'LET A$="shibacchi" LET A$ = UCASE$(A$) DO LET A$ = LTRIM$(A$) FOR J=4 TO 1 STEP -1 LET AA$=LEFT$(A$,J) FOR I = 1 TO K IF AA$ = ROME$(I) THEN PRINT NIHON$(I); IF J=2 AND POS("BB CC DD FF GG HH JJ KK PP SS TT ZZ", AA$)<>0 THEN LET A$ = MID$(A$, 2,LEN(A$)-1) EXIT FOR END IF LET A$ = RIGHT$(A$, LEN(A$)-J) EXIT FOR END IF NEXT I IF I<=K THEN EXIT FOR NEXT J LOOP UNTIL A$ = "" DATA A,あ,I,い,U,う,E,え,O,お DATA BA,ば,BI,び,BU,ぶ,BE,べ,BO,ぼ DATA CA,か,CI,ち,CU,く,CE,せ,CO,こ DATA DA,だ,DI,ぢ,DU,づ,DE,で,DO,ど,TZU,づ DATA FA,ふぁ,FI,ふぃ,FU,ふ,FE,ふぇ,FO,ふぉ DATA GA,が,GI,ぎ,GU,ぐ,GE,げ,GO,ご DATA HA,は,HI,ひ,HU,ふ,HE,へ,HO,ほ DATA JA,じゃ,JI,じぃ,JU,じゅ,JE,じぇ,JO,じょ DATA KA,か,KI,き,KU,く,KE,け,KO,こ DATA LA,ら,LI,り,LU,る,LE,れ,LO,ろ DATA MA,ま,MI,み,MU,む,MU,め,MO,も DATA NA,な,NI,に,NU,ぬ,NE,ね,NO,の DATA PA,ぱ,PI,ぴ,PU,ぷ,PE,ぺ,PO,ぽ DATA QA,くぁ,QI,くぃ,QU,くぅ,QE,くぇ,QO,くぉ DATA RA,ら,RI,り,RU,る,RE,れ,RO,ろ DATA SA,さ,SI,し,SU,す,SE,せ,SO,そ DATA TA,た,TI,ち,TU,つ,TE,て,TO,と DATA YA,や,YI,ゐ,YU,ゆ,YE,ゑ,YO,よ DATA VA,ヴァ,VI,ヴィ,VU,ぶ,VE,ヴェ,VO,ヴォ DATA WA,わ,WI,うぃ,WU,う,WE,うぇ,WO,を DATA XA,ざぁ,XI,じぃ,XU,ずぅ,XE,ぜぇ,XO,ぞぉ DATA ZA,ざ,ZI,じ,ZU,ず,ZE,ぜ,ZO,ぞ DATA N,ん,NQ,ん,Q,ん,NX,ん,XN,ん DATA BYA,びゃ,BYI,びぃ,BYU,びゅ,BYE,びぇ,BYO,びょ DATA GYA,ぎゃ,GYI,ぎぃ,GYU,ぎゅ,GYE,ぎぇ,GYO,ぎょ DATA HYA,ひゃ,HYI,ひぃ,HYU,ひゅ,HYE,ひぇ,HYO,ひょ DATA JYA,じゃ,JYI,じぃ,JYU,じゅ,JYE,じぇ,JYO,じょ DATA KYA,きゃ,KYI,きぃ,KYU,きゅ,KYE,きぇ,KYO,きょ DATA MYA,みゃ,MYI,みぃ,MYU,みゅ,MYE,みぇ,MYO,みょ DATA NYA,にゃ,NYI,にぃ,NYU,にゅ,NYE,にぇ,NYO,にょ DATA PYA,ぴゃ,PYI,ぴぃ,PYU,ぴゅ,PYE,ぴぇ,PYO,ぴょ DATA RYA,りゃ,RYI,りぃ,RYU,りゅ,RYE,りぇ,RYO,りょ DATA SYA,しゃ,SYI,しぃ,SYU,しゅ,SYE,しぇ,SYO,しょ DATA TYA,ちゃ,TYI,ちぃ,TYU,ちゅ,TYE,ちぇ,TYO,ちょ DATA ZYA,じゃ,ZYI,じぃ,ZYU,じゅ,ZYE,じぇ,ZYO,じょ DATA BHA,びぁ,BHI,びぃ,BHU,びゅ,BHE,びぇ,BHO,びょ DATA CHA,ちぁ,CHI,ち,CHU,ちゅ,CHE,ちぇ,CHO,ちょ DATA PHA,ふぁ,PHI,ふぃ,PHU,ふぅ,PHE,ふぇ,PHO,ふょ DATA SHA,しゃ,SHI,し,SHU,しゅ,SHE,しぇ,SHO,しょ DATA TSA,つぁ,TSI,つぃ,TSU,つ,TSE,つぇ,TSO,つぉ DATA LTU,っ,XTU,っ,LTSU,っ,XTU,っ,XTSU,っ DATA WRI,らい,XY,っくし,CK,っく,TCHI,っち DATA BB,っ,CC,っ,DD,っ,FF,っ,GG,っ,HH,っ,JJ,っ,KK,っ,PP,っ,SS,っ,TT,っ,ZZ,っ DATA LKA,カ,XKA,カ,LKE,ケ,XKE,ケ,X,っくす DATA "","" END EXTERNAL SUB SORT (A$(), B$(), N) FOR I=1 TO N-1 FOR J=I+1 TO N IF A$(I)>A$(J) THEN SWAP A$(I), A$(J) SWAP B$(I), B$(J) END IF NEXT J NEXT I END SUB

魔方陣(奇数)

投稿者：しばっち投稿日：2011年11月13日(日)20時06分51秒

魔方陣(奇数魔方陣のみ) N * N 方陣において1～N^2までの数字を全て使用し、各縦、横、斜めの列の和が全て同じ DIM A(19, 19) FOR N=3 TO 19 STEP 2 LET X = INT(N / 2) + 1 LET A(X, 1) = 1 LET I = 2 LET Y = N + 1 DO IF X = N THEN LET X = 1 ELSE LET X = X + 1 IF Y = 1 THEN LET Y = N ELSE LET Y = Y - 1 IF A(X, Y) <> 0 THEN LET Y = Y + 2 LET X = X - 1 END IF DO LET A(X, Y) = I IF X = N AND Y = 1 THEN LET Y = Y + 1 LET I = I + 1 ELSE EXIT DO END IF LOOP IF I = N * N THEN EXIT DO LET I = I + 1 LOOP PRINT N; " * "; N; " 魔方陣" FOR Y = 1 TO N FOR X = 1 TO N PRINT USING "#####": A(X, Y); NEXT X PRINT NEXT Y MAT A=ZER NEXT N END

魔方陣(4N)

投稿者：しばっち投稿日：2011年11月13日(日)20時07分45秒

魔方陣(4*N 魔方陣) OPTION BASE 0 DIM A(27, 27) FOR L=4 TO 24 STEP 4 FOR M = 0 TO L / 4 FOR N = 0 TO L / 4 LET A(4 * N, 4 * M) = 1 LET A(4 * N + 1, 4 * M) = 1 LET A(4 * N + 1, 4 * M + 1) = 1 LET A(4 * N, 4 * M + 1) = 1 LET A(4 * N + 2, 4 * M + 2) = 1 LET A(4 * N + 3, 4 * M + 2) = 1 LET A(4 * N + 2, 4 * M + 3) = 1 LET A(4 * N + 3, 4 * M + 3) = 1 NEXT N NEXT M FOR Y = 1 TO L FOR X = 1 TO L IF A(X, Y) = 1 THEN LET A(X, Y) = L * (Y - 1) + X ELSE LET A(X, Y) = L * L - (L * (Y - 1) + X - 1) NEXT X NEXT Y PRINT L; " * "; L; " 魔方陣" FOR Y = 1 TO L FOR X = 1 TO L PRINT USING "#####": A(X,Y); NEXT X PRINT NEXT Y PRINT MAT A=ZER NEXT L END

魔方陣(4N+2)

投稿者：しばっち投稿日：2011年11月13日(日)20時08分25秒

魔方陣(4*N+2 魔方陣) OPTION BASE 0 DIM A(30,30) FOR N=6 TO 30 STEP 4 LET K = N * 2 - 2 FOR I = 1 TO N - 2 FOR J = 1 TO N-2 IF BITAND(I,2) = BITAND(J,2) THEN LET K=K+1 LET A(I,J) = K ELSE LET K=K+1 LET A(N - 1 - I,N - 1 - J) = K END IF NEXT J NEXT I LET SUM = N * N + 1 LET A(0,0)=N-2 LET A(N - 1,N - 1) = SUM - (N-2) LET A(0,N - 1)=N-1 LET A(N - 1,0) = SUM - (N-1) LET A(0,N - 2) = SUM - 2 * N + 3 LET A(N - 1,N - 2) = SUM - (SUM-2*N+3) LET A(N - 2,0)= 2 * N - 2 LET A(N - 2,N - 1) = SUM - (2*N-2) FOR I = 1 TO N - 3 IF BITAND(I, 2) = 0 THEN LET J= 0 ELSE LET J= N - 1 LET A(J,I) = N - 2 - I LET A(N - 1 -J,I) = SUM - (N-2-I) LET A(I,J) = N - 1 + I LET A(I,N - 1 -J) = SUM - (N-1+I) NEXT I PRINT N; " * "; N; " 魔方陣" FOR I=0 TO N-1 FOR J=0 TO N-1 PRINT USING" ####":A(I,J); NEXT J PRINT NEXT I PRINT NEXT N END

魔星陣

投稿者：しばっち投稿日：2011年11月13日(日)20時09分4秒

魔星陣? (魔方陣の星型版) FOR A = 1 TO 12 FOR B = 1 TO 12 IF A = B THEN GOTO 60 FOR C = 1 TO 12 IF A = C OR B = C THEN GOTO 50 FOR D = 1 TO 12 IF A = D OR B = D OR C = D THEN GOTO 40 LET E = 26 - D - C - B IF E < 1 THEN EXIT FOR IF E > 12 THEN GOTO 40 IF A = E OR B = E OR C = E OR D = E THEN GOTO 40 FOR F = 1 TO 12 IF A = F OR B = F OR C = F OR D = F OR E = F THEN GOTO 30 LET H = 26 - A - C - F IF H < 1 THEN EXIT FOR IF H > 12 THEN GOTO 30 IF A = H OR B = H OR C = H OR D = H OR E = H OR F = H THEN GOTO 30 FOR I = 1 TO 12 IF A = I OR B = I OR C = I OR D = I OR E = I OR F = I OR H = I THEN GOTO 20 LET L = 26 - B - F - I IF L < 1 THEN EXIT FOR IF L > 12 THEN GOTO 20 IF A = L OR B = L OR C = L OR D = L OR E = L OR F = L OR H = L OR I = L THEN GOTO 20 FOR G = 1 TO 12 IF A = G OR B = G OR C = G OR D = G OR E = G OR F = G OR H = G OR I = G OR L = G THEN GOTO 10 LET K = 26 - A - D - G IF K < 1 THEN EXIT FOR IF K > 12 THEN GOTO 10 IF A = K OR B = K OR C = K OR D = K OR E = K OR F = K OR H = K OR I = K OR L = K OR G = K THEN GOTO 10 LET J = 26 - H - I - K IF J < 1 THEN GOTO 10 IF J > 12 THEN GOTO 10 IF A = J OR B = J OR C = J OR D = J OR E = J OR F = J OR H = J OR I = J OR L = J OR G = J OR K = J THEN GOTO 10 LET NO = NO + 1 PRINT "No."; NO PRINT USING " ##":A PRINT USING "## ## ## ##":B,C,D,E PRINT USING " ## ##":F,G PRINT USING "## ## ## ##":H,I,J,K PRINT USING " ##":L 10 NEXT G 20 NEXT I 30 NEXT F 40 NEXT D 50 NEXT C 60 NEXT B 70 NEXT A END

魔六角陣

投稿者：しばっち投稿日：2011年11月13日(日)20時09分46秒

魔六角陣? (魔方陣の六角形版) FOR A = 1 TO 19 FOR B = 1 TO 19 IF A = B THEN GOTO 20 LET C = 38 - A - B IF C > 19 THEN GOTO 20 IF C < 1 THEN EXIT FOR IF C = A OR C = B THEN GOTO 20 FOR D = 1 TO 19 IF A = D OR B = D OR C = D THEN GOTO 40 LET H = 38 - A - D IF H > 19 THEN GOTO 40 IF H < 1 THEN EXIT FOR IF H = A OR H = B OR H = C OR H = D THEN GOTO 40 FOR E = 1 TO 19 IF A = E OR B = E OR C = E OR D = E OR H = E THEN GOTO 50 FOR F = 1 TO 19 IF A = F OR B = F OR C = F OR D = F OR H = F OR E = F THEN GOTO 60 LET G = 38 - D - E - F IF G < 1 THEN EXIT FOR IF G > 19 THEN GOTO 60 IF A = G OR B = G OR C = G OR D = G OR H = G OR E = G OR F = G THEN GOTO 60 LET L = 38 - C - G IF L < 1 OR L > 19 THEN GOTO 60 IF A = L OR B = L OR C = L OR D = L OR H = L OR E = L OR F = L OR G = L THEN GOTO 60 FOR I = 1 TO 19 IF A = I OR B = I OR C = I OR D = I OR H = I OR E = I OR F = I OR G = I OR L = I THEN GOTO 70 LET M = 38 - B - E - I IF M < 1 THEN EXIT FOR IF M > 19 THEN GOTO 70 IF A = M OR B = M OR C = M OR D = M OR H = M OR E = M OR F = M OR G = M OR L = M OR I = M THEN GOTO 70 FOR J = 1 TO 19 IF A = J OR B = J OR C = J OR D = J OR H = J OR E = J OR F = J OR G = J OR L = J OR I = J OR M = J THEN GOTO 80 FOR K = 1 TO 19 IF A = K OR B = K OR C = K OR D = K OR H = K OR E = K OR F = K OR G = K OR L = K OR I = K OR M = K OR J = K THEN GOTO 90 !'IF H + I + J + K + L > 38 THEN EXIT FOR IF H + I + J + K + L <> 38 THEN GOTO 90 LET P = 38 - B - F - K IF P < 1 THEN EXIT FOR IF P > 19 THEN GOTO 90 IF A = P OR B = P OR C = P OR D = P OR H = P OR E = P OR F = P OR G = P OR L = P OR I = P OR M = P OR K = P OR J = P THEN GOTO 90 FOR N = 1 TO 19 IF A = N OR B = N OR C = N OR D = N OR H = N OR E = N OR F = N OR G = N OR L = N OR I = N OR M = N OR K = N OR P = N OR J = N THEN GOTO 100 LET R = 38 - D - I - N IF R < 1 THEN EXIT FOR IF R > 19 THEN GOTO 100 IF A = R OR B = R OR C = R OR D = R OR H = R OR E = R OR F = R OR G = R OR L = R OR I = R OR M = R OR K = R OR P = R OR N = R OR J = R THEN GOTO 100 LET Q = 38 - C - F - J - N IF Q < 1 THEN EXIT FOR IF Q > 19 THEN GOTO 100 IF H + M + Q <> 38 THEN GOTO 100 IF A = Q OR B = Q OR C = Q OR D = Q OR H = Q OR E = Q OR F = Q OR G = Q OR L = Q OR I = Q OR M = Q OR K = Q OR P = Q OR N = Q OR R = Q OR J = Q THEN GOTO 100 LET O = 38 - G - K - R IF O < 1 OR O > 19 THEN GOTO 100 IF M + N + O + P <> 38 THEN GOTO 100 IF A = O OR B = O OR C = O OR D = O OR H = O OR E = O OR F = O OR G = O OR L = O OR I = O OR M = O OR K = O OR P = O OR N = O OR R = O OR Q = O OR J = O THEN GOTO 100 LET S = 38 - Q - R IF S < 1 OR S > 19 THEN GOTO 100 IF L + P + S <> 38 THEN GOTO 100 IF A + E + J + O + S <> 38 THEN GOTO 100 IF A = S OR B = S OR C = S OR D = S OR H = S OR E = S OR F = S OR G = S OR L = S OR I = S OR M = S OR K = S OR P = S OR N = S OR R = S OR Q = S OR O = S OR J = S THEN GOTO 100 LET NO = NO + 1 PRINT "No."; NO PRINT USING " ## ## ## ": A, B, C PRINT USING " ## ## ## ## ": D, E, F, G PRINT USING "## ## ## ## ##": H, I, J, K, L PRINT USING " ## ## ## ## ": M, N, O, P PRINT USING " ## ## ## ": Q, R, S 100 NEXT N 90 NEXT K 80 NEXT J 70 NEXT I 60 NEXT F 50 NEXT E 40 NEXT D 20 NEXT B 10 NEXT A END

スライドショー

投稿者：しばっち投稿日：2011年11月13日(日)20時10分28秒

画像スライドショー LET PATH$="D:\My Pictures" !'画像フォルダを指定すること LET PT$=PATH$ & "\*.*" LET NN=FILES(PT$) IF NN>0 THEN DIM N$(NN),P$(NN),NAME$(NN),EXT$(NN) FILE LIST PT$, N$ ELSE STOP END IF FOR I=1 TO NN FILE SPLITNAME(N$(I)) P$(I),NAME$(I),EXT$(I) IF POS(".JPG.BMP.GIF",UCASE$(EXT$(I)))=0 THEN LET NAME$(I)="" LET P$(I)="" LET EXT$(I)="" ELSE LET NUM=NUM+1 END IF NEXT I FOR I=1 TO NN IF NAME$(I)<>"" THEN WHEN EXCEPTION IN CALL PICTURELOAD(PATH$ & "\" & NAME$(I) & EXT$(I),XSIZE,YSIZE) LET K=K+1 PRINT K;"/";NUM;NAME$(I) & EXT$(I);XSIZE;"*";YSIZE WAIT DELAY 3 !'表示時間(秒) USE PRINT "READ ERROR !! ";NAME$(I) & EXT$(I) END WHEN END IF NEXT I END EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE) SET COLOR MODE "NATIVE" CLEAR SET POINT STYLE 1 GLOAD N$ LET XSIZE=PIXELX(1) LET YSIZE=PIXELY(1) SET BITMAP SIZE XSIZE,YSIZE SET WINDOW 0,XSIZE-1,YSIZE-1,0 END SUB

3項論理演算

投稿者：しばっち投稿日：2011年11月13日(日)20時11分39秒

3項論理演算 FOR C=0 TO 1 FOR B=0 TO 1 FOR A=0 TO 1 PRINT A;"-";B;"-";C, PRINT BIT1(A,B,C); PRINT BIT2(A,B,C); PRINT BIT3(A,B,C); PRINT BIT12(A,B,C); PRINT BIT23(A,B,C); PRINT BIT123(A,B,C) NEXT A NEXT B NEXT C END EXTERNAL FUNCTION BIT0 (A, B, C) !'0-0-0 1 !'0-0-1 0 !'0-1-0 0 !'0-1-1 0 !'1-0-0 0 !'1-0-1 0 !'1-1-0 0 !'1-1-1 0 LET BIT0 =BITNOT(BIT123(A, B, C)) END FUNCTION EXTERNAL FUNCTION BIT1 (A, B, C) !'0-0-0 0 !'0-0-1 1 !'0-1-0 1 !'0-1-1 0 !'1-0-0 1 !'1-0-1 0 !'1-1-0 0 !'1-1-1 0 LET BIT1 = BITXOR(BITOR(BITOR(BITXOR(A,B),BITXOR(B,C)),BITXOR(C,A)),BIT2(A, B, C)) END FUNCTION EXTERNAL FUNCTION BIT2 (A, B, C) !'0-0-0 0 !'0-0-1 0 !'0-1-0 0 !'0-1-1 1 !'1-0-0 0 !'1-0-1 1 !'1-1-0 1 !'1-1-1 0 LET BIT2 = BITXOR(BIT23(A, B, C),BIT3(A, B, C)) END FUNCTION EXTERNAL FUNCTION BIT3 (A, B, C) !'0-0-0 0 !'0-0-1 0 !'0-1-0 0 !'0-1-1 0 !'1-0-0 0 !'1-0-1 0 !'1-1-0 0 !'1-1-1 1 LET BIT3 = BITAND(BITAND(A,B),C) END FUNCTION EXTERNAL FUNCTION BIT01 (A, B, C) !'0-0-0 1 !'0-0-1 1 !'0-1-0 1 !'0-1-1 0 !'1-0-0 1 !'1-0-1 0 !'1-1-0 0 !'1-1-1 0 LET BIT01 =BITNOT (BIT23(A, B, C)) END FUNCTION EXTERNAL FUNCTION BIT02 (A, B, C) !'0-0-0 1 !'0-0-1 0 !'0-1-0 0 !'0-1-1 1 !'1-0-0 0 !'1-0-1 1 !'1-1-0 1 !'1-1-1 0 LET BIT02 =BITNOT (BIT13(A, B, C)) END FUNCTION EXTERNAL FUNCTION BIT03 (A, B, C) !'0-0-0 1 !'0-0-1 0 !'0-1-0 0 !'0-1-1 0 !'1-0-0 0 !'1-0-1 0 !'1-1-0 0 !'1-1-1 1 LET BIT03 =BITNOT (BIT12(A, B, C)) END FUNCTION EXTERNAL FUNCTION BIT12 (A, B, C) !'0-0-0 0 !'0-0-1 1 !'0-1-0 1 !'0-1-1 1 !'1-0-0 1 !'1-0-1 1 !'1-1-0 1 !'1-1-1 0 LET BIT12 = BITOR(BIT1(A, B, C),BIT2(A, B, C)) END FUNCTION EXTERNAL FUNCTION BIT13 (A, B, C) !'0-0-0 0 !'0-0-1 1 !'0-1-0 1 !'0-1-1 0 !'1-0-0 1 !'1-0-1 0 !'1-1-0 0 !'1-1-1 1 LET BIT13 = BITOR(BIT1(A, B, C),BIT3(A, B, C)) END FUNCTION EXTERNAL FUNCTION BIT23 (A, B, C) !'0-0-0 0 !'0-0-1 0 !'0-1-0 0 !'0-1-1 1 !'1-0-0 0 !'1-0-1 1 !'1-1-0 1 !'1-1-1 1 LET BIT23 = BITOR(BITOR(BITAND(A,B),BITAND(B,C)),BITAND(C,A)) END FUNCTION EXTERNAL FUNCTION BIT123 (A, B, C) !'0-0-0 0 !'0-0-1 1 !'0-1-0 1 !'0-1-1 1 !'1-0-0 1 !'1-0-1 1 !'1-1-0 1 !'1-1-1 1 LET BIT123 = BITOR(BITOR(A,B),C) END FUNCTION EXTERNAL FUNCTION BIT023 (A, B, C) !'0-0-0 1 !'0-0-1 0 !'0-1-0 0 !'0-1-1 1 !'1-0-0 0 !'1-0-1 1 !'1-1-0 1 !'1-1-1 1 LET BIT023 =BITNOT(BIT1(A,B,C)) END FUNCTION EXTERNAL FUNCTION BIT013 (A, B, C) !'0-0-0 1 !'0-0-1 1 !'0-1-0 1 !'0-1-1 0 !'1-0-0 1 !'1-0-1 0 !'1-1-0 0 !'1-1-1 1 LET BIT013 =BITNOT(BIT2(A,B,C)) END FUNCTION EXTERNAL FUNCTION BIT012 (A, B, C) !'0-0-0 1 !'0-0-1 1 !'0-1-0 1 !'0-1-1 1 !'1-0-0 1 !'1-0-1 1 !'1-1-0 1 !'1-1-1 0 LET BIT012 =BITNOT(BIT3(A,B,C)) END FUNCTION

関数

投稿者：しばっち投稿日：2011年11月13日(日)20時12分37秒

関数をいくつか定義してみました(※エラー処理なし) EXTERNAL FUNCTION SEC(X) LET SEC=1/COS(X) !'secant END FUNCTION EXTERNAL FUNCTION COSEC(X) LET COSEC=1/SIN(X) !'cosecant END FUNCTION EXTERNAL FUNCTION COTAN(X) LET COTAN=1/TAN(X) !'cotangent END FUNCTION EXTERNAL FUNCTION ARCSIN(X) LET ARCSIN=ATN(X/SQR(1-X*X)) !'arcsine END FUNCTION EXTERNAL FUNCTION ARCCOS(X) LET ARCCOS=-ATN(X/SQR(1-X*X))+PI/2 !'arccosine END FUNCTION EXTERNAL FUNCTION ARCSEC(X) LET ARCSEC=ATN(SQR(X*X-1))+(SGN(X)-1)*PI/2 !'arcsecant END FUNCTION EXTERNAL FUNCTION ARCSEC2(X) LET ARCSEC2=ACOS(1/X) END FUNCTION EXTERNAL FUNCTION ARCCOSEC(X) LET ARCCOSEC=ATN(1/SQR(X*X-1))+(SGN(X)-1)*PI/2 !'arccosecant END FUNCTION EXTERNAL FUNCTION ARCCOSEC2(X) LET ARCCOSEC2=ASIN(1/X) END FUNCTION EXTERNAL FUNCTION ARCCOTAN(X) LET ARCCOTAN=-ATN(X)+PI/2 !'arccotangent END FUNCTION EXTERNAL FUNCTION ARCCOTAN2(X) LET ARCCOTAN=ATN(1/X) END FUNCTION EXTERNAL FUNCTION SINH(X) LET SINH=(EXP(X)-EXP(-X))/2 !'hyperbolic sine END FUNCTION EXTERNAL FUNCTION COSH(X) LET COSH=(EXP(X)+EXP(-X))/2 !'hyperbolic cosine END FUNCTION EXTERNAL FUNCTION TANH(X) LET TANH=-EXP(-X)/(EXP(X)+EXP(-X))*2+1 !'hyperbolic tangent END FUNCTION EXTERNAL FUNCTION TANH2(X) LET TANH2=SINH(X)/COSH(X) END FUNCTION EXTERNAL FUNCTION SECH(X) LET SECH=2/(EXP(X)+EXP(-X)) !'hyperbolic secant END FUNCTION EXTERNAL FUNCTION SECH2(X) LET SECH2=1/COSH(X) END FUNCTION EXTERNAL FUNCTION COSECH(X) LET COSECH =2/(EXP(X)-EXP(-X)) !'hyperbolic cosecant END FUNCTION EXTERNAL FUNCTION COSECH2(X) LET COSECH2=1/SINH(X) END FUNCTION EXTERNAL FUNCTION COTANH(X) LET COTANH=EXP(-X)/(EXP(X)-EXP(-X))*2+1 !'hyperbolic cotangent END FUNCTION EXTERNAL FUNCTION COTANH2(X) LET COTANH2=1/TANH(X) END FUNCTION EXTERNAL FUNCTION ARCSINH(X) LET ARCSINH=LOG(X+SQR(X*X+1)) !'arc-hyperbolic sine END FUNCTION EXTERNAL FUNCTION ARCCOSH(X) LET ARCCOSH=LOG(X+SQR(X*X-1)) !'arc-hyperbolic cosine END FUNCTION EXTERNAL FUNCTION ARCTANH(X) LET ARCTANH=LOG((1+X)/(1-X))/2 !'arc-hyperbolic tangent END FUNCTION EXTERNAL FUNCTION ARCSECH(X) LET ARCSECH=LOG((SQR(1-X*X)+1)/X) !'arc-hyperbolic secant END FUNCTION EXTERNAL FUNCTION ARCCOSECH(X) LET ARCCOSECH=LOG((SGN(X)*SQR(X*X+1)+1)/X) !'arc-hyperbolic cosecant END FUNCTION EXTERNAL FUNCTION ARCCOTANH(X) LET ARCCOTANH=LOG((X+1)/(X-1))/2 !'arc-hyperbolic cotangent END FUNCTION EXTERNAL FUNCTION SINC(X) IF X=0 THEN LET SINC=1 ELSE LET SINC=SIN(X)/X END FUNCTION EXTERNAL FUNCTION SUM(X) LET SUM=X/2*(X+1) !'1 + 2 + 3 +...+ X END FUNCTION EXTERNAL FUNCTION FACT2(A) !'n!! IF MOD(A,2)=0 THEN LET FACT2=2^(A/2)*FACT(A/2) !'2*4*6*8*... ELSE LET FACT2=FACT(A)/((2^((A-1)/2))*(FACT((A-1)/2))) !'3*5*7*... END IF END FUNCTION EXTERNAL FUNCTION H(N,R) LET H=COMB(N+R-1,R) !'nHr 重複組合わせ END FUNCTION EXTERNAL FUNCTION ATN2(Y,X) LET ATN2=ASIN(Y/SQR(X*X+Y*Y)) !' X=SQR(X^2+Y^2)*COS(θ) Y=SQR(X^2+Y^2)*SIN(θ) END FUNCTION EXTERNAL FUNCTION MAX(X,Y) LET MAX=(X+Y+ABS(X-Y))/2 !'IF X>Y THEN MAX=X ELSE MAX=Y 最大値 END FUNCTION EXTERNAL FUNCTION MIN(X,Y) LET MIN=(X+Y-ABS(X-Y))/2 !'IF X<Y THEN MIN=X ELSE MIN=Y 最小値 END FUNCTION EXTERNAL FUNCTION SQR2(X,Y) LET SQR2=X/COS(ATN(Y/X)) !'SQR(X*X+Y*Y) X>Y END FUNCTION EXTERNAL FUNCTION MOD2(X,Y) LET MOD2=X-INT(X/Y)*Y !'X MOD Y 余り END FUNCTION EXTERNAL FUNCTION FIX(X) LET FIX=INT(ABS(X))*SGN(X) !'FIX(X) 整数部 END FUNCTION EXTERNAL FUNCTION FRAC(X) LET FRAC=X-FIX(X) !'FRAC(X) 小数部 END FUNCTION EXTERNAL FUNCTION FLOOR(X) IF INT(X)>X THEN LET FLOOR=INT(X)-1 ELSE LET FLOOR=INT(X) !'floor(x) END FUNCTION EXTERNAL FUNCTION CEIL(X) IF INT(X)<X THEN LET CEIL=INT(X)+1 ELSE LET CEIL=INT(X) !'ceil(x) END FUNCTION EXTERNAL FUNCTION MIDDLE(X,A,B) !' A<=X<=B LET MIDDLE=MAX(A,MIN(X,B)) END FUNCTION EXTERNAL FUNCTION ZELLER(Y,M,D) LET ZELLER=MOD(Y+INT(Y/4)-INT(Y/100)+INT(Y/400)+INT((13*M+8)/5)+D,7) !'ツェラーの公式 END FUNCTION EXTERNAL FUNCTION WEEK(Y,M,D) IF M<3 THEN LET YY=Y-1 LET MM=M+12 ELSE LET YY=Y LET MM=M END IF LET WEEK=ZELLER(YY,MM,D) END FUNCTION EXTERNAL FUNCTION DAY$(Y,M,D) !'曜日を求める LET DAY$=MID$("日月火水木金土",WEEK(Y,M,D)+1,1) & "曜日" END FUNCTION EXTERNAL FUNCTION NORMAL(U,M,X) !'正規分布密度関数 LET NORMAL=EXP(-(X-U)*(X-U)/(2*M*M))/SQR(2*PI)/M END FUNCTION EXTERNAL FUNCTION FUN(X) LET FUN=1/X !'ダミー定義 END FUNCTION EXTERNAL FUNCTION FUN2(X,Y) LET FUN2=X^3+X*Y^2-X^2+X*Y+X !'ダミー定義 END FUNCTION EXTERNAL FUNCTION FX(X,Y,H) LET FX=(FUN2(X+H,Y)-FUN2(X,Y))/H !'d/dxF(X,Y) END FUNCTION EXTERNAL FUNCTION FY(X,Y,H) LET FY=(FUN2(X,Y+H)-FUN2(X,Y))/H !'d/dyF(X,Y) END FUNCTION EXTERNAL FUNCTION F3(X,H) LET F3=(FUN(X+H)-FUN(X-H))/(2*H) !'３点微分 END FUNCTION EXTERNAL FUNCTION F5(X,H) LET F5 =(-FUN(X+2*H)+8*FUN(X+H)-8*FUN(X-H)+FUN(X-2*H))/(12*H) !'５点微分 END FUNCTION EXTERNAL FUNCTION FF3(X,H) LET FF3=(FUN(X+H)-2*FUN(X)+FUN(X-H))/(H*H) !'２階３点微分 END FUNCTION EXTERNAL FUNCTION FF5(X,H) LET FF5=(-FUN(X-2*H)+16*FUN(X-H)-30*FUN(X)+16*FUN(X+H)-FUN(X+2*H))/(12*H*H) !'２階５点微分 END FUNCTION EXTERNAL FUNCTION FFF5(X,H) LET FFF5=(-FUN(X-2*H)+2*FUN(X-H)-2*FUN(X+H)+FUN(X+2*H))/(2*H*H*H) !'３階５点微分 END FUNCTION EXTERNAL FUNCTION FXN(XX,H,N) !'n階微分 IF N=0 THEN LET FXN=FUN(XX) ELSE LET FXN=(-FXN(XX+2*H,H,N-1)+8*FXN(XX+H,H,N-1)-8*FXN(XX-H,H,N-1)+FXN(XX-2*H,H,N-1))/(12*H) !'d^n/dx^nF(X) END IF END FUNCTION

Re: 関数

投稿者：しばっち投稿日：2011年11月13日(日)20時13分30秒

> No.1717[元記事へ] 続き EXTERNAL FUNCTION STIRLING(N) LET STIRLING=SQR(N*2*PI)*N^N*EXP(-N) !'FACT(N) END FUNCTION EXTERNAL FUNCTION AREA3(X1,Y1,X2,Y2,X3,Y3) LET AREA3=ABS(X1*Y2+X2*Y3+X3*Y1-Y1*X2-Y2*X3-Y3*X1)/2 !'三角形の面積 END FUNCTION EXTERNAL FUNCTION AREA(N, X(), Y()) !'n角形の面積 LET A = X(N - 1) * Y(1) - X(1) * Y(N - 1) FOR I = 2 TO N - 1 LET A = A + X(I - 1) * Y(I) - X(I) * Y(I - 1) NEXT I LET AREA = ABS(A) / 2 END FUNCTION EXTERNAL FUNCTION NINT(X,N) LET NINT=INT(10^N*X+.5)/10^N END FUNCTION EXTERNAL FUNCTION ISLOWER(X$) IF ORD(X$)>=97 AND ORD(X$)<=122 THEN LET ISLOWER=-1 ELSE LET ISLOWER=0 !'小文字なら真 END FUNCTION EXTERNAL FUNCTION ISUPPER(X$) IF ORD(X$)>=65 AND ORD(X$)<=90 THEN LET ISUPPER=-1 ELSE LET ISUPPER=0 !'大文字なら真 END FUNCTION EXTERNAL FUNCTION ISDIGIT(X$) IF ORD(X$)>=48 AND ORD(X$)<=57 THEN LET ISDIGIT=-1 ELSE LET ISDIGIT=0 !'数字なら真 END FUNCTION EXTERNAL FUNCTION ISALNUM(X$) IF ISLOWER(X$)=-1 OR ISUPPER(X$)=-1 OR ISDIGIT(X$)=-1 THEN LET ISALNUM=-1 ELSE LET ISALNUM=0 END FUNCTION EXTERNAL FUNCTION ISALPHA(X$) IF ISLOWER(X$)=-1 OR ISUPPER(X$)=-1 THEN LET ISALPHA=-1 ELSE LET ISALPHA=0 END FUNCTION EXTERNAL FUNCTION ISGRAPH(X$) IF ORD(X$)>=33 AND ORD(X$)<=126 THEN LET ISGRAPH=-1 ELSE LET ISGRAPH=0 !'印字可能文字なら真（空白除く） END FUNCTION EXTERNAL FUNCTION ISCNTRL(X$) IF ORD(X$)<=31 OR ORD(X$)=127 THEN LET ISCNTRL=-1 ELSE LET ISCNTRL=0 !'制御文字なら真 END FUNCTION EXTERNAL FUNCTION ISPRINT(X$) IF ORD(X$)>=32 AND ORD(X$)<=126 THEN LET ISPRINT=-1 ELSE LET ISPRINT=0 !'印字可能文字なら真 END FUNCTION EXTERNAL FUNCTION ISSPACE(X$) IF ORD(X$)>=9 AND ORD(X$)<=13 OR ORD(X$)=32 THEN LET ISSPACE=-1 ELSE LET ISSPACE=0 !'空白、タブ、復帰、改項、垂直タブ、改頁なら真 END FUNCTION EXTERNAL FUNCTION ISHEXDIGIT(X$) IF ISDIGIT(X$)=-1 OR ORD(X$)>=65 AND ORD(X$)<=70 OR ORD(X$)>=97 AND ORD(X$)<=102 THEN LET ISHEXDIGIT=-1 ELSE LET ISHEXDIGIT=0 !'１６進表示文字なら真 END FUNCTION EXTERNAL FUNCTION ISPUNCT(X$) IF ORD(X$)>=33 AND ORD(X$)<=47 OR ORD(X$)>=58 AND ORD(X$)<=64 OR ORD(X$)>=91 AND ORD(X$)<=96 OR ORD(X$)>=123 AND ORD(X$)<=126 THEN LET ISPUNCT=-1 ELSE LET ISPUNCT=0 !'区切り文字なら真 END FUNCTION EXTERNAL FUNCTION ISKANJI(X$) IF LEN(X$)<>BLEN(X$) THEN LET ISKANJI=-1 ELSE LET ISKANJI=0 !'2バイト文字なら真 END FUNCTION EXTERNAL FUNCTION FIB(N) LET FIB=INT((((1+SQR(5))/2)^N)/SQR(5)+.5) !'フィボナッチ数列 END FUNCTION EXTERNAL FUNCTION FIB2(N) LET A =1 LET B =1 FOR I=1 TO N-2 LET A=A+B LET B=A-B NEXT I LET FIB2=A END FUNCTION EXTERNAL FUNCTION MOVEX(X,N,S) !'テンキーによるキャラクター移動(X方向) IF S=1 OR S=4 OR S=7 THEN LET MOVEX=X+N IF S=3 OR S=6 OR S=9 THEN LET MOVEX=X-N END FUNCTION EXTERNAL FUNCTION MOVEY(Y,N,S) !'テンキーによるキャラクター移動(Y方向) IF S=7 OR S=8 OR S=9 THEN LET MOVEY=Y-N IF S=1 OR S=2 OR S=3 THEN LET MOVEY=Y+N END FUNCTION EXTERNAL FUNCTION MOVEX2(X,N,S) LET MOVEX2=X+N*(MOD((S-1),3)-1) END FUNCTION EXTERNAL FUNCTION MOVEY2(Y,N,S) LET MOVEY2=Y+N*(INT((1-S)/3)+1) END FUNCTION EXTERNAL FUNCTION LAGRANGE2(X0,X1,Y0,Y1,T) LET LAGRANGE2=Y0*(T-X1)/(X0-X1)+Y1*(T-X0)/(X1-X0) !'ラグランジュ補間 END FUNCTION EXTERNAL FUNCTION LAGRANGE3(X0,X1,X2,Y0,Y1,Y2,T) LET LAGRANGE3=((X2-T)*LAGRANGE2(X0,X1,Y0,Y1,T)-(X1-T)*LAGRANGE2(X0,X2,Y0,Y2,T))/(X2-X1) END FUNCTION EXTERNAL FUNCTION LAGRANGE4(X0,X1,X2,X3,Y0,Y1,Y2,Y3,T) LET LAGRANGE4=((X3-T)*LAGRANGE3(X0,X1,X2,Y0,Y1,Y2,T)-(X2-T)*LAGRANGE3(X0,X1,X3,Y0,Y1,Y3,T))/(X3-X2) END FUNCTION EXTERNAL FUNCTION LAGRANGE5(X0,X1,X2,X3,X4,Y0,Y1,Y2,Y3,Y4,T) LET LAGRANGE5=((X4-T)*LAGRANGE4(X0,X1,X2,X3,Y0,Y1,Y2,Y3,T)-(X3-T)*LAGRANGE4(X0,X1,X2,X4,Y0,Y1,Y2,Y4,T))/(X4-X3) END FUNCTION EXTERNAL FUNCTION LAGRANGE(N, X(), Y(), T) FOR I = 1 TO N LET P = Y(I) FOR J = 1 TO N IF I <> J THEN LET P = P * (T - X(J)) / (X(I) - X(J)) !'ラグランジュ補間 NEXT J LET S = S + P NEXT I LET LARGRANGE = S END FUNCTION EXTERNAL FUNCTION Y3(X,X0,Y0,X1,Y1,X2,Y2) LET Y3=((X-X1)*(X-X2))/((X0-X1)*(X0-X2))*Y0+((X-X0)*(X-X2))/((X1-X0)*(X1-X2))*Y1+((X-X0)*(X-X1))/((X2-X0)*(X2-X1))*Y2 !'３点を通る２次方程式 END FUNCTION EXTERNAL FUNCTION EQV(X,Y) LET EQV=BITNOT(BITXOR(X,Y)) !'X EQV Y END FUNCTION EXTERNAL FUNCTION AND2(X,Y) LET AND2=BITNOT(BITOR(BITNOT(X),BITNOT(Y))) !'X AND Y END FUNCTION EXTERNAL FUNCTION OR2(X,Y) LET OR2=BITNOT(BITAND(BITNOT(X),BITNOT(Y))) !'X OR Y END FUNCTION EXTERNAL FUNCTION NAND(X,Y) LET NAND=BITNOT(BITAND(X,Y)) !'X NAND Y END FUNCTION EXTERNAL FUNCTION NAND2(X,Y) LET NAND2=BITOR(BITNOT(X),BITNOT(Y)) END FUNCTION EXTERNAL FUNCTION NOR(X,Y) LET NOR=BITNOT(BITOR(X,Y)) !'X NOR Y END FUNCTION EXTERNAL FUNCTION NOR2(X,Y) LET NOR2=BITAND(BITNOT(X),BITNOT(Y)) END FUNCTION EXTERNAL FUNCTION XOR2(X,Y) LET XOR2=BITNOT(BITOR(BITAND(X,Y),NOR(X,Y))) !'X XOR Y END FUNCTION EXTERNAL FUNCTION XOR3(X,Y) LET XOR3=BITOR(BITAND(BITNOT(X),Y),BITAND(X,BITNOT(Y))) END FUNCTION EXTERNAL FUNCTION XOR4(X,Y) LET XOR4=BITAND(BITOR(X,Y),BITOR(BITNOT(X),BITNOT(Y))) END FUNCTION EXTERNAL FUNCTION XOR5(X,Y) LET XOR5=NAND(NAND(X,BITNOT(Y)),NAND(BITNOT(X),Y)) END FUNCTION EXTERNAL FUNCTION IMP(X,Y) LET IMP=BITOR(BITNOT(X),Y) !'X IMP Y END FUNCTION EXTERNAL FUNCTION IMP2(X,Y) LET IMP2=BITNOT(BITAND(BITNOT(Y),X)) END FUNCTION EXTERNAL FUNCTION NIMP(X,Y) LET NIMP=BITNOT(BITOR(BITNOT(X),Y)) !'X NIMP Y END FUNCTION EXTERNAL FUNCTION NIMP2(X,Y) LET NIMP2=BITAND(BITNOT(Y),X) END FUNCTION EXTERNAL FUNCTION NIMP3(X,Y) LET NIMP3=BITNOT(IMP(X,Y)) END FUNCTION EXTERNAL FUNCTION GCD(M,N) !'最大公約数 DO WHILE N <> 0 LET T = MOD(M , N) LET M = N LET N = T LOOP LET GCD=M END FUNCTION EXTERNAL FUNCTION LCM(A, B) LET LCM=A*B/GCD(A,B) !'最小公倍数 END FUNCTION EXTERNAL FUNCTION LCM3(A, B, C) LET LCM3=A*B*C/GCD(A,B)/GCD(B,C)/GCD(A,C)*GCD(A,GCD(B,C)) END FUNCTION EXTERNAL FUNCTION WHICH(N,X,Y) IF N<>0 THEN LET WHICH=X ELSE LET WHICH=Y END FUNCTION EXTERNAL FUNCTION COSINE(OX, OY, PX, PY, MX, MY) LET COSINE=((PX - OX) * (MX - OX) + (PY - OY) * (MY - OY)) / SQR((PX - OX) * (PX - OX) + (PY - OY) * (PY - OY)) / SQR((MX - OX) * (MX - OX) + (MY - OY) * (MY - OY)) END FUNCTION EXTERNAL FUNCTION COSINE3D(AX,AY,AZ,BX,BY,BZ) LET COSINE3D=(AX*BX+AY*BY+AZ*BZ)/SQR(AX^2+AY^2+AZ^2)/SQR(BX^2+BY^2+BZ^2) END FUNCTION EXTERNAL FUNCTION NSTR$(Y,N) !'N進文字列 LET X=Y LET B$="" DO LET A$=MID$("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",MOD(X,N)+1,1) LET B$=A$&B$ LET X=INT(X/N) LOOP UNTIL X=0 LET NSTR$=B$ END FUNCTION EXTERNAL FUNCTION ANGLE2(X,Y) LET ANGLE2=ASIN(Y/SQR(X*X+Y*Y)) END FUNCTION

Re: 作図サブルーチン集（直線、円、2次関数とグラフ）実用編

投稿者：山中和義投稿日：2011年11月16日(水)09時50分14秒

> No.1690[元記事へ] !図形と方程式 SET WINDOW -8,8,-8,8 !表示領域を設定する　※ !SET WINDOW -1.2,1.2,-1.2,1.2 !表示領域を設定する　※ DRAW grid !XY座標 PUBLIC NUMERIC cEps !精度　※調整が必要である LET cEPS=1E-8 PUBLIC NUMERIC cINF !∞ LET cINF=999999 PUBLIC NUMERIC gcCOLOR,gcSTYLE,gcLINESTYLE !描画色、線種 LET gcCOLOR=1 LET gcLINESTYLE=1 !------------------------------ ここまでがサブルーチン !●3直線の交点を通る円を求めよ。 LET gcN=3 !動点の数 DIM gcX(gcN),gcY(gcN) !制御点の座標 DATA -3,-5 DATA 5,-2 DATA 1,4 FOR i=1 TO gcN READ gcX(i),gcY(i) NEXT i !------------------------------ LET FLG=1 DO IF FLG=1 THEN !再描画が必要なら LET FLG=0 SET DRAW MODE HIDDEN !ちらつき防止開始 CLEAR DRAW grid CALL frame(gcN,gcX,gcY) SET DRAW MODE EXPLICIT !ちらつき防止終了 END IF MOUSE POLL mx,my,left,right !マウスの位置、ボタン状態を読み込む FOR i=1 TO gcN IF DIST(mx,my,gcX(i),gcY(i))<=0.4 AND left=1 THEN !近傍を左ドラッグされたなら LET gcX(i)=mx !移動する LET gcY(i)=my LET FLG=1 EXIT FOR !１つだけ END IF NEXT i LOOP UNTIL right=1 !右クリックされるまで SUB frame(N,MX(),MY()) !作図 LET gcCOLOR=8 FOR i=1 TO N !制御点を描く CALL gcDRAWPOINT(MX(i),MY(i),"") NEXT i LET gcCOLOR=1 CALL gcLINE(MX(1),MY(1),MX(2),MY(2), L1,M1,N1) CALL gcDRAWLINE(L1,M1,N1,"L1",2) !直線1を描く LET gcCOLOR=2 CALL gcLINE(MX(2),MY(2),MX(3),MY(3), L2,M2,N2) CALL gcDRAWLINE(L2,M2,N2,"L2",2) !直線2を描く LET gcCOLOR=4 CALL gcLINE(MX(3),MY(3),MX(1),MY(1), L3,M3,N3) CALL gcDRAWLINE(L3,M3,N3,"L3",2) !直線3を描く !3直線L1x+M1y+N1=0、L2x+M2y+N2=0、L3x+M3y+N3=0を通る !円錐曲線 s(L1x+M1y+N1)(L2x+M2y+N2)+t(L2x+M2y+N2)(L3x+M3y+N3)+(L3x+M3y+N3)(L1x+M1y+N1)=0 !円となるには、 !・x^2とy^2の係数が0でなく等しい !・xyの係数が0である !が条件となる。 !係数を調べると、 !sL1L2+tL2L3+L3L1=tM1M2+tM1M2+M3M1≠0、s(L1M2+M1L2)+t(L2M3+M2L3)+(L3M1+M3L1)=0 !　┌ L1L2-M1M2 L2L3-M2M3 ┐┌ s ┐ = ┌ -L3L1+M3M1 ┐ !　└ L1M2+M1L2 L2M3+M2L3 ┘└ t ┘ └ -L3M1-L1M3 ┘ !これを解いて !　┌ s ┐ = 1/(L2^2+M2^2)(L1M3-L3M1) ┌ L2M3+M2L3 -(L2L3-M2M3) ┐┌ -L3L1+M3M1 ┐ !　└ t ┘ └ -(L1M2+M1L2) L1L2-M1M2 ┘└ -L3M1-L1M3 ┘ LET u=(L2^2+M2^2)*(L1*M3-L3*M1) LET s=( (L2*M3+M2*L3)*(-L3*L1+M3*M1) + (-(L2*L3-M2*M3))*(-L3*M1-L1*M3) ) / u LET t=( -(L1*M2+M1*L2)*(-L3*L1+M3*M1) + (L1*L2-M1*M2)*(-L3*M1-L1*M3) ) / u LET u=s*L1*L2+t*L2*L3+L3*L1 !x^2の係数 LET A=( s*(L1*N2+L2*N1)+t*(L2*N3+L3*N2)+(L3*N1+L1*N3) ) / u LET B=( s*(M1*N2+M2*N1)+t*(M2*N3+M3*N2)+(M3*N1+M1*N3) ) / u LET C=( s*N1*N2+t*N2*N3+N3*N1 ) / u LET gcCOLOR=1 CALL gcDRAWCIRCLE(A,B,C,"",0) !求める円を描く END SUB END !作図ルーチン EXTERNAL SUB gcDRAWPOINT(x,y,s$) !点(x,y)を描く ASK WINDOW x1,x2,y1,y2 SET AREA COLOR gcCOLOR DRAW disk WITH SCALE(ABS(x1-x2)/100)*SHIFT(x,y) !※拡大率0.1は調整が必要である !!!DRAW disk WITH SCALE(0.1)*SHIFT(x,y) !※拡大率0.1は調整が必要である IF s$<>"" THEN PLOT TEXT ,AT x,y: s$ END SUB EXTERNAL SUB gcDRAWLINE(L,M,N,s$,o) !直線Lx+My+N=0を描く IF (L=0 AND M=0) THEN PRINT "L=M=0なので、直線が成立しません。"; L;M;N ELSE ASK WINDOW x1,x2,y1,y2 SET LINE COLOR gcCOLOR SET LINE STYLE gcLINESTYLE IF ABS(L)>ABS(M) THEN !y=±xの傾きより大きいなら　※y軸に平行な直線を含む PLOT LINES: -(M*y1+N)/L,y1; -(M*y2+N)/L,y2 ELSE PLOT LINES: x1,-(L*x1+N)/M; x2,-(L*x2+N)/M END IF IF s$<>"" THEN !注釈 IF M=0 THEN !y軸に平行なら LET x=-N/L !x切片 LET y=0 ELSEIF L=0 THEN !x軸に平行なら LET x=0 !y切片 LET y=-N/M ELSE !x軸とy軸の両方と交差するなら（いわゆる斜めの直線） SELECT CASE o !記入位置 CASE 0 !y切片 LET x=0 LET y=-N/M CASE 1 !x切片 LET x=-N/L LET y=0 CASE 2 !x切片とy切片との中点 LET x=-N/L*0.5 LET y=-N/M*0.5 CASE ELSE END SELECT END IF PLOT TEXT ,AT x,y: s$ END IF END IF END SUB EXTERNAL SUB gcDRAWCIRCLE(A,B,C,s$,o) !円x^2+y^2+Ax+By+C=0を描く LET RR=(A^2+B^2)/4-C !判別式 IF RR>=0 THEN SET LINE COLOR gcCOLOR SET LINE STYLE gcLINESTYLE LET CX=-A/2 !中心 LET CY=-B/2 LET R=SQR(RR) !半径 FOR i=0 TO 360 !(x-CX)^2+(y-CY)^2=R^2として描く PLOT LINES: R*COS(RAD(i))+CX,R*SIN(RAD(i))+CY; NEXT i PLOT LINES IF s$<>"" THEN !注釈 SELECT CASE o !記入位置 CASE 0 !右 LET x=CX+R LET y=CY CASE 1 !上 LET x=CX LET y=CY+R CASE 2 !右上 LET x=R*SQR(2)/2+CX !45度 LET y=R*SQR(2)/2+CY CASE ELSE END SELECT PLOT TEXT ,AT x,y: s$ END IF ELSE PRINT "半径が負なので、円が成立しません。"; A;B;C END IF END SUB EXTERNAL SUB gcDRAWFNC2(A,B,C,d1,d2) !2次関数y=Ax^2+Bx+C、x=[d1,d2]を描く IF A=0 THEN PRINT "A=0なので、2次関数ではありません。"; A;B;C ELSE ASK WINDOW x1,x2,y1,y2 LET x1=MAX(x1,d1) LET x2=MIN(x2,d2) SET LINE COLOR gcCOLOR FOR x=x1 TO x2 STEP 1/2^8 !※折れ線による PLOT LINES: x,A*x^2+B*x+C; NEXT x PLOT LINES END IF END SUB !補助ルーチン EXTERNAL FUNCTION DIST(x1,y1,x2,y2) !2点(x1,y1),(x2,y2)間の距離 LET DIST=SQR((x1-x2)^2+(y1-y2)^2) END FUNCTION !点(x,y)と直線Lx+My+N=0との距離（点から直線へ下した垂線の長さ） EXTERNAL FUNCTION DIST1L(x,y,L,M,N) LET DIST1L=ABS(L*x+M*y+N)/SQR(L^2+M^2) END FUNCTION EXTERNAL FUNCTION D2Equ(a,b,c) !2次方程式ax^2+bx+c=0の判別式を計算する IF a=0 THEN PRINT "2次の係数が0なので、2次方程式ではありません。"; a;b;c ELSE LET D2Equ=b^2-4*a*c END IF END FUNCTION !演算ルーチン !●直線 !2点(x1,y1), (x2,y2)を通る直線Lx+My+N=0 !公式　-(y2-y1)(x-x1)+(x2-x1)(y-y1)=0 より EXTERNAL SUB gcLINE(x1,y1,x2,y2, L,M,N) IF (x1=x2 AND y1=y2) THEN !同一点なら PRINT "異なる2点ではないので、直線が成立しません。"; x1;y1;x2;y2 ELSE LET L=y1-y2 LET M=x2-x1 LET N=x1*y2-y1*x2 END IF END SUB

Re: 作図サブルーチン集（直線、円、2次関数とグラフ）実用編

投稿者：山中和義投稿日：2011年11月16日(水)10時17分42秒

> No.1719[元記事へ] !図形と方程式 SET WINDOW -8,8,-8,8 !表示領域を設定する　※ !SET WINDOW -1.2,1.2,-1.2,1.2 !表示領域を設定する　※ DRAW grid !XY座標 PUBLIC NUMERIC cEps !精度　※調整が必要である LET cEPS=1E-8 PUBLIC NUMERIC cINF !∞ LET cINF=999999 PUBLIC NUMERIC gcCOLOR,gcSTYLE,gcLINESTYLE !描画色、線種 LET gcCOLOR=1 LET gcLINESTYLE=1 !------------------------------ ここまでがサブルーチン !●直線と2次関数との2交点と他の1点を通る円 LET L=1 !直線x-y+1=0 LET M=-1 LET N=1 CALL gcDRAWLINE(L,M,N,"L",1) LET A=1 !2次関数y=x^2-2x LET B=-2 LET C=0 CALL gcDRAWFNC2(A,B,C,-3,5) LET x=5 !通過点P LET y=-3 LET gcCOLOR=2 CALL gcDRAWPOINT(x,y,"P") !　直線Lx+My+N=0、2次関数y=Ax^2+Bx+C !　xを消去する。L^2y=A(-My-N)^2+LB(-My-N)+L^2C　∴AM^2y^2+(2AMN-LBM-L^2)y+(L^2C+AN^2-LBN)=0　←式1 !　yを消去する。(-Lx-N)/M=Ax^2+Bx+C　∴x^2+((B+L/M)/A)x+(C+N/M)/A=0　←式2 !　直線と2次関数の交点を直径の両端とする円は、式1,式2より、式1+式2=0と表される。 !　よって、(直径円)+k(直線)=0は、点(x,y)を通るので、代入して、kを求める。 LET t=L*x+M*y+N !判別式 IF (M=0 AND L=0) OR A=0 THEN PRINT "直線（L=0かつM=0）または2次関数（A=0）ではありません。"; L;M;N; A;B;C ELSEIF M=0 THEN PRINT "垂直線（y軸の平行）では交点が1つです。"; L;M;N ELSEIF t=0 THEN PRINT "直線上の点です。"; x;y; L;M;N ELSE IF D2Equ(A,B+L/M,C+N/M)>0 THEN !判別式より LET w1=(B+L/M)/A LET w2=(2*A*M*N-L*B*M-L^2)/(A*M^2) LET w3=(L^2*C+A*N^2-L*B*N)/(A*M^2)+(C+N/M)/A LET k=-(x^2+y^2+w1*x+w2*y+w3) / t PRINT k !debug LET P=w1 + k*L LET Q=w2 + k*M LET R=w3 + k*N ELSE PRINT "直線と2次関数との交点が2つありません。"; L;M;N; A;B;C END IF END IF LET gcCOLOR=2 CALL gcDRAWCIRCLE(P,Q,R,"",0) !求める円を描く !●直線と円との2交点と他の1点を通る2次関数 LET A=-7 !円x^2+y^2-7x-y-2=0 LET B=-1 LET C=-2 !!CALL gcDRAWCIRCLE(A,B,C,"",0) LET x=-2 !通過点P LET y=-5 LET gcCOLOR=4 CALL gcDRAWPOINT(x,y,"Q") !　直線Lx+My+N=0、円x^2+y^2+Ax+By+C=0 !　直線と円との交点を通る曲線は、(Lx+My+N)(-Lx+My+k)+j(x^2+y^2+Ax+By+C)=0と表される。 !　j=-M^2として、-(L^2+M^2)x^2-(LN+AM^2)x+(MN-BM^2)y-CM^2) + k(Lx+My+N) = 0 !　よって、(2次関数)+k(直線)=0は、点(x,y)を通るので、代入して、kを求める。 LET t=L*x+M*y+N !判別式 LET RR=(A^2+B^2)/4-C !判別式 IF (M=0 AND L=0) THEN PRINT "L=0かつM=0なので、直線ではありません。"; L;M;N ELSEIF RR<=0 THEN PRINT "半径が0または負なので、円ではありません。"; A;B;C ELSEIF M=0 THEN PRINT "垂直線（y軸の平行）では交点が1つです。"; L;M;N ELSEIF t=0 THEN PRINT "直線上の点です。"; x;y; L;M;N ELSE IF DIST1L(-A/2,-B/2,L,M,N)^2<RR THEN !直線と円の中心との距離＜円の半径なら LET k=((L^2+M^2)*x^2+(L*N+A*M^2)*x-(M*N-B*M^2)*y+C*M^2)/t PRINT k !debug LET w=M*N-B*M^2 + k*M LET P=( L^2+M^2 )/w LET Q=( L*N+A*M^2 - k*L )/w LET R=( C*M^2 - k*N )/w ELSE PRINT "直線と円との交点が2つありません。"; L;M;N; A;B;C END IF END IF LET gcCOLOR=4 CALL gcDRAWFNC2(P,Q,R,-6,8) !求める2次関数を描く END 作図ルーチンは省略します。

断面性能（面積、モーメント）

投稿者：山中和義投稿日：2011年12月12日(月)19時56分1秒

!座標法で図形（多角形）の断面性能を求める DATA 12 !頂点の個数　I型 DATA 0, 0 !頂点の座標 DATA 25, 0 DATA 25, 2.5 DATA 13.1, 2.5 DATA 13.1, 47.5 DATA 25, 47.5 DATA 25, 50 DATA 0, 50 DATA 0, 47.5 DATA 11.9, 47.5 DATA 11.9, 2.5 DATA 0, 2.5 !LET CX=20 !中心位置　※円型　多角形による近似 !LET CY=10 !LET R=30 !半径 ! !LET N=360 !頂点の個数 !DIM X(N),Y(N) !頂点の座標 !FOR i=1 TO N ! LET X(i)=R*COS(RAD(i-1))+CX ! LET Y(i)=R*SIN(RAD(i-1))+CY !NEXT i READ N !頂点の個数 DIM X(N),Y(N) !頂点の座標 FOR i=1 TO N READ X(i),Y(i) NEXT i CALL MOAofPolygon(N,X,Y, Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy) !基本 CALL MOA_Print(Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy) !基本を表示する CALL MOA_Print2(Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy, ALPHA) !その他 !●形状を描く LET w=Dr-Dl !幅　※多角形の大きさ LET h=Du-Dd !高さ LET t=MAX(w,h) !縦横の比率を合わせる LET xx1=Dl-t*0.1 LET xx2=Dl+t*1.1 LET yy1=Dd-t*0.1 LET yy2=Dd+t*1.1 SET WINDOW xx1,xx2,yy1,yy2 !表示領域を設定する IF t>=10 THEN DRAW grid(INT(t/10),INT(t/10)) !座標を描く ELSE DRAW grid(t/10,t/10) !座標を描く END IF CALL gcDRAWPOLYGON(N,X,Y) !多角形の形状を描く CALL gcDRAWPOINT(Xg,Yg,"G") !図心位置 SET LINE COLOR 4 !赤色 LET L=TAN(ALPHA) !u軸　※点(x1,y1)と通り、傾きαの直線は、Y-y1=tanα(X-x1)より LET M=-1 LET N=-L*Xg+Yg CALL gcDRAWLINE(L,M,N) SET LINE COLOR 3 !緑色 LET A=-M !v軸　※点(x1,y1)と通り、直線Lx+My+N=0に垂直な直線は、L(y-y1)=M(x-x1)より LET B=L LET C=-L*Yg+M*Xg CALL gcDRAWLINE(A,B,C) SET LINE COLOR 2 !青色 PLOT LINES: Dl,Dd; Dr,Dd; Dr,Du; Dl,Du; Dl,Dd !AABB（軸並行境界ボックス: Axis-Aligned Bounding Box） END !多角形 !反時計まわりに与えられた多角形の頂点が示す座標を(X[i],Y[i])、i=1,2,…,N とする。 !また、X[N+1]=X[1],Y[N+1]=Y{1]とする。 !・辺どうしが交差しない。 !・凸でも凹でも構わない。 !●断面積（sectional area、断面0次モーメント）　単位: mm^2 !　反時計まわりを正とする符号付面積である。 !　S=∫dS=(1/2)Σ[i=1,N]{ X(i)*Y(i+1)-X(i+1)*Y(i) }　辺と原点からなる三角形の面積の和（2次元外積による） !　Ax=(1/2)Σ[i=1,N]{ (X(i)-X(i+1))*(Y(i)+Y(i+1)) }　辺とX軸からなる台形の面積の和 !　Ay=(1/2)Σ[i=1,N]{ (Y(i+1)-Y(i))*(X(i)+X(i+1)) }　辺とY軸からなる台形の面積の和 !　S=Ax=Ay ! !以下、三角形の面積（2次元外積による）を基準に、 ! !●原点からX軸方向、原点からY軸方向の断面1次モーメント（statical moment of area）　単位: mm^3 !　Sx=∫ydS=(1/6)Σ[i=1,N]{ (X(i)*Y(i+1)-X(i+1)*Y(i)) * (X(i)+X(i+1)) } !　Sy=∫xdS=(1/6)Σ[i=1,N]{ (X(i)*Y(i+1)-X(i+1)*Y(i)) * (Y(i)+Y(i+1)) } !図心Xg軸回り、図心Yg軸回りの断面1次モーメント !　Sxg=Syg=0 ! !●図心（centroid）　単位: mm　　※荷重分布が均一なら、重心となる !　Xg=Sx/S !　Yg=Sy/S ! !●X軸回り、Y軸回りの断面2次モーメント（moment of inertia of area）　単位: mm^4 !　Jx=∫y^2dS=(1/24)Σ[i=1,N]{ (X(i)*Y(i+1)-X(i+1)*Y(i)) * ((Y(i)+Y(i+1))^2+Y(i)^2+Y(i+1)^2) } !　Jy=∫x^2dS=(1/24)Σ[i=1,N]{ (X(i)*Y(i+1)-X(i+1)*Y(i)) * ((X(i)+X(i+1))^2+X(i)^2+X(i+1)^2) } !図心Xg軸回り、図心Yg軸回りの断面2次モーメント !　Jxg=Jx-S*Yg^2 !　Jyg=Jy-S*Xg^2 ! !●原点回りの断面相乗モーメント（product of inertia of area）　単位: mm^4 !　Jxy=∫xydS=(1/24)Σ[i=1,N]{ (X(i)*Y(i+1)-X(i+1)*Y(i)) * ((X(i)+X(i+1))*(Y(i)+Y(i+1))+X(i)*Y(i)+X(i+1)*Y(i+1)) } !図心回りの断面相乗モーメント !　Jxyg=Jxy-S*Xg*Yg EXTERNAL SUB MOAofPolygon(N,X(),Y(), Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy) !基本 LET a=X(N) !Σ部分 LET b=Y(N) LET c=X(1) LET d=Y(1) LET Du=b !座標の最大値、最小値を探す LET Dd=b LET Dl=a LET Dr=a LET wx=a+c LET wy=b+d LET S=a*d-b*c LET Sx=S*wx LET Sy=S*wy LET Jx=S*(wy*wy-b*d)*2 LET Jy=S*(wx*wx-a*c)*2 LET Jxy=S*(wx*wy+(a*b+c*d)) FOR i=1 TO N-1 LET a=X(i) !原点、点(a,b)、点(c,d)の3点 LET b=Y(i) LET c=X(i+1) LET d=Y(i+1) IF b>Du THEN LET Du=b !上端 IF b<Dd THEN LET Dd=b !下端 IF a<Dl THEN LET Dl=a !左端 IF a>Dr THEN LET Dr=a !右端 LET wx=a+c !※似た式が多いので、まとめて乗算の回数が減るように式を変形した LET wy=b+d LET t=a*d-b*c LET S=S+t LET Sx=Sx+t*wx LET Sy=Sy+t*wy LET Jx=Jx+t*(wy*wy-b*d)*2 LET Jy=Jy+t*(wx*wx-a*c)*2 LET Jxy=Jxy+t*(wx*wy+(a*b+c*d)) NEXT i LET S=S/2 !定数部分 LET Sx=Sx/6 LET Sy=Sy/6 LET Xg=Sx/S LET Yg=Sy/S LET Jx=Jx/24 LET Jy=Jy/24 LET Jxy=Jxy/24 END SUB EXTERNAL SUB MOA_Print(Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy) !基本を表示する PRINT "上端=";Du; "下端=";Dd; "左端=";Dl; "右端=";Dr PRINT "断面積 S=";S PRINT "断面1次モーメント（原点からX軸方向）Sx=";Sx; "（原点からY軸方向）Sy=";Sy PRINT "図心 Xg=";Xg; "Yg=";Yg PRINT "断面2次モーメント（X軸回り）Jx=";Jx; "（Y軸回り）Jy=";Jy PRINT "断面相乗モーメント（原点回り）Jxy=";Jxy END SUB EXTERNAL SUB MOA_Print2(Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy, ALPHA) !その他 LET Jxg=Jx-S*Yg^2 LET Jyg=Jy-S*Xg^2 PRINT "断面2次モーメント（図心Xg軸回り）Jxg=";Jxg; "（図心Yg軸回り）Jyg=";Jyg LET Jxyg=Jxy-S*Xg*Yg PRINT "断面相乗モーメント（図心回り）Jxyg=";Jxyg PRINT !●原点回りの断面2次極モーメント　単位: mm^4 !　Jd=∫r^2dS=∫(x^2+y^2)dS=Jx+Jy !図心回りの断面2次極モーメント !　Jdg=Jxg+Jyg LET Jd=Jx+Jy PRINT "断面2次極モーメント（原点回り）Jd=";Jd LET Jdg=Jxg+Jyg PRINT "断面2次極モーメント（図心回り）Jdg=";Jdg !●断面2次半径　単位: mm !　Rx=√(Jx/S) !　Ry=√(Jy/S) !図心Xg軸回り、図心Yg軸回りの断面2次半径 !　Rxg=√(Jxg/S) !　Ryg=√(Jyg/S) !図心回りの断面2次半径 !　Rxyg=√(Rxg^2+Ryg^2) LET Rx=SQR(Jx/S) LET Ry=SQR(Jy/S) PRINT "断面2次半径（X軸回り）Rx=";Rx; "（Y軸回り）Ry=";Ry LET Rxg=SQR(Jxg/S) LET Ryg=SQR(Jyg/S) PRINT "断面2次半径（図心Xg軸回り）Rxg=";Rxg; "（図心Yg軸回り）Ryg=";Ryg LET Rxyg=SQR(Rxg^2+Ryg^2) PRINT "断面2次半径（図心回り）Rxyg=";Rxyg !●断面係数（section modulus）　単位: mm^3 !　上端 Wu=Jyg/d　dは、図心から上端までの距離 !　下端 Wd=Jyg/d　dは、図心から下端までの距離 !　左端 Wl=Jxg/d　dは、図心から左端までの距離 !　右端 Wr=Jxg/d　dは、図心から右端までの距離 LET Mu=Jxg/(Du-Yg) !図心を基準にする LET Md=Jxg/(Yg-Dd) LET Ml=Jyg/(Xg-Dl) LET Mr=Jyg/(Dr-Xg) PRINT "断面係数（上端）Mu=";Mu; "（下端）Md=";Md PRINT "　　　　（左端）Ml=";Ml; "（右端）Mr=";Mr PRINT !●X軸からの主軸の角度α　単位: ラジアン !　α=(1/2)ArcTan( (-2*Jxy)/(Jx-Jy) ) IF Jy-Jx=0 THEN LET ALPHA=PI ELSE LET ALPHA=ATN( (2*Jxy)/(Jy-Jx) )/2 END IF PRINT "主軸の角度=";DEG(ALPHA);"°" !●主軸回りの断面2次モーメント（固有断面2次モーメント）　単位: mm^4 !　Ju=( Jx+Jy + √((Jx-Jy)^2 + 4*Jxy^2) ) / 2 !　Jv=( Jx+Jy - √((Jx-Jy)^2 + 4*Jxy^2) ) / 2 !　Juv=0 LET t=SQR((Jx-Jy)^2+4*Jxy^2) LET Ju=(Jx+Jy+t)/2 LET Jv=(Jx+Jy-t)/2 LET Juv=0 PRINT "断面2次モーメント（主軸u軸回り）Ju=";Ju; "（v軸回り）Jv=";Jv !!PRINT "断面2次モーメント（主軸回り）Juv=";Juv END SUB !作図ツール EXTERNAL SUB gcDRAWPOINT(x,y,s$) !点を描く PLOT POINTS: x,y PLOT TEXT ,AT x,y: s$ END SUB EXTERNAL SUB gcDRAWLINE(L,M,N) !直線Lx+My+N=0を描く IF (L=0 AND M=0) THEN PRINT "L=M=0なので、直線が成立しません。"; L;M;N ELSE ASK WINDOW x1,x2,y1,y2 IF ABS(L)>ABS(M) THEN !y=±xの傾きより大きいなら　※y軸に平行な直線を含む PLOT LINES: -(M*y1+N)/L,y1; -(M*y2+N)/L,y2 ELSE PLOT LINES: x1,-(L*x1+N)/M; x2,-(L*x2+N)/M END IF END IF END SUB EXTERNAL SUB gcDRAWPOLYGON(N,X(),Y()) !多角形を描く FOR i=1 TO N !折れ線でつなぐ PLOT LINES: X(i),Y(i); NEXT i PLOT LINES: X(1),Y(1) !閉じる END SUB 実行結果上端= 50 下端= 0 左端= 0 右端= 25 断面積 S= 179 断面1次モーメント（原点からX軸方向）Sx= 2237.5 （原点からY軸方向）Sy= 4475 図心 Xg= 12.5 Yg= 25 断面2次モーメント（X軸回り）Jx= 191560.416666667 （Y軸回り）Jy= 34485.6466666667 断面相乗モーメント（原点回り）Jxy= 55937.5 断面2次モーメント（図心Xg軸回り）Jxg= 79685.416666667 （図心Yg軸回り）Jyg= 6516.8966666667 断面相乗モーメント（図心回り）Jxyg= 0 断面2次極モーメント（原点回り）Jd= 226046.063333334 断面2次極モーメント（図心回り）Jdg= 86202.3133333337 断面2次半径（X軸回り）Rx= 32.7134517517199 （Y軸回り）Ry= 13.8801024473114 断面2次半径（図心Xg軸回り）Rxg= 21.0990503462148 （図心Yg軸回り）Ryg= 6.03384155806719 断面2次半径（図心回り）Rxyg= 21.9448665856042 断面係数（上端）Mu= 3187.41666666668 （下端）Md= 3187.41666666668 　　　　（左端）Ml= 521.351733333336 （右端）Mr= 521.351733333336 主軸の角度=-17.7300030228545 ° 断面2次モーメント（主軸u軸回り）Ju= 209444.630641628 （v軸回り）Jv= 16601.4326917054

Re: 断面性能（面積、モーメント）

投稿者：山中和義投稿日：2011年12月13日(火)10時23分11秒

> No.1721[元記事へ] 図形を分けて考える。 ●例１ !座標法で図形（多角形）の断面性能を求める !エ = ━ + ┃ + ━ DATA 4 !頂点の個数　※下フランジ DATA 0, 0 !頂点の座標 DATA 25, 0 DATA 25, 2.5 DATA 0, 2.5 READ N1 !頂点の個数 DIM X1(N1),Y1(N1) !頂点の座標 FOR i=1 TO N1 READ X1(i),Y1(i) NEXT i CALL MOAofPolygon(N1,X1,Y1, Du1,Dd1,Dl1,Dr1, S1,Sx1,Sy1,Xg1,Yg1,Jx1,Jy1,Jxy1) !基本 CALL MOA_Print(Du1,Dd1,Dl1,Dr1, S1,Sx1,Sy1,Xg1,Yg1,Jx1,Jy1,Jxy1) !基本を表示する PRINT DATA 4 !頂点の個数　※ウェブ DATA 11.9, 2.5 !頂点の座標 DATA 13.1, 2.5 DATA 13.1, 47.5 DATA 11.9, 47.5 READ N2 !頂点の個数 DIM X2(N2),Y2(N2) !頂点の座標 FOR i=1 TO N2 READ X2(i),Y2(i) NEXT i CALL MOAofPolygon(N2,X2,Y2, Du2,Dd2,Dl2,Dr2, S2,Sx2,Sy2,Xg2,Yg2,Jx2,Jy2,Jxy2) !基本 CALL MOA_Print(Du2,Dd2,Dl2,Dr2, S2,Sx2,Sy2,Xg2,Yg2,Jx2,Jy2,Jxy2) !基本を表示する PRINT DATA 4 !頂点の個数　※上フランジ DATA 0, 47.5 !頂点の座標 DATA 25, 47.5 DATA 25, 50 DATA 0, 50 READ N3 !頂点の個数 DIM X3(N3),Y3(N3) !頂点の座標 FOR i=1 TO N3 READ X3(i),Y3(i) NEXT i CALL MOAofPolygon(N3,X3,Y3, Du3,Dd3,Dl3,Dr3, S3,Sx3,Sy3,Xg3,Yg3,Jx3,Jy3,Jxy3) !基本 CALL MOA_Print(Du3,Dd3,Dl3,Dr3, S3,Sx3,Sy3,Xg3,Yg3,Jx3,Jy3,Jxy3) !基本を表示する PRINT LET Du=MAX(MAX(Du1,Du2),Du3) !3つの形状を合わせる LET Dd=MIN(MIN(Dd1,Dd2),Dd3) LET Dl=MIN(MIN(Dl1,Dl2),Dl3) LET Dr=MAX(MAX(Dr1,Dr2),Dr3) LET S=S1+S2+S3 LET Sx=Sx1+Sx2+Sx3 LET Sy=Sy1+Sy2+Sy3 LET Xg=(Xg1*S1+Xg2*S2+Xg3*S3)/S LET Yg=(Yg1*S1+Yg2*S2+Yg3*S3)/S LET Jx=Jx1+Jx2+Jx3 LET Jy=Jy1+Jy2+Jy3 LET Jxy=Jxy1+Jxy2+Jxy3 CALL MOA_Print(Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy) !基本を表示する CALL MOA_Print2(Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy, ALPHA) !その他 !●形状を描く LET w=Dr-Dl !幅　※多角形の大きさ LET h=Du-Dd !高さ LET t=MAX(w,h) !縦横の比率を合わせる LET xx1=Dl-t*0.1 LET xx2=Dl+t*1.1 LET yy1=Dd-t*0.1 LET yy2=Dd+t*1.1 SET WINDOW xx1,xx2,yy1,yy2 !表示領域を設定する IF t>=10 THEN DRAW grid(INT(t/10),INT(t/10)) !座標を描く ELSE DRAW grid(t/10,t/10) !座標を描く END IF CALL gcDRAWPOLYGON(N1,X1,Y1) !多角形の形状を描く CALL gcDRAWPOLYGON(N2,X2,Y2) CALL gcDRAWPOLYGON(N3,X3,Y3) CALL gcDRAWPOINT(Xg,Yg,"G") !図心位置 SET LINE COLOR 4 !赤色 LET L=TAN(ALPHA) !u軸　※点(x1,y1)と通り、傾きαの直線は、Y-y1=tanα(X-x1)より LET M=-1 LET N=-L*Xg+Yg CALL gcDRAWLINE(L,M,N) SET LINE COLOR 3 !緑色 LET A=-M !v軸　※点(x1,y1)と通り、直線Lx+My+N=0に垂直な直線は、L(y-y1)=M(x-x1)より LET B=L LET C=-L*Yg+M*Xg CALL gcDRAWLINE(A,B,C) SET LINE COLOR 2 !青色 PLOT LINES: Dl,Dd; Dr,Dd; Dr,Du; Dl,Du; Dl,Dd !AABB（軸並行境界ボックス: Axis-Aligned Bounding Box） END ※サブルーチン部分は省略します。実行結果上端= 2.5 下端= 0 左端= 0 右端= 25 断面積 S= 62.5 断面1次モーメント（原点からX軸方向）Sx= 781.25 （原点からY軸方向）Sy= 78.125 図心 Xg= 12.5 Yg= 1.25 断面2次モーメント（X軸回り）Jx= 130.208333333333 （Y軸回り）Jy= 13020.8333333333 断面相乗モーメント（原点回り）Jxy= 976.5625 上端= 47.5 下端= 2.5 左端= 11.9 右端= 13.1 断面積 S= 54 断面1次モーメント（原点からX軸方向）Sx= 675 （原点からY軸方向）Sy= 1350 図心 Xg= 12.5 Yg= 25 断面2次モーメント（X軸回り）Jx= 42862.5 （Y軸回り）Jy= 8443.98 断面相乗モーメント（原点回り）Jxy= 16875 上端= 50 下端= 47.5 左端= 0 右端= 25 断面積 S= 62.5 断面1次モーメント（原点からX軸方向）Sx= 781.25 （原点からY軸方向）Sy= 3046.875 図心 Xg= 12.5 Yg= 48.75 断面2次モーメント（X軸回り）Jx= 148567.708333333 （Y軸回り）Jy= 13020.8333333333 断面相乗モーメント（原点回り）Jxy= 38085.9375 上端= 50 下端= 0 左端= 0 右端= 25 断面積 S= 179 断面1次モーメント（原点からX軸方向）Sx= 2237.5 （原点からY軸方向）Sy= 4475 図心 Xg= 12.5 Yg= 25 断面2次モーメント（X軸回り）Jx= 191560.416666666 （Y軸回り）Jy= 34485.6466666666 断面相乗モーメント（原点回り）Jxy= 55937.5 断面2次モーメント（図心Xg軸回り）Jxg= 79685.416666666 （図心Yg軸回り）Jyg= 6516.8966666666 断面相乗モーメント（図心回り）Jxyg= 0 断面2次極モーメント（原点回り）Jd= 226046.063333333 断面2次極モーメント（図心回り）Jdg= 86202.3133333326 断面2次半径（X軸回り）Rx= 32.7134517517198 （Y軸回り）Ry= 13.8801024473113 断面2次半径（図心Xg軸回り）Rxg= 21.0990503462147 （図心Yg軸回り）Ryg= 6.03384155806714 断面2次半径（図心回り）Rxyg= 21.944866585604 断面係数（上端）Mu= 3187.41666666664 （下端）Md= 3187.41666666664 　　　　（左端）Ml= 521.351733333328 （右端）Mr= 521.351733333328 主軸の角度=-17.7300030228546 ° 断面2次モーメント（主軸u軸回り）Ju= 209444.630641627 （v軸回り）Jv= 16601.4326917053 ●例２ !座標法で図形（多角形）の断面性能を求める !エ = □ - ロ - ロ DATA 4 !頂点の個数　I型 DATA 0, 0 !頂点の座標　全体の矩形 DATA 25, 0 DATA 25, 50 DATA 0, 50 READ N1 !頂点の個数 DIM X1(N1),Y1(N1) !頂点の座標 FOR i=1 TO N1 READ X1(i),Y1(i) NEXT i CALL MOAofPolygon(N1,X1,Y1, Du1,Dd1,Dl1,Dr1, S1,Sx1,Sy1,Xg1,Yg1,Jx1,Jy1,Jxy1) !基本 CALL MOA_Print(Du1,Dd1,Dl1,Dr1, S1,Sx1,Sy1,Xg1,Yg1,Jx1,Jy1,Jxy1) !基本を表示する PRINT DATA 4 DATA 13.1, 2.5 !ウェブ右側　※差の図形は右回り DATA 13.1, 47.5 DATA 25, 47.5 DATA 25, 2.5 READ N2 !頂点の個数 DIM X2(N2),Y2(N2) !頂点の座標 FOR i=1 TO N2 READ X2(i),Y2(i) NEXT i CALL MOAofPolygon(N2,X2,Y2, Du2,Dd2,Dl2,Dr2, S2,Sx2,Sy2,Xg2,Yg2,Jx2,Jy2,Jxy2) !基本 CALL MOA_Print(Du2,Dd2,Dl2,Dr2, S2,Sx2,Sy2,Xg2,Yg2,Jx2,Jy2,Jxy2) !基本を表示する PRINT DATA 4 DATA 0, 2.5 !ウェブ左側　※差の図形は右回り DATA 0, 47.5 DATA 11.9, 47.5 DATA 11.9, 2.5 READ N3 !頂点の個数 DIM X3(N3),Y3(N3) !頂点の座標 FOR i=1 TO N3 READ X3(i),Y3(i) NEXT i CALL MOAofPolygon(N3,X3,Y3, Du3,Dd3,Dl3,Dr3, S3,Sx3,Sy3,Xg3,Yg3,Jx3,Jy3,Jxy3) !基本 CALL MOA_Print(Du3,Dd3,Dl3,Dr3, S3,Sx3,Sy3,Xg3,Yg3,Jx3,Jy3,Jxy3) !基本を表示する PRINT LET Du=Du1 !3つの形状を合わせる LET Dd=Dd1 LET Dl=Dl1 LET Dr=Dr1 LET S=S1+S2+S3 LET Sx=Sx1+Sx2+Sx3 LET Sy=Sy1+Sy2+Sy3 LET Xg=(Xg1*S1+Xg2*S2+Xg3*S3)/S LET Yg=(Yg1*S1+Yg2*S2+Yg3*S3)/S LET Jx=Jx1+Jx2+Jx3 LET Jy=Jy1+Jy2+Jy3 LET Jxy=Jxy1+Jxy2+Jxy3 CALL MOA_Print(Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy) !基本を表示する CALL MOA_Print2(Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy, ALPHA) !その他 !●形状を描く LET w=Dr-Dl !幅　※多角形の大きさ LET h=Du-Dd !高さ LET t=MAX(w,h) !縦横の比率を合わせる LET xx1=Dl-t*0.1 LET xx2=Dl+t*1.1 LET yy1=Dd-t*0.1 LET yy2=Dd+t*1.1 SET WINDOW xx1,xx2,yy1,yy2 !表示領域を設定する IF t>=10 THEN DRAW grid(INT(t/10),INT(t/10)) !座標を描く ELSE DRAW grid(t/10,t/10) !座標を描く END IF CALL gcDRAWPOLYGON(N1,X1,Y1) !多角形の形状を描く CALL gcDRAWPOLYGON(N2,X2,Y2) CALL gcDRAWPOLYGON(N3,X3,Y3) CALL gcDRAWPOINT(Xg,Yg,"G") !図心位置 SET LINE COLOR 4 !赤色 LET L=TAN(ALPHA) !u軸　※点(x1,y1)と通り、傾きαの直線は、Y-y1=tanα(X-x1)より LET M=-1 LET N=-L*Xg+Yg CALL gcDRAWLINE(L,M,N) SET LINE COLOR 3 !緑色 LET A=-M !v軸　※点(x1,y1)と通り、直線Lx+My+N=0に垂直な直線は、L(y-y1)=M(x-x1)より LET B=L LET C=-L*Yg+M*Xg CALL gcDRAWLINE(A,B,C) SET LINE COLOR 2 !青色 PLOT LINES: Dl,Dd; Dr,Dd; Dr,Du; Dl,Du; Dl,Dd !AABB（軸並行境界ボックス: Axis-Aligned Bounding Box） END ※サブルーチン部分は省略します。実行結果上端= 50 下端= 0 左端= 0 右端= 25 断面積 S= 1250 断面1次モーメント（原点からX軸方向）Sx= 15625 （原点からY軸方向）Sy= 31250 図心 Xg= 12.5 Yg= 25 断面2次モーメント（X軸回り）Jx= 1041666.66666667 （Y軸回り）Jy= 260416.666666667 断面相乗モーメント（原点回り）Jxy= 390625 上端= 47.5 下端= 2.5 左端= 13.1 右端= 25 断面積 S=-535.5 断面1次モーメント（原点からX軸方向）Sx=-10201.275 （原点からY軸方向）Sy=-13387.5 図心 Xg= 19.05 Yg= 25 断面2次モーメント（X軸回り）Jx=-425053.125 （Y軸回り）Jy=-200653.635 断面相乗モーメント（原点回り）Jxy=-255031.875 上端= 47.5 下端= 2.5 左端= 0 右端= 11.9 断面積 S=-535.5 断面1次モーメント（原点からX軸方向）Sx=-3186.225 （原点からY軸方向）Sy=-13387.5 図心 Xg= 5.95 Yg= 25 断面2次モーメント（X軸回り）Jx=-425053.125 （Y軸回り）Jy=-25277.385 断面相乗モーメント（原点回り）Jxy=-79655.625 上端= 50 下端= 0 左端= 0 右端= 25 断面積 S= 179 断面1次モーメント（原点からX軸方向）Sx= 2237.5 （原点からY軸方向）Sy= 4475 図心 Xg= 12.5 Yg= 25 断面2次モーメント（X軸回り）Jx= 191560.41666667 （Y軸回り）Jy= 34485.646666667 断面相乗モーメント（原点回り）Jxy= 55937.5 断面2次モーメント（図心Xg軸回り）Jxg= 79685.41666667 （図心Yg軸回り）Jyg= 6516.896666667 断面相乗モーメント（図心回り）Jxyg= 0 断面2次極モーメント（原点回り）Jd= 226046.063333337 断面2次極モーメント（図心回り）Jdg= 86202.313333337 断面2次半径（X軸回り）Rx= 32.7134517517202 （Y軸回り）Ry= 13.8801024473114 断面2次半径（図心Xg軸回り）Rxg= 21.0990503462152 （図心Yg軸回り）Ryg= 6.03384155806733 断面2次半径（図心回り）Rxyg= 21.9448665856046 断面係数（上端）Mu= 3187.4166666668 （下端）Md= 3187.4166666668 　　　　（左端）Ml= 521.35173333336 （右端）Mr= 521.35173333336 主軸の角度=-17.7300030228543 ° 断面2次モーメント（主軸u軸回り）Ju= 209444.630641631 （v軸回り）Jv= 16601.432691706

Re: 断面性能（面積、モーメント）

投稿者：山中和義投稿日：2011年12月16日(金)09時45分3秒

> No.1722[元記事へ] 扇形、円、半円、円管などの場合 !座標法で図形（扇形）の断面性能を求める LET CX=20 !中心の位置 LET CY=10 LET R1=20 !内半径 LET R2=50 !外半径 LET AS=-20 !開始角（単位は度） LET AE=120 !終了角 !たとえば、 !開始角=0、終了角=360なら、円管 !内半径=0、開始角=0、終了角=360なら、円 !内半径=0、開始角=θ、終了角=開始角+180なら、傾きθの半円 !内半径=0、開始角=θ、終了角=開始角+90なら、傾きθの1/4円 CALL MOAofFan(CX,CY,R1,R2,AS,AE, Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy) !基本 CALL MOA_Print(Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy) !基本を表示する CALL MOA_Print2(Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy, ALPHA) !その他 !●形状を描く LET w=Dr-Dl !幅　※多角形の大きさ LET h=Du-Dd !高さ LET t=MAX(w,h) !縦横の比率を合わせる LET xx1=Dl-t*0.1 LET xx2=Dl+t*1.1 LET yy1=Dd-t*0.1 LET yy2=Dd+t*1.1 SET WINDOW xx1,xx2,yy1,yy2 !表示領域を設定する IF t>=10 THEN DRAW grid(INT(t/10),INT(t/10)) !座標を描く ELSE DRAW grid(t/10,t/10) !座標を描く END IF CALL gcDRAWFAN(CX,CY,R1,R2,AS,AE) !扇形を描く　←←← CALL gcDRAWPOINT(Xg,Yg,"G") !図心位置 SET LINE COLOR 4 !赤色 LET L=TAN(ALPHA) !u軸　※点(x1,y1)と通り、傾きαの直線は、Y-y1=tanα(X-x1)より LET M=-1 LET N=-L*Xg+Yg CALL gcDRAWLINE(L,M,N) SET LINE COLOR 3 !緑色 LET A=-M !v軸　※点(x1,y1)と通り、直線Lx+My+N=0に垂直な直線は、L(y-y1)=M(x-x1)より LET B=L LET C=-L*Yg+M*Xg CALL gcDRAWLINE(A,B,C) SET LINE COLOR 2 !青色 PLOT LINES: Dl,Dd; Dr,Dd; Dr,Du; Dl,Du; Dl,Dd !AABB（軸並行境界ボックス: Axis-Aligned Bounding Box） END ※サブルーチン　追加部分 !扇形 !●断面積（sectional area、断面0次モーメント）　単位: mm^2 !　中心(0,0)、内半径r1、外半径r2、開始角θ1、終了角θ2 とする。 !　S=∫dS=(r2^2-r1^2)(θ2-θ1)/2 ! !以下、三角形の面積（2次元外積による）を基準に、 ! !●原点からX軸方向、原点からY軸方向の断面1次モーメント（statical moment of area）　単位: mm^3 !　Sx=∫ydS=(r2^3-r1^3)(sinθ2-sinθ1)/3 !　Sy=∫xdS=(r2^3-r1^3)(cosθ1-cosθ2)/3 !図心Xg軸回り、図心Yg軸回りの断面1次モーメント !　Sx=Sy=0 ! !●図心（centroid）　単位: mm　　※荷重分布が均一なら、重心となる !　Xg=Sx/S !　Yg=Sy/S ! !●X軸回り、Y軸回りの断面2次モーメント（moment of inertia of area）　単位: mm^4 !　Jx=∫y^2dS=(1/16)(r2^4-r1^4)(2θ2-2θ1-sin(2θ2)+sin(2θ1)) !　Jy=∫x^2dS=(1/16)(r2^4-r1^4)(2θ2-2θ1+sin(2θ2)-sin(2θ1)) !図心Xg軸回り、図心Yg軸回りの断面2次モーメント !　Jxg=Jx-S*Yg^2 !　Jyg=Jy-S*Xg^2 ! !●原点回りの断面相乗モーメント（product of inertia of area）　単位: mm^4 !　Jxy=∫xydS=(1/16)(r2^4-r1^4)(cos(2θ2)-cos(2θ1)) !図心回りの断面相乗モーメント !　Jxyg=Jxy-S*Xg*Yg EXTERNAL SUB MOAofFan(CX,CY,R1,R2,AS,AE, Du,Dd,Dl,Dr, S,Sx,Sy,Xg,Yg,Jx,Jy,Jxy) !基本 LET Du=R2+CY !座標の最大値、最小値を探す　※円として把握する LET Dd=-R2+CY LET Dl=-R2+CX LET Dr=R2+CX IF AS>AE THEN LET AE=AE+360 LET TH1=RAD(AS) LET TH2=RAD(AE) LET S=(R2^2-R1^2)*(TH2-TH1)/2 !※中心(CX,CY)を基準とする LET Sxc=(R2^3-R1^3)*(SIN(TH2)-SIN(TH1))/3 LET Syc=(R2^3-R1^3)*(COS(TH1)-COS(TH2))/3 LET Xgc=Sxc/S LET Ygc=Syc/S LET Jxc=(R2^4-R1^4)*(2*TH2-2*TH1-SIN(2*TH2)+SIN(2*TH1))/16 LET Jyc=(R2^4-R1^4)*(2*TH2-2*TH1+SIN(2*TH2)-SIN(2*TH1))/16 LET Jxyc=-(R2^4-R1^4)*(COS(2*TH2)-COS(2*TH1))/16 LET Xg=Xgc + CX !※XY軸へ換算する LET Yg=Ygc + CY LET Sx=Xg*S LET Sy=Yg*S LET Jxgc=Jxc-S*Ygc^2 !!! LET Jygc=Jyc-S*Xgc^2 LET Jxygc=Jxyc-S*Xgc*Ygc LET Jx=Jxgc + S*Yg^2 !=(Jxc-S*Ygc^2)+S*(Ygc+CY)^2=Jxc+2*S*CY*Ygc+S*CY^2=Jxc+S*CY*(2Ygc+CY) LET Jy=Jygc + S*Xg^2 LET Jxy=Jxygc + S*Xg*Yg END SUB !作図ツール EXTERNAL SUB gcDRAWCIRCLE(CX,CY,R,AS,AE) !円（円弧）を描く　※ASは開始角、AEは終了角 IF R<0 THEN PRINT "R<0なので、円が成立しません。"; CX;CY;R ELSE IF AS>AE THEN LET AE=AE+360 FOR i=AS TO AE !折れ線でつなぐ PLOT LINES: R*COS(RAD(i))+CX,R*SIN(RAD(i))+CY; NEXT i PLOT LINES !閉じる END IF END SUB EXTERNAL SUB gcDRAWFAN(CX,CY,R1,R2,AS,AE) !扇形を描く CALL gcDRAWCIRCLE(CX,CY,R1,AS,AE) !弧 CALL gcDRAWCIRCLE(CX,CY,R2,AS,AE) LET co=COS(RAD(AS)) !開始 LET si=SIN(RAD(AS)) PLOT LINES: R1*co+CX,R1*si+CY; R2*co+CX,R2*si+CY LET co=COS(RAD(AE)) !終了 LET si=SIN(RAD(AE)) PLOT LINES: R1*co+CX,R1*si+CY; R2*co+CX,R2*si+CY CALL gcDRAWPOINT(CX,CY,"C") !中心 END SUB 実行結果上端= 60 下端=-40 左端=-30 右端= 70 断面積 S= 2565.63400043167 断面1次モーメント（原点からX軸方向）Sx= 98426.4563459275 （原点からY軸方向）Sy= 81804.3522149674 図心 Xg= 38.3634050411583 Yg= 31.8846539300632 断面2次モーメント（X軸回り）Jx= 3324578.17994765 （Y軸回り）Jy= 4685919.41859888 断面相乗モーメント（原点回り）Jxy= 2589112.97383445 断面2次モーメント（図心Xg軸回り）Jxg= 716274.719600415 （図心Yg軸回り）Jyg= 909945.407034179 断面相乗モーメント（図心回り）Jxyg=-549180.52431792 断面2次極モーメント（原点回り）Jd= 8010497.59854653 断面2次極モーメント（図心回り）Jdg= 1626220.12663459 断面2次半径（X軸回り）Rx= 35.9973825930853 （Y軸回り）Ry= 42.7366087411558 断面2次半径（図心Xg軸回り）Rxg= 16.7086922681897 （図心Yg軸回り）Ryg= 18.8326015288029 断面2次半径（図心回り）Rxyg= 25.1763237518056 断面係数（上端）Mu= 25476.2903440237 （下端）Md= 9964.22296610457 　　　　（左端）Ml= 13310.4166839897 （右端）Mr= 28762.4318678414 主軸の角度= 37.6352029782081 ° 断面2次モーメント（主軸u軸回り）Ju= 6682340.22156183 （v軸回り）Jv= 1328157.37698471

(無題)

投稿者：SECOND 投稿日：2011年12月26日(月)18時39分37秒

!某サイト「考える葦」に掲示されている問題を、グラフ化したものです。 !実際的な確認ができます。数学的証明の糸口に・・ !------------------------------------------------------- !ベクトルの問題なんですが・・・返信引用 !名前：・・・日付：2011/12/24(土) 11:10 !四角形 ABCD において、辺 AB,BC,CD,DA の中点を、それぞれ E,F,G,H とし、 !対角線 AC,BD の中点をそれぞれ I,J とする。 !このとき、線分 EG,FH,IJ は、１点で交わることを証明せよ。 !------------------------------------------------------- OPTION ARITHMETIC COMPLEX SET WINDOW -1.1, 1.1, -1.1, 1.1 SET POINT STYLE 7 ! LET a=COMPLEX(-.5, .5) LET b=COMPLEX(-.7,-.7) LET c=COMPLEX( .8,-.8) LET d=COMPLEX( .4, .7) DO SET DRAW mode hidden CLEAR CALL gide(-1,1) ! SET LINE width 1 SET LINE COLOR "black" PLOT LINES: a;b;c;d;a PLOT TEXT,AT a:"A" PLOT TEXT,AT b:"B" PLOT TEXT,AT c:"C" PLOT TEXT,AT d:"D" ! SET LINE COLOR "green" LET e=(a+b)/2 LET f=(b+c)/2 LET g=(c+d)/2 LET h=(d+a)/2 PLOT LINES: e;f;g;h;e PLOT POINTS: e;f;g;h PLOT TEXT,AT e:"E" PLOT TEXT,AT f:"F" PLOT TEXT,AT g:"G" PLOT TEXT,AT h:"H" ! PLOT LINES: a;c PLOT LINES: b;d ! SET LINE width 2 SET LINE COLOR "red" PLOT LINES: e; g PLOT LINES: f; h ! SET LINE COLOR "blue" PLOT LINES: (a+c)/2;(b+d)/2 PLOT POINTS: (a+c)/2;(b+d)/2 PLOT TEXT,AT (a+c)/2:"I" PLOT TEXT,AT (b+d)/2:"J" ! SET DRAW mode explicit mouse poll x,y,mlb,mrb DO WHILE mlb=0 AND mrb=0 WAIT DELAY 0 !省電力（待機中のクロックアップ防止。) mouse poll x,y,mlb,mrb LET z=COMPLEX(x,y) LET i$="" LET i=MIN( MIN( MIN(ABS(z-a),ABS(z-b)),ABS(z-c)),ABS(z-d)) IF i<=1/6 THEN IF i=ABS(z-a) THEN LET i$="a" IF i=ABS(z-b) THEN LET i$="b" IF i=ABS(z-c) THEN LET i$="c" IF i=ABS(z-d) THEN LET i$="d" END IF LOOP LET z=COMPLEX(x,y) IF i$="a" THEN LET a=z ELSEIF i$="b" THEN LET b=z ELSEIF i$="c" THEN LET c=z ELSEIF i$="d" THEN LET d=z END IF LOOP UNTIL 0< mrb !------------ SUB gide(x,y) PLOT TEXT,AT x,y:"左ボタン押下で、A, B, C, D ４点をドラッグ、自由に変形。" PLOT TEXT,AT x,y-.07:"右ボタン終了。" END SUB !------------ END

　戻る