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

新掲示板開設

 投稿者：白石　和夫  投稿日：2008年 7月21日(月)09時38分46秒 		返信・引用 　編集済
  十進BASIC第2掲示板を開設しました。
メインの掲示板が不調のとき，こちらをご利用ください。
なお，最大500行まで書き込めることになっていますが，
実験的には251行までしか書き込めないようです。
Internet Explorerでもインデントを保持したまま表示されること，
同一人による連続書き込みに規制がかかること（スパム対策）
など，利点も多いので，将来的には本格的な移転もありえます。 		 

第２掲示板に感謝

 投稿者：北摂三太郎  投稿日：2008年 7月23日(水)10時27分59秒 		返信・引用
  私の県の学校ネットでは、旧十進ＢＡＳＩＣ掲示板は、なぜか「有害情報」として扱われ学校からは閲覧することができません。（フィルターにひっかかるようです。）
この第２掲示板は今のところ閲覧できてますので、こちらに移転していただけるとありがたいです。 		 

【質問】chr$での文字表示について

 投稿者：Bear  投稿日：2008年 9月 2日(火)04時49分9秒 		返信・引用
  ※現在の住まいの関係上、無料メールしか利用できないため
※こちらの掲示板に書かせていただきます。

当方、WindowsXp + 十進BASIC 7.2.7という環境です。
前に十進BASICとUltraBASICの違いを質問した者です、よろしくお願いします。

　print chr$(...)

て具合に番地指定で文字表示させる際に
WindowsのIMEパッドで見える範囲を指定してるのにちょくちょく例外が発生します。

＝ここから＝
option character kanji
input prompt "全角で１文字入力してください:":a$
let b=ord(a$)
let b$=str$(b)
let c$=bstr$(ord(a$),16)
let d$=right$(c$,2)&left$(c$,2)
print
print chr$(bval(c$,16))&"(JIS:"&c$&")"&" -> "&chr$(bval(d$,16))&"(JIS:"&d$&")"
end
＝ここまで＝

例として、上記プログラムでa$に「日」と入力した場合に出力される文字を
テキストウィンドウ内でコピーしてからプログラムを再実行して
2回目のa$入力でペーストすれば「裏の裏は表」となり、今度は「日」が出力されるはずだと思うのですが
なぜかここで例外4002が発生してしまいます。

当方の記述にまずい点があればご教示いただけませんでしょうか。
それともFull Basicの規格に準拠する仕様上、当然の結果なのでしょうか？ 		 

Re: 【質問】chr$での文字表示について

 投稿者：SECOND  投稿日：2008年 9月 2日(火)22時32分26秒 		返信・引用 　編集済
  > No.3[元記事へ]

削除編集できません。→　投稿者：SECOND  投稿日：2008年 9月 2日(火)21時28分28秒
削除して下さい。


win98SE + ver7.2.7 では、例外が発生せず、以下の様に
期待どうりになります。
しかし、byte 反転した word は、漢字コードの許される範囲を、
いつ飛出すか不明です。時折、不正コードは、発生しているはずです。
又、7C46 は、第１第２水準以外の、拡張文字コードです。
　　(金+帝 の字、※この掲示板は、表示出来ないようです。)
IMEパッドも、アテニ出来ません。
この字を、IMEパッドで拾うと何故か、BSTR$( ORD("金+帝"),16 ) →"1662" になる？不正コードです。
しかし、w$=CHR$( BVAL("7C46",16) ) →BSTR$( ORD(w$),16 ) →"7C46" になりますので、
十進BASIC の方は、正常です。


全角で１文字入力してください:日

日(JIS:467C) -> (JIS:7C46)

　　(copy & paste)

全角で１文字入力してください:

(JIS:7C46) -> 日(JIS:467C) 		 

Re: 【質問】chr$での文字表示について

 投稿者：Bear  投稿日：2008年 9月 3日(水)21時10分48秒 		返信・引用
  > No.5[元記事へ]

ありがとうございます。
IMEパッドもあてにできないんですね、今後は注意するようにします。

>win98SE + ver7.2.7 では、例外が発生せず、以下の様に
>期待どうりになります。
やっぱりそうですか。
自分も前に 98SE + 5.0.8 の組合せで同じ事を試した時は
第1水準、第2水準から外れる文字番地をかすめても特に支障なかったので
これはありなんだと思ってたら今回 Xp + 7.2.7 で例外を回避できませんでした。

猶、例外が出る文字番地を一覧するもの書いてみました。
＝ここから＝
rem -- 全角文字の始点:8481 (2121) / 終端:38700 (972C) --
rem -- 結果出力は画面表示よりファイルに書き出した方が早いかも --
option arithmetic decimal
option character kanji
do
input prompt "どこから見る?(半角始点=1,全角始点=2)":start
if start=1 or start=2 then
exit do
elseif start=0 then
stop
else
end if
loop
select case start
case is =2
let start=8481
case else
end select
for count=start to 38700 step 1
let hcount$=bstr$(count,16)
let strcount$=str$(count)
when exception in
print chr$(39)+chr$(count)+chr$(39)+" chr$("+strcount$+") <-> JIS ["+hcount$+"]"
use
print chr$(7)+"例外"+str$(extype)+chr$(7)+" chr$("+strcount$+") <-> JIS ["+hcount$+"]"
end when
next count
end
＝ここまで＝ 		 

Re: 【質問】chr$での文字表示について

 投稿者：白石　和夫  投稿日：2008年 9月 5日(金)20時59分34秒 		返信・引用
  > No.6[元記事へ]

Windows XP (Windows2000) は文字コードがユニコードに変更されています。
シフトJISの文字はユニコードに変換されて表示されます。
シフトJISとJISの対応は，一応，一対一とみなせますが，
ユニコードとJIS（あるいはシフトJIS）との対応は一対一ではありません。
シフトJIS→ユニコード→シフトJISと変換すると元に戻らないことがあります。
十進BASICの場合，ファイル入出力はシフトJISなので，
画面に表示した文字をクリップボード経由で取り出すのでなく，
ファイルに書き出した文字を対象にすれば，問題は起こりにくくなると思います。


100 OPTION CHARACTER KANJI
110 INPUT PROMPT "全角で１文字入力してください:":a$
120 LET b=ORD(a$)
130 LET b$=STR$(b)
140 LET c$=BSTR$(ORD(a$),16)
150 LET d$=right$(c$,2)&left$(c$,2)
160 PRINT
170 PRINT CHR$(BVAL(c$,16))&"(JIS:"&c$&")"&" -> "&CHR$(BVAL(d$,16))&"(JIS:"&d$&")"
180 OPEN #1:NAME "A:TEST.TXT"
190 ERASE #1
200 PRINT #1:CHR$(BVAL(d$,16))
210 CLOSE #1
220 OPEN #2:NAME "A:TEST.TXT"
230 INPUT #2:s$
240 CLOSE #2
250 PRINT BSTR$(ORD(s$),16)
260 END

180行以降を追加しています。 		 

Re: 【質問】chr$での文字表示について

 投稿者：白石　和夫  投稿日：2008年 9月 6日(土)10時09分11秒 		返信・引用
  > No.6[元記事へ]

JIS文字コードは，第2バイト（下位バイト）が16進で21から7Eの間でのみ定義されています。
なので，文字を順に生成するプログラムは，下位バイトが21から7Eの間になるように記述しなければなりません。


100 OPTION ARITHMETIC DECIMAL
110 OPTION CHARACTER KANJI
120 FOR hi=BVAL("21",16) TO BVAL("73",16)
130    FOR lo=BVAL("21",16) TO BVAL("7E",16)
140       LET count=hi*256+lo
150       LET hcount$=BSTR$(count,16)
160       LET strcount$=STR$(count)
170       WHEN EXCEPTION IN
180          PRINT CHR$(39)&CHR$(count)&CHR$(39)&" chr$("&strcount$&") <-> JIS ["&hcount$&"]"
190       USE
200          PRINT CHR$(7)&"例外"&STR$(EXTYPE)&CHR$(7)&" chr$("&strcount$&") <-> JIS ["&hcount$&"]"
210       END WHEN
220    NEXT lo
230 NEXT hi
240 END 		 

Re: 【質問】chr$での文字表示について

 投稿者：Bear  投稿日：2008年 9月 7日(日)22時07分8秒 		返信・引用
  白石先生、ありがとうございます。

提示いただいたソース拝見しました、自分でも動かしてみました。
なるほど、こうすればいいんですね。
今後の参考にさせていただき、もっと勉強しようと思います。

>シフトJIS→ユニコード→シフトJISと変換すると元に戻らないことがあります。

文字の割当てがない番地(「・」と表示されるところ)を
WindowsXp上でコピーしてからペースト(クリップボード経由)すると
本来の番地に関係なくJIS 2126番地にされてしまいます。
この現象はWindows98SEでは見られないものでしたが、これで疑問が晴れました。

ありがとうございました。 		 

第1掲示板が開けない

 投稿者：島村1243  投稿日：2008年10月 9日(木)10時11分32秒 		返信・引用
  第1掲示板を読ませて頂いておりますが、先日からアクセス出来なくなっています。閉止でしょうか、或いは不具合発生対処中でしょうか？  

Re: 第1掲示板が開けない

 投稿者：白石　和夫  投稿日：2008年10月 9日(木)20時18分21秒 		返信・引用
  > No.12[元記事へ]

around.ne.jp全体がアクセス不能になっています。
こちらの掲示板は，今回のような事態に備えて開設したものです。
もうしばらく様子を見て，復活しないようであれば，こちらを正の掲示板にしたいと思います。 		 

Re: 第1掲示板が開けない

 投稿者：島村1243  投稿日：2008年10月10日(金)10時07分10秒 		返信・引用
  > No.13[元記事へ]

白石先生、ご回答有り難うございます。もうしばらく復旧されるか待ってみます。

山中様が最近第1掲示板に掲載されたクウォータニアンのプログラムを見たい（コピー損ねた）
のですが、どうしても第1掲示板が復旧出来なかった場合は第２掲示板への転載はされるでし
ょうか。 		 

Re: 第1掲示板が開けない

 投稿者：白石　和夫  投稿日：2008年10月10日(金)16時52分13秒 		返信・引用
  > No.14[元記事へ]

掲示板自体が復旧しないかぎり，書き込み内容はアクセス不能です。 		 

Re: 第1掲示板が開けない

 投稿者：白石　和夫  投稿日：2008年10月11日(土)09時27分55秒 		返信・引用
  > No.15[元記事へ]

http://freebbs.around.ne.jp/
が不通になって3日たちました。
当面，こちらの掲示板をメインに使っていくことにしたいと思います。
旧掲示板の101ページから110ページのログは，旧掲示板が復活しない限り取り出せません。

101ページ以降に書き込まれた方は，再書き込みなど，ご協力をお願いします。
なお，旧掲示板過去ログ 12-100 は，
http://www.geocities.jp/thinking_math_education/log/logs.html
にあります。 		 

Re: 第1掲示板が開けない

 投稿者：山中和義  投稿日：2008年10月11日(土)10時56分27秒 		返信・引用
  > No.14[元記事へ]

島村1243さんへのお返事です。

> 山中様が最近第1掲示板に掲載されたクウォータニアンのプログラムを見たい（コピー損ねた）
> のですが、どうしても第1掲示板が復旧出来なかった場合は第２掲示板への転載はされるでし
> ょうか。


行列表現による複素数、クォータニオン（四元数）の計算
　http://www.urban.ne.jp/home/kz4ymnk/seminar/basic/mat.lzh

でダウンロードしてください。



また、掲示板で発表したプログラムのメンテナンス（デバッグ、バージョンアップなど）はこちらです。

　http://www.urban.ne.jp/home/kz4ymnk/seminar/basic/

１〜２週間後に掲載しています。リンク集にも掲載されています。 		 

Re: 第1掲示板が開けない

 投稿者：島村1243  投稿日：2008年10月11日(土)11時27分14秒 		返信・引用
  > No.17[元記事へ]

山中和義さん、有難う御座いました。早速ダウンロード完了致しました。
楽しみに読ませて頂きます。

> 行列表現による複素数、クォータニオン（四元数）の計算
> 　http://www.urban.ne.jp/home/kz4ymnk/seminar/basic/mat.lzh
>
> でダウンロードしてください。
>
>
>
> また、掲示板で発表したプログラムのメンテナンス（デバッグ、バージョンアップなど）はこちらです。
>
> 　http://www.urban.ne.jp/home/kz4ymnk/seminar/basic/
>
> １〜２週間後に掲載しています。リンク集にも掲載されています。 		 

スピログラフ（幾何学アート）

 投稿者：山中和義  投稿日：2008年10月13日(月)22時35分55秒 		返信・引用
  !参考. リンク集より
!　彷徨の神殿　http://stillbe.web.fc2.com/compendium/basic/index.html

FUNCTION GCD(a,b) !最大公約数
   IF b=0 THEN LET GCD=a ELSE LET GCD=GCD(b, MOD(a,b))
END FUNCTION


LET r1=8 !固定円の半径
LET r2=5 !動く円の半径　※r1*r2>0なら内側、r1*r2<0なら外側
LET r3=4 !点Pの位置（動く円の中心から）　※r3=r2ならサイクロイド、r3≠r2ならトロコイド

IF r1*r2>0 THEN
   LET sz=ABS(r1)+ABS(r3)+1
ELSE
   LET sz=ABS(r1)+ABS(r2)+ABS(r3)+1
END IF
SET WINDOW -sz,sz,-sz,sz !表示領域

DRAW grid !座標
DRAW circle WITH SCALE(r1) !大きな円

LET iter=r2/GCD(r1,r2) !周回数

FOR th=0 TO 360*iter !STEP 0.2 !※疎になるなら調整
   DRAW p WITH ROTATE(r1/r2*RAD(th))*SHIFT(r1-r2,0)*ROTATE(-RAD(th)) !点P
NEXT th


PICTURE p !原点（動く円の中心）を基準に点Pを描く
   DRAW disk WITH SCALE(0.1)*SHIFT(r3,0) !点P
END PICTURE

END 		 

Re: スピログラフ（幾何学アート）

 投稿者：山中和義  投稿日：2008年10月14日(火)07時54分28秒 		返信・引用 　編集済
  > No.19[元記事へ]

作画の様子をアニメーションさせてみました。


FUNCTION GCD(a,b) !最大公約数
   IF b=0 THEN LET GCD=a ELSE LET GCD=GCD(b, MOD(a,b))
END FUNCTION


LET r1=8 !固定円の半径
LET r2=5 !動く円の半径　※r1*r2>0なら内側、r1*r2<0なら外側
LET r3=4 !点Pの位置（動く円の中心から）　※r3=r2ならサイクロイド、r3≠r2ならトロコイド

!LET r1=8 !固定円の直径 r1:r2=2:1
!LET r2=4
!LET r3=r2

!LET r1=12 !アステロイド 4:1
!LET r2=3
!LET r3=r2

!LET r1=5 !カージオイド 1:1
!LET r2=-5
!LET r3=ABS(r2)

!LET r1=4 !ネフロイド 2:1
!LET r2=-2
!LET r3=ABS(r2)


IF r1*r2>0 THEN
   IF ABS(r1)>ABS(r2) THEN
      LET sz=MAX(ABS(r1),ABS(r1-r2)+ABS(r3))+1
   ELSE
      LET sz=ABS(r1)+ABS(r3)+1
   END IF
ELSE
   LET sz=ABS(r1)+ABS(r2)+ABS(r3)+1
END IF
SET WINDOW -sz,sz,-sz,sz !表示領域

DRAW grid !座標
DRAW circle WITH SCALE(r1) !大きな円

LET iter=r2/GCD(r1,r2) !周回数

SET DRAW MODE NOTXOR

DIM w(4,4) !ローカル座標をワールド座標に変換する
MAT w=SHIFT(r1-r2,0) !１つ前
DRAW p(0) WITH w

FOR th=0 TO 360*iter !STEP 0.2 !※疎になるなら調整
   DRAW p(0) WITH w !１つ前を消す

   MAT w=ROTATE(-r1/r2*RAD(th)) * SHIFT(r1-r2,0)*ROTATE(RAD(th)) !姿勢と位置
   DRAW p(1) WITH w !ワールド座標に、動く円と点Pを描く

   WAIT DELAY 0.02
NEXT th


PICTURE p(f) !ローカル座標の原点を基準に、動く円と点Pを描く
   IF f=1 THEN !描画順を考慮して、先に点Pを描く
      SET DRAW MODE OVERWRITE !描画diskにNOTXORを反映させない
      DRAW disk WITH SCALE(0.2)*SHIFT(r3,0)
      SET DRAW MODE NOTXOR
   END IF
   DRAW circle WITH SCALE(r2) !動く円
   PLOT LINES: 0,0; r3,0
END PICTURE

END
 

画像縮小補正プログラム

 投稿者：荒田浩二  投稿日：2008年10月15日(水)19時32分55秒 		返信・引用 　編集済
  第2掲示板では画像のアップもできるようなので、試しに画像縮小の補正プログラムを投稿します。
MAT PLOT CELLSで画像を縮小して描画したときに生じるジャギー(ギザギザ)を補正するものです。
縮小により欠損する画素の色情報を周囲の画素と加重平均しました。
補正できる縮小率は次の2通りです。
　1/2,1/3,1/4,...といった 1/n のタイプ。
　2/3,3/4,4/5,...といった (n-1)/n のタイプ。
縮小率を入力すると、まず画面右下に補正なしの画像が描画されます。
ビープ音の後、何かキーを押すと左下に補正した画像が描画されます。
プログラムで読み込んでいる画像は十進BASIC添付ファイルですが、サイズが小さいためか補正の効果をあまり確認できません。
ぜひ、アップした写真をデスクトップにでもコピー＆ペーストして試してみてください。
この写真は個人が撮影したもので著作権に問題はありません。

(JPEG形式でUpしたので画質が落ちてますが、DownLoadするとBMP形式で保存されます。)
(掲示されているサイズは400×300、拡大すると元のサイズ800×600になります。どちらのサイズもダウンロードできます)


REM ** 画像縮小補正プログラム **
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB revision1,revision2
GLOAD "C:\Program Files\Decimal BASIC\BASICw32\SAMPLE\ZENKOUJI.JPG"
LET px0=PIXELX(1)
LET py0=PIXELY(1)
SET WINDOW 0,px0,0,py0
DIM pict0(0 TO px0,0 TO py0)    ! 元画像(配列の下限は0以外も可)
SET COLOR MODE "NATIVE"
ASK PIXEL ARRAY (0,py0) pict0   ! 元画像の色指標
DO
   LET err=0
   INPUT PROMPT "[縮小率入力] 分子,分母 (分子=1 or 分子=分母-1)" : num,denom
   IF num<1 OR INT(num)<>num THEN LET err=1
   IF denom<2 OR INT(denom)<>denom THEN LET err=1
   IF num<>1 AND num<>denom-1 THEN LET err=1
LOOP UNTIL err=0
LET t0=TIME
LET kk=num/denom   ! 縮小率
MAT PLOT CELLS, IN px0-px0*kk,py0*kk ; px0,0 : pict0  !! 補正なし
!
LET px9=INT(SIZE(pict0,1)*kk+0.00001)-1  ! k=1/3,3*k<>1に対応
LET py9=INT(SIZE(pict0,2)*kk+0.00001)-1
DIM pict9(0 TO px9,0 TO py9)    ! 縮小補正画像(配列の下限は0)
IF num=1 THEN
   CALL revision1(pict0,pict9,denom)   ! 縮小率=1/n
ELSE
   CALL revision2(pict0,pict9,denom)   ! 縮小率=(n-1)/n
END IF
IF TIME-t0<0.2 THEN WAIT DELAY 0.2
BEEP
SET TEXT COLOR "RED"
SET TEXT HEIGHT py0/30
PLOT TEXT ,AT 1,1 : "PUSH ANY KEY"
DO
   FOR i=8 TO 239
      IF GetKeyState(i)<0 THEN EXIT DO
   NEXT i
LOOP
MAT PLOT CELLS, IN 0,py9 ; px9,0 : pict9  !! 補正あり
BEEP
END


REM  縮小率=1/n (1/2,1/3,1/4,...)
EXTERNAL SUB revision1(sp0(,),sp9(,),k)
OPTION ARITHMETIC NATIVE
LET kk=1/k
DIM c9(3)
LET lx0=LBOUND(sp0,1)
LET ly0=LBOUND(sp0,2)
LET ux0=UBOUND(sp0,1)
LET uy0=UBOUND(sp0,2)
LET ux9=UBOUND(sp9,1)
LET uy9=UBOUND(sp9,2)
FOR i=lx0 TO ux0-(k-1) STEP k
   FOR j=ly0 TO uy0-(k-1) STEP k
      MAT c9=ZER
      FOR ii=0 TO k-1
         FOR jj=0 TO k-1
            CALL acm(i+ii,j+jj)
         NEXT jj
      NEXT ii
      LET sp9((i-lx0)*kk,(j-ly0)*kk)=COLORINDEX(c9(1)/k^2,c9(2)/k^2,c9(3)/k^2)
   NEXT j
NEXT i
LET rm2=MOD(uy0,k)  ! 縁(横)の処理
IF rm2<>k-1 THEN
   FOR i=lx0 TO ux0-(k-1) STEP k
      MAT c9=ZER
      FOR j=0 TO rm2
         CALL acm(i,uy0-j)
      NEXT j
      LET sp9((i-lx0)*kk,uy9)=COLORINDEX(c9(1)/(rm2+1),c9(2)/(rm2+1),c9(3)/(rm2+1))
   NEXT i
END IF
LET rm1=MOD(ux0,k)  ! 縁(縦)の処理
IF rm1<>k-1 THEN
   FOR j=ly0 TO uy0-(k-1) STEP k
      MAT c9=ZER
      FOR i=0 TO rm1
         CALL acm(ux0-i,j)
      NEXT i
      LET sp9(ux9,(j-ly0)*kk)=COLORINDEX(c9(1)/(rm1+1),c9(2)/(rm1+1),c9(3)/(rm1+1))
   NEXT j
END IF
IF rm1<>k-1 OR rm2<>k-1 THEN  ! 角の処理
   MAT c9=ZER
   FOR i=0 TO rm1
      FOR j=0 TO rm2
         CALL acm(ux0-i,uy0-j)
      NEXT j
   NEXT i
   LET rm12=(rm1+1)*(rm2+1)
   LET sp9(ux9,uy9)=COLORINDEX(c9(1)/rm12,c9(2)/rm12,c9(3)/rm12)
END IF
SUB acm(x0,y0)
   ASK COLOR MIX(sp0(x0,y0)) b,g,r
   LET c9(1)=c9(1)+b
   LET c9(2)=c9(2)+g
   LET c9(3)=c9(3)+r
END SUB
END SUB

REM  縮小率=(n-1)/n (2/3,3/4,4/5,...)
EXTERNAL SUB revision2(sp0(,),sp9(,),k)
OPTION ARITHMETIC NATIVE
DECLARE FUNCTION c_ave
LET kk=(k-1)/k
LET num1=(k-1)-1
LET lx0=LBOUND(sp0,1)
LET ly0=LBOUND(sp0,2)
LET ux0=UBOUND(sp0,1)
LET uy0=UBOUND(sp0,2)
LET ux9=UBOUND(sp9,1)
LET uy9=UBOUND(sp9,2)
FOR i=lx0 TO ux0-k STEP k
   FOR j=ly0 TO uy0-k STEP k
      CALL center
      CALL side1(i,j,1,0)
      CALL side1(i+k,j,-1,num1)
      CALL side2(i,j,1,0)
      CALL side2(i,j+k,-1,num1)
      CALL corner(i,j,1,1,0,0)
      CALL corner(i,j+k,1,-1,0,num1)
      CALL corner(i+k,j,-1,1,num1,0)
      CALL corner(i+k,j+k,-1,-1,num1,num1)
   NEXT j
NEXT i
LET x8=(i-lx0-k)*kk+num1
LET y8=(j-ly0-k)*kk+num1
IF uy9<>y8 THEN CALL edge1
IF ux9<>x8 THEN CALL edge2
IF ux9<>x8 AND uy9<>y8 THEN CALL edge_corner
FUNCTION c_ave(c1,c2)   ! 色強度加重平均
   ASK COLOR MIX(c1) b1,g1,r1
   ASK COLOR MIX(c2) b2,g2,r2
   LET c_ave=COLORINDEX((b1+2*b2)/3,(g1+2*g2)/3,(r1+2*r2)/3)
END FUNCTION
SUB center
   FOR ii=2 TO num1
      FOR jj=2 TO num1
         LET sp9((i-lx0)*kk+ii-1,(j-ly0)*kk+jj-1)=sp0(i+ii,j+jj)
      NEXT jj
   NEXT ii
END SUB
SUB side1(x,y,ii,m)
   FOR jj=2 TO num1
      LET sp9((i-lx0)*kk+m,(j-ly0)*kk+jj-1)=c_ave(sp0(x,y+jj),sp0(x+ii,y+jj))
   NEXT jj
END SUB
SUB side2(x,y,jj,n)
   FOR ii=2 TO num1
      LET sp9((i-lx0)*kk+ii-1,(j-ly0)*kk+n)=c_ave(sp0(x+ii,y),sp0(x+ii,y+jj))
   NEXT ii
END SUB
SUB corner(x,y,ii,jj,m,n)
   ASK COLOR MIX(sp0(x,y)) b1,g1,r1
   ASK COLOR MIX(sp0(x,y+jj)) b2,g2,r2
   ASK COLOR MIX(sp0(x+ii,y)) b3,g3,r3
   ASK COLOR MIX(sp0(x+ii,y+jj)) b4,g4,r4
   LET bb=(b1+2*b2+2*b3+4*b4)/9
   LET gg=(g1+2*g2+2*g3+4*g4)/9
   LET rr=(r1+2*r2+2*r3+4*r4)/9
   LET sp9((i-lx0)*kk+m,(j-ly0)*kk+n)=COLORINDEX(bb,gg,rr)
END SUB
SUB edge1
   FOR i=lx0 TO ux0-k STEP k  ! 下辺の処理
      FOR ii=0 TO num1
         FOR jj=0 TO uy9-y8-2
            LET sp9((i-lx0)*kk+ii,uy9-jj)=sp0(i+ii+1,uy0-jj)
         NEXT jj
         LET sp9((i-lx0)*kk+ii,uy9-jj)=c_ave(sp0(i+ii+1,uy0-(jj+1)),sp0(i+ii+1,uy0-jj))
      NEXT ii
   NEXT i
END SUB
SUB edge2
   FOR j=ly0 TO uy0-k STEP k  ! 右辺の処理
      FOR jj=0 TO num1
         FOR ii=0 TO ux9-x8-2
            LET sp9(ux9-ii,(j-ly0)*kk+jj)=sp0(ux0-ii,j+jj+1)
         NEXT ii
         LET sp9(ux9-ii,(j-ly0)*kk+jj)=c_ave(sp0(ux0-(ii+1),j+jj+1),sp0(ux0-ii,j+jj+1))
      NEXT jj
   NEXT j
END SUB
SUB edge_corner
   FOR ii=ux9 TO x8+1 STEP-1
      FOR jj=uy9 TO y8+1 STEP-1
         LET sp9(ii,jj)=sp0(ux0-(ux9-ii),uy0-(uy9-jj))
      NEXT jj
   NEXT ii
END SUB
END SUB
 

Re: 画像縮小補正プログラム

 投稿者：山中和義  投稿日：2008年10月18日(土)20時06分51秒 		返信・引用 　編集済
  > No.21[元記事へ]

バイリニア法では、画像を縮小すればエッジ部分が強調される傾向があります。

一般的な縮小率の場合、画像処理アプリケーションでの操作のように
縮小率に応じて平滑化（ぼかす）して、バイリニア法で縮小すればよいかと思います。


別解　※MAT文を使って処理が速くなりました。


!離散コサイン変換（DCT:Discrete Cosine Transform）による拡大縮小

OPTION ARITHMETIC NATIVE

LET N=8 !ブロックサイズ

FUNCTION phi(k,i,N) !基底関数φk(i)
   IF k=0 THEN
      LET phi=1/SQR(N)
   ELSE
      LET phi=SQR(2/N)*COS((2*i+1)*k*PI/(2*N))
   END IF
END FUNCTION

SUB DCT(f(,),TBL(,),iTBL(,), FF(,)) !DCT変換
   MAT FF=TBL*f
   MAT FF=FF*iTBL !F(k,l)=Σ[j=0,N-1]Σ[i=0,N-1]f(i,j)*φk(i)*φl(j)
END SUB
SUB iDCT(FF(,),TBL(,),iTBL(,), f(,)) !DCT逆変換
   MAT f=iTBL*FF
   MAT f=f*TBL !f(i,j)=Σ[l=0,N-1]Σ[k=0,N-1]F(k,l)*φk(i)*φl(j)
END SUB

DIM TBLn(0 TO N-1,0 TO N-1) !変換行列 T
MAT TBLn=ZER
FOR k=0 TO N-1 !N×Nブロックのφk(i)のテーブルをつくる
   FOR i=0 TO N-1
      LET TBLn(k,i)=phi(k,i,N)
   NEXT i
NEXT k
!!!MAT PRINT TBLn;
DIM iTBLn(N,N) !※T^-1=T^t、∵ユニタリー行列
MAT iTBLn=TRN(TBLn)
!-------------------- ここまでがサブルーチン


SET COLOR MODE "NATIVE"
!GLOAD "c:\BASICw32\SAMPLE\ZENKOUJI.JPG" !画像を読み込む
GLOAD "c:\My Documents\test2.bmp" !画像を読み込む
ASK PIXEL SIZE (0,0; 1,1) w,h !画像の縦横の大きさ(ピクセル単位)を調べる
DIM p(w,h) !画像の大きさに対応する配列要素を用意する
ASK PIXEL ARRAY (0,1) p !画像の各点の色情報を配列に格納する
PRINT "画像の大きさ 縦:";h;" 横:";w
!SET BITMAP SIZE w,h !ウィンドウの大きさを画像に合わせる


LET A=5 !拡大縮小率 A/N
!LET A=11 !拡大縮小率

LET ww=INT(w*A/N+0.5) !変換後の画像の大きさ
LET hh=INT(h*A/N+0.5)
PRINT A;"/";N;"倍（縦横比は固定） 縦:";hh;" 横:";ww
IF ww<=0 OR hh<=0 THEN
   PRINT "画像の大きさが０または負になります。"
   STOP
END IF
DIM q(ww,hh) !変換後の画像を格納する配列


LET t0=TIME


DIM TBLa(0 TO A-1,0 TO A-1)
MAT TBLa=ZER
FOR k=0 TO A-1 !A×Aブロックのφk(i)のテーブルをつくる
   FOR i=0 TO A-1
      LET TBLa(k,i)=phi(k,i,A)
   NEXT i
NEXT k
DIM iTBLa(0 TO A-1,0 TO A-1)
MAT iTBLa=TRN(TBLa)

FOR by=0 TO INT((h-1)/N) !ブロック単位に分割する
   FOR bx=0 TO INT((w-1)/N)

      FOR j=1 TO N !ブロック内の画像
         LET y=by*N+j
         IF y>h THEN EXIT FOR !下端なら
         FOR i=1 TO N
            LET x=bx*N+i
            IF x>w THEN EXIT FOR !右端なら
            !!!PRINT x;y,i;j

            LET c=p(x,y)
            ASK COLOR MIX(c) r,g,b !RGBを取得する

            DIM Br(N,N),Bg(N,N),Bb(N,N) !画素の色濃度　※画像信号 f(i,j)
            LET Br(i,j)=r
            LET Bg(i,j)=g
            LET Bb(i,j)=b
         NEXT i
      NEXT j

      DIM BVr(N,N),BVg(N,N),BVb(N,N) !DCT係数 F(k,l)
      CALL DCT(Br,TBLn,iTBLn, BVr)
      CALL DCT(Bg,TBLn,iTBLn, BVg)
      CALL DCT(Bb,TBLn,iTBLn, BVb)

      !※縮小なら高周波成分の行と列を除く、拡大なら不足部分は０を補う
      DIM Tr(A,A),Tg(A,A),Tb(A,A)
      IF A>N THEN !拡大なら
         MAT Tr=ZER(A,A)
         MAT Tg=ZER(A,A)
         MAT Tb=ZER(A,A)
      END IF
      FOR j=1 TO MIN(N,A) !copy it
         FOR i=1 TO MIN(N,A)
            LET Tr(i,j)=BVr(i,j)
            LET Tg(i,j)=BVg(i,j)
            LET Tb(i,j)=BVb(i,j)
         NEXT i
      NEXT j

      DIM iBr(A,A),iBg(A,A),iBb(A,A) !画素の色濃度　※画像信号 f(i,j)
      CALL iDCT(Tr,TBLa,iTBLa, iBr)
      CALL iDCT(Tg,TBLa,iTBLa, iBg)
      CALL iDCT(Tb,TBLa,iTBLa, iBb)

      FOR j=1 TO A !画像に割当てる
         LET yy=by*A+j
         IF yy>hh THEN EXIT FOR !下端なら
         FOR i=1 TO A
            LET xx=bx*A+i
            IF xx>ww THEN EXIT FOR !右端なら

            LET r=MIN(iBr(i,j)*A/N,1) !輝度調整
            LET g=MIN(iBg(i,j)*A/N,1)
            LET b=MIN(iBb(i,j)*A/N,1)

            LET q(xx,yy)=colorindex(r,g,b) !指定位置の画素に書き込む
         NEXT i
      NEXT j

   NEXT bx
NEXT by


SET BITMAP SIZE ww,hh !ウィンドウの大きさを画像に合わせる
MAT PLOT CELLS, IN 0,1; 1,0 :q !画像を表示する


PRINT
PRINT "計算時間=";TIME-t0

END 		 

質問

 投稿者：ゆう  投稿日：2008年10月19日(日)09時43分19秒 		返信・引用
  グラフを描いています。
2つの関数f(x)とg(x)によって囲まれた図形を塗りつぶしたいのですが、どうやってやったら出来ますか？回答お願いします。 		 

Re: 質問

 投稿者：山中和義  投稿日：2008年10月19日(日)11時51分12秒 		返信・引用 　編集済
  > No.23[元記事へ]

ゆうさんへのお返事です。


!連立不等式f(x)>0、g(x,y)<0の領域

DEF f(x)=x^2-3*x-1 !関数の定義 y=f(x)
DEF g(x,y)=5*x^2-6*x*y+5*y^2-25 !関数の定義 f(x,y)=0

LET a=-5 !x=[a,b]　※xy座標の表示領域
LET b=5
LET c=a !y=[c,d]
LET d=b


SET WINDOW a,b,c,d !表示領域を設定する
DRAW grid(1,1) !座標を描く
ASK PIXEL SIZE (a,c; b,d) w,h !画像の縦横の大きさ(ドット単位)を調べる
PRINT w;h

LET cEps=(b-a)/(w-1) !座標間隔
PRINT cEps

DEF ha(f)=MOD(f,cEps*10) !評価関数
SUB hatch(t, x,y,c) !ハッチ形状なら点(x,y)を描く
   LET flg=0
   IF (t=1 OR t=5) AND ha(y)<cEps THEN LET flg=1 !横
   IF (t=2 OR t=5) AND ha(x)<cEps THEN LET flg=1 !縦
   IF (t=3 OR t=6) AND ha(x+y)<cEps THEN LET flg=1 !左斜め
   IF (t=4 OR t=6) AND ha(x-y)<cEps THEN LET flg=1 !右斜め
   IF t=0 OR flg=1 THEN !t=0はベタ塗り
      SET POINT COLOR c
      PLOT POINTS: x,y
   END IF
END SUB


!条件を満たす領域を描く
SET POINT STYLE 1 !ドット形式
FOR j=1 TO h !画面全体を走査する
   LET y=WORLDY(j) !ドットをxy座標に変換する
   FOR i=1 TO w
      LET x=WORLDX(i)

      WHEN EXCEPTION IN
      !不等式が示す領域　※y>f(x)はf(x)>0、y<f(x)はf(x)<0を意味する
         IF y>f(x) THEN CALL hatch(4, x,y,4) !条件を満たすなら
         IF g(x,y)<0 THEN CALL hatch(3, x,y,2)

         !連立不等式が示す領域
         !IF y>f(x) AND g(x,y)<0 THEN CALL hatch(5, x,y,2) !条件を満たすなら
      USE
      END WHEN

   NEXT i
NEXT j



!曲線を描く　※y=f(x)
FOR x=a TO b STEP cEps
   WHEN EXCEPTION IN
      PLOT LINES: x,f(x); !折れ線で近似する
   USE
      PLOT LINES
   END WHEN
NEXT x
PLOT LINES
PLOT TEXT ,AT -2,4: "f(x)"


!曲線を描く　※連続なf(x,y)=0
SET POINT COLOR 1
FOR y=c TO d STEP cEps
   LET x=a
   LET z=g(x,y)
   FOR x=a TO b STEP cEps
      LET z0=z
      LET z=g(x,y)
      IF z0*z<0 THEN  PLOT POINTS: x,y !符号が変われば
   NEXT x
NEXT y
PLOT TEXT ,AT -3,-3: "g(x)"


END
 

(無題)

 投稿者：だい  投稿日：2008年10月21日(火)13時50分23秒 		返信・引用
  十進basicをダウンロードしたいんですが、どうしたらいいか教えてください。  

Re: (無題)

 投稿者：白石　和夫  投稿日：2008年10月21日(火)17時56分20秒 		返信・引用
  > No.25[元記事へ]

だいさんへのお返事です。

> 十進basicをダウンロードしたいんですが、どうしたらいいか教えてください。

この頁の一番下のほうにある「十進BASICのホームページ」へのリンクをクリックし，
十進BASICのホームページでOS別に用意されたダウンロードの頁に進んでください。 		 

Re: 画像縮小補正プログラム

 投稿者：荒田浩二  投稿日：2008年10月26日(日)12時08分13秒 		返信・引用
  > No.22[元記事へ]

山中和義さんへのお返事です。

アドバイスありがとうございます。
画像処理に対しての知識もなく思いつきで作ったプログラムです。
離散コサイン変換なる用語も初めて目にするもので、ネット等で自分なりに調べましたが残念ながら硬くなった頭では原理を理解するまではいたりませんでした。

画像関係ではないですが、いくつか投稿しようかと思案しているものがあります。
またアドバイスお願いします。 		 

不等号をタグと誤認識

 投稿者：荒田浩二  投稿日：2008年10月27日(月)08時31分49秒 		返信・引用 　編集済
  第2掲示板ではHTMLタグを使えますが、不等号をタグと誤認識することがあるようなので報告します。
「右開き不等号(<)+タグ用語+空白」でタグと認識し、次の左開き不等号(>)までの間にある文字が表示されません。
（元の文として表示しているのは不等号を全角にしています。）
投稿する際は、変数名をタグ用語と変えるか、j<p+0 の様にして不等号に続く変数の後ろを空白にしない、または不等号の向きを変えるといった工夫が必要になります。
参考までに1文字のタグは、a,b,i,p,q,s,u。h1〜h6も見出しと認識されます。(訂正;掲示板内では見出しタグは使えないようです)

この問題の原因はレンタル掲示板にあるのでどうしようもないですよね？



例1 : フォント(font)
10 IF ac THEN LET font=1

元1 :
10 IF a＜font AND b＞c THEN LET font=1


例2 : 改行(br)
20 IF x
z THEN LET br=2

元2 :
20 IF x＜br OR y＞z THEN LET br=2


例3 : ハイパーリンク(a)
30 IF di THEN LET h=5

元3 :
30 IF d＜a THEN LET d=3
40 LET e=e+1
50 IF f＜g THEN LET f=4
60 IF h＞i THEN LET h=5


例4 : 段落(p)
70 IF j

l THEN LET j=6

元4 :
70 IF j＜p OR k＞l THEN LET j=6


例5 : ボールド体(b)
80 IF mo THEN LET m=7

元5 :
80 IF m＜b AND n＞o THEN LET m=7


問題なし :
10 a<fontx AND b>c THEN LET fontx=1
70 IF j<p+0 OR k>l THEN LET j=6
80 IF b>m AND n>o THEN LET m=7


(＜b で太字になってしまったので＜/b＞と記述されるまで直りません。)

 		 

Re: 不等号をタグと誤認識

 投稿者：山中和義  投稿日：2008年10月27日(月)12時59分39秒 		返信・引用 　編集済
  > No.28[元記事へ]

気になる特殊文字の書き込み試験です。

PRINT "＆ＬＴ；"
PRINT "＆ｌｔ；"
PRINT "123"＆ｌｔ$
PRINT "123"＆ｌｔｕｖｗ$
IF a＜font AND b>c THEN LET font=1

と記述したプログラムを投稿したとする。



PRINT "<"
PRINT "<"
PRINT "123"<$
PRINT "123"&ltuvw$
IF ac THEN LET font=1



PREタグを指定してみる
PRINT "<"
PRINT "<"
PRINT "123"<$
PRINT "123"&ltuvw$
IF ac THEN LET font=1


ということは、＜と＆を＆ｌｔ；，＆ａｍｐ；に変換しておけばいいのでしょうか！？ 		 

Re: 不等号をタグと誤認識

 投稿者：白石　和夫  投稿日：2008年10月28日(火)08時04分13秒 		返信・引用 　編集済
  > No.29[元記事へ]

十進BASIC FAQ 掲示板の使い方に & ，< の置換手順を追加しました。
なお，ほかにお気づきの点があればお知らせください。 		 

モンテカルロ法による数値積分

 投稿者：山中和義  投稿日：2008年10月28日(火)11時14分32秒 		返信・引用 　編集済
  !モンテカルロ法（Monte Carlo Method）による数値積分

DEF f(x)=1/(1+x) !被積分関数

!●入門的モンテカルロ法
!　∫[0,1]f(x)dx=Σ[i=1,N]f(i/N)/N=1/N*Σ[i=1,N]f(xi)
!
!　x=[a,b]範囲で一様乱数で点(x,y)をN個発生させると
!　∫[a,b]f(x)dx=(b-a)/N*Σ[i=1,N]f(xi)

LET N=500000 !乱数の発生個数

LET a=0
LET b=1

LET ba=b-a
LET h=0
FOR i=1 TO N
   LET x=RND*ba+a !N個の一様乱数
   LET h=h+f(x) !Σf
NEXT i
LET S=h*ba/N

PRINT S, LOG(2)



!●「あたりはずれ」のモンテカルロ法
!　x=[a,b]、y=[0,c]、0<f(x)<cの範囲で
!　一様乱数で点(x,y)をN個発生させて、y<f(x)の数をnとすると
!　∫[a,b]f(x)dx=c*(b-a)*n/N

LET N=500000 !乱数の発生個数

LET a=0
LET b=1
LET c=1

LET ba=b-a
LET hit=0
FOR i=1 TO N
   LET x=RND*ba+a !N個の一様乱数
   LET y=RND*c
   IF y<f(x) THEN LET hit=hit+1 !fより下の領域
NEXT i
LET S=c*ba * hit/N !長方形との面積比

PRINT S, LOG(2)


END 		 

＜ ＆ の直後には、半角スペースを必ず置く。

 投稿者：SECOND  投稿日：2008年10月28日(火)13時02分40秒 		返信・引用 　編集済
  １）＜の直後には、半角スペースを置く。( 不等号＜＞は、そのままで良いようです。)
２）＆の直後には、半角スペースを置く。

の様にすると、
タグと、文字参照、のシーケンスが止められます。掲示用のリストで「実行」も兼用。

スペース挿入効果の試験です。

PRINT "＆ ＬＴ；"
PRINT "＆ ｌｔ；"
PRINT "123"＆ ｌｔ$
PRINT "123"＆ ｌｔｕｖｗ$
IF a＜ font AND b>c THEN LET font=1
IF a＜＞b THEN LET font=2

と記述したプログラムを投稿したとする。

PRINT "& LT;"
PRINT "& lt;"
PRINT "123"& lt$
PRINT "123"& ltuvw$
IF a< font AND b>c THEN LET font=1
IF a<>b THEN LET font=2

文字参照　の試験を、もう少し追加。(右側は、スペース無しの同文)

print "& #34; & quot;"    ! print "" ""
print "& #38; & amp;"     ! print "& &"
print "& #60; & lt;"      ! print "< <"
print "& #62; & gt;"      ! print "> >"
print "& #160; & nbsp;"   ! print "   "
print "& #161; & iexcl;"  ! print "ｸA憎ｸA蔵
print "& #162; & cent;"   ! print "¢ ¢"
print "& #163; & pound;"  ! print "£ £"
print "& #164; & curren;" ! print "ｸA陞ｸA陟
print "& #165; & yen;"    ! print "\ \"
print "& #166; & brvbar;" ! print "�� ��"
print "& #167; & sect;"   ! print "§ §"
print "& #168; & uml;"    ! print "¨ ¨"
print "& #169; & copy;"   ! print "ｸA迸ｸA蹉

--------------------------------------------------
&& の試験。

LET copy$="&& を使用して１行に"

PRINT "１行に書き切れなくて、改行してしまったが、"&
&ｸA蹐 & "つないで、この行を、改行していない１行の文字列にした。"

PRINT "１行に書き切れなくて、改行してしまったが、"&
&& copy$ & "つないで、この行を、改行していない１行の文字列にした。"
  ↑
このスペースが無い場合(上)と、有る場合(下)。

--------------------------------------------------
＜の試験　を追加。(半角スペース後付けの出来ないケース)

IF X ＜＝ 10 THEN PRINT USING "＜###" : 123
IF X ＜＞ 10 THEN PRINT USING "＜%%%" : 123
IF X＜＝10 THEN PRINT USING "＜###":123
IF X＜＞10 THEN PRINT USING "＜%%%":123
PRINT USING "#＜" : w10, w1
PRINT USING "#＜":w10, w1

　と書いたとする。

IF X <= 10 THEN PRINT USING "<###" : 123
IF X <> 10 THEN PRINT USING "<%%%" : 123
IF X<=10 THEN PRINT USING "<###":123
IF X<>10 THEN PRINT USING "<%%%":123
PRINT USING "#<" : w10, w1
PRINT USING "#<":w10, w1 		 

世界のナベアツにBASICで挑戦！　おもろ〜

 投稿者：山中和義  投稿日：2008年10月29日(水)11時14分24秒 		返信・引用 　編集済
  以前、プログラミングの練習に「３の倍数」と「３の付く数」の判定方法を検討してみました。
今回は、数を多項式やベクトルや行列で表現して、その演算で判定してみます。


!自然数nの各位の値が係数となる多項式p(x)=k1+k2*x+k3*x^2+ …で表す。
!21の場合
!　p(x)=1+2*x+0*x^2+0*x^3+ …
!元のnに戻すには、x=10として関数値を計算すればよい。
!　p(10)=1*1+2*10+0*100+0*1000+ … =21

DEF p(x)=k1+k2*x+k3*x^2+k4*x^3 !多項式

FOR k2=0 TO 9 !十の位
   FOR k1=0 TO 9 !一の位

      IF MOD(p(1),3)=0 THEN !各桁の和が３の倍数なら
         PRINT p(10) !x=k1+k2*10+k3*100+ …
      ELSEIF k1=3 OR k2=3 THEN !いずれかが３となる
         PRINT p(10) !x=k1+k2*10+k3*100+ …
      END IF

   NEXT k1
NEXT k2





!自然数nの各位の値が成分となるベクトルで表す。
!21の場合
!　(1 2)
!元のnに戻すには、10のべき乗を成分とするベクトルと内積をとればよい。
!　(1 2)・(1 10)=1*1+2*10=21

LET K=4 !桁数

DIM CC(K) !定数 (1 1 1 …)
MAT CC=CON
DIM BB(K) !定数 (1 10 100 …)
FOR i=1 TO K
   LET BB(i)=10^(i-1) !位
NEXT i
DIM V(K) !ベクトル
FOR k2=0 TO 9 !十の位
   LET V(2)=k2
   FOR k1=0 TO 9 !一の位
      LET V(1)=k1

      IF MOD(DOT(V,CC),3)=0 THEN !各桁の和が３の倍数なら
         PRINT DOT(V,BB) !x=k1+k2*10+k3*100+ …
      ELSEIF V(1)=3 OR V(2)=3 THEN !いずれかが３となる
         PRINT DOT(V,BB) !x=k1+k2*10+k3*100+ …
      END IF

   NEXT k1
NEXT k2





!自然数nの各位の値が要素となる対角行列で表す。
!21の場合
!　┌ 1 0 ┐
!　└ 0 2 ┘
!元のnに戻すには、10のべき乗を要素とする行列をかければよい。
!　┌ 1 0 ┐┌ １ ┐
!　└ 0 2 ┘└ 10 ┘
!　＝┌ １ ┐
!　　└ 20 ┘
!さらに、すべての要素が１の行列をかければよい。
!　[1 1]┌ １ ┐＝[21]
! 　　　└ 20 ┘

FUNCTION tr(A(,)) !行列Aのトレース
   LET t=0 !対角成分の和
   FOR m=1 TO MIN(UBOUND(A,1),UBOUND(A,2))
      LET t=t+A(m,m)
   NEXT m
   LET tr=t
END FUNCTION


LET K=4 !桁数

DIM B(K,1) !定数 t[1 10 100 …]
FOR i=1 TO K
   LET B(i,1)=10^(i-1) !位
NEXT i

DIM C(1,K) !定数 [1 1 1 …]
MAT C=CON

DIM TT(K,1),X(1,1) !作業用

DIM A(K,K) !対角行列
MAT A=ZER
FOR k2=0 TO 9 !十の位
   LET A(2,2)=k2
   FOR k1=0 TO 9 !一の位
      LET A(1,1)=k1

      IF MOD(tr(A),3)=0 THEN !各桁の和が３の倍数なら
         MAT TT=A*B !x=k1+k2*10+k3*100+ …
         MAT X=C*TT
         MAT PRINT X; !PRINT X(1,1)
      ELSEIF A(1,1)=3 OR A(2,2)=3 THEN !いずれかが３となる
         MAT TT=A*B !x=k1+k2*10+k3*100+ …
         MAT X=C*TT
         MAT PRINT X;
      END IF

   NEXT k1
NEXT k2


END 		 

旧掲示板の投稿をキャッシュからサルベージ

 投稿者：荒田浩二  投稿日：2008年10月30日(木)08時04分4秒 		返信・引用
  十進BASICの旧掲示板が10月上旬から運営会社aroundの活動停止により事実上閉鎖されました。
「掲示板過去ログ」に保管されていなかった101〜110ページの投稿を検索サイトのキャッシュから拾い出す方法を紹介します。
ただしキャッシュですから、すべてのページが保存されているわけではありません。
分割して投稿されたプログラムなどは、部分的にしか拾えないかもしれません。
また、キャッシュは日々更新されますのであと1,2ヶ月もしたらほとんどのページが削除されると思います。
数日前と比較してもヒット数が減っています。
必要な投稿は早めにパソコンに保存しておくことをお勧めします。


1.検索サイトGoogleで "十進BASIC掲示板" を検索します。
  (余計な情報を排除するためダブルクォテーション(")で囲みましょう)

2.検索結果の最後に、
    最も的確な結果を表示するために、上の○○件と似たページは除外されています。
    検索結果をすべて表示するには、ここから再検索してください。
  とあるのでクリックして下さい。

3.検索結果のうち、URLが freebbs.around.ne.jp で始まるものが旧掲示板の投稿です。
  /basic/ または &pg= の後ろにある数字が旧掲示板のページ番号です。
  （URLが www.geocities.jp とあるのは「掲示板過去ログ」にあるのでそちらをご覧ください）

4.内容を見るには必ずキャッシュをクリックして下さい。
  （見出しをクリックすると接続エラーになります）

5.下の語句からも検索できます。他の検索サイトからも検索してみて下さい。
    "freebbs.around.ne.jp/article/b/basic/"

    "freebbs.around.ne.jp/kyview","basic" 		 

Re: 旧掲示板の投稿をキャッシュからサルベージ

 投稿者：SECOND  投稿日：2008年10月31日(金)18時20分1秒 		返信・引用
  > No.34[元記事へ]

目次だけで、直接に中味は見れませんが、個別検索のキーワードに。

Page : 101~110 全ページ（ツリー表示）のキャッシュが、ありました。
Live Search で、下のキーワード

"初心者歓迎！ 十進BASIC掲示板" "Page : 110"
  (
   )
"初心者歓迎！ 十進BASIC掲示板" "Page : 101"

（すでに消去されている場合、保存してありますので御要望があればココに掲示します。） 		 

Re: 旧掲示板の投稿をキャッシュからサルベージ

 投稿者：白石　和夫  投稿日：2008年10月31日(金)18時36分7秒 		返信・引用
  > No.35[元記事へ]

メール等でデータをいただければ，十進BASIC過去ログの頁に掲載します。 		 

プログラムのお願い

 投稿者：GAI  投稿日：2008年11月 1日(土)10時51分27秒 		返信・引用
  オイラー方陣が６次では構成不可能であることを、しらみつぶしにより
確認することをやってみたいのです。
どなたか十進BASICにてプログラムを組んでいただけないでしょうか？
オイラー方陣とは5次なら（２次と６次以外は構成可能と証明されている。）
12 23 34 45 51
53 14 25 31 42
44 55 11 22 33
35 41 52 13 24
21 32 43 54 15
のように、十位と一位にくる数（１〜５）が
各行、各列に重複することが起きない。
（ただし２５個の数字は全て異なるものとする。）
自分でやっていて、なかなか進展しないものですのでよろしくお願いします。 		 

Re: プログラムのお願い

 投稿者：白石　和夫  投稿日：2008年11月 1日(土)20時58分48秒 		返信・引用
  > No.37[元記事へ]

1〜6の数字で作られる2桁の数は全部で36個あります。
なので，これら36個の数の順列すべてについて条件を満たすかどうか調べればよいはずです。
ただし，
36!＝371993326789901217467999448150835200000000 ≒3.7E41
なので，1秒に1万件テストしたとしても3.7E37秒≒1.12E30年かかります。 		 

Re: プログラムのお願い

 投稿者：GAI  投稿日：2008年11月 1日(土)22時13分32秒 		返信・引用
  > No.38[元記事へ]

白石　和夫さんへのお返事です。
/* ６次のオイラー方陣が存在しないことを確認する. */

#include <stdio.h>
#include <stdlib.h>
#include <string.h>

#define N 6

char lb[9408][N][N];
/* N=1〜7: 1,1,1,4,56,9408,16942080 N=7は非現実的 */

int lbs;
char wb[N][N];
int p, q;
char xidx[N], yidx[N];

void check1(int n);

void makelb(int x, int y)
{
int i, j;

for(i = 0; i < N; ++i){
for(j = 0; j < x; ++j)
if((char)i == wb[y][j])
break;
if(j >= x){
for(j = 0; j < y; ++j)
if((char)i == wb[j][x])
break;
if(j >= y){
wb[y][x] = (char)i;
if(y == N - 1 && x == N - 1){
memcpy(lb[lbs++], wb, sizeof(wb));
return;
}
if(y == N - 1)
makelb(x + 1, 1);
else
makelb(x, y + 1);
}
}
}
}

void echk(void)
{
static char fb[N][N];
int i, j;

memset(fb, 0, sizeof(fb));
for(i = 0; i < N; ++i)
for(j = 0; j < N; ++j){
if(fb[lb[p][i][j]][lb[q][yidx[i]][xidx[j]]])
return;
fb[lb[p][i][j]][lb[q][yidx[i]][xidx[j]]] = 1;
}
for(i = 0; i < N; ++i)
for(j = 0; j < N; ++j)
printf("%c%c%c", lb[p][i][j] + '0', lb[q][yidx[i]][xidx[j]] + '0',
j == N - 1 ? '\n' : ' ');
exit(0);
}

void check2(int n)
{
int i;
char c;

for(i = n; i < N; ++i){
c = yidx[i];
yidx[i] = yidx[n];
yidx[n] = c;
if(yidx[n] != xidx[n] && (n != 1 || yidx[n] < xidx[n]))
if(n == N - 1)
echk();
else
check1(n + 1);
c = yidx[i];
yidx[i] = yidx[n];
yidx[n] = c;
}
}

void check1(int n)
{
int i;
char c;

for(i = n; i < N; ++i){
c = xidx[i];
xidx[i] = xidx[n];
xidx[n] = c;
check2(n);
c = xidx[i];
xidx[i] = xidx[n];
xidx[n] = c;
}
}

int main(void)
{
int i, count;

for(i = 0; i < N; ++i)
wb[0][i] = wb[i][0] = (char)i;
lbs = 0;
makelb(1, 1);

count = 0;
for(p = 0; p < lbs; ++p)
for(q = p; q < lbs; ++q){
if(++count % 1000 == 0)
printf("%d\r", count);
for(i = 0; i < N; ++i)
xidx[i] = yidx[i] = (char)i;
check1(1);
}
printf("解は見つかりませんでした.\n");
return 0;
}
がｃ言語でのプログラムでの解決法（５時間ほどでOK！）です。
これをBASICで書き直せないでしょうか。（自分はC言語に不勉強なので） 		 

Re: プログラムのお願い

 投稿者：山中和義  投稿日：2008年11月 2日(日)08時22分9秒 		返信・引用
  > No.38[元記事へ]

総当りの王道としてバックトラック法があります。
ただし、不適以降は無視（枝刈り）するので検証する場合の数がいくらか減ります。

う〜ん、現実的ではない！
掲載されたＣ言語のように標準形のラテン方陣からのアプローチを検討してほしい。


LET N=5 !大きさ N×N

PUBLIC NUMERIC ANSWER_COUNT !解答数
LET ANSWER_COUNT=0

PUBLIC STRING num$
LET num$="0123456789ABCDEF" !N進法の数字

DIM M(0 TO N-1,0 TO N-1) !平方の方陣
MAT M=(-1)*CON

SET WINDOW -1,N+1,N+1,-1
DRAW grid

LET t0=TIME
CALL BackTrack(N,M,0) !左上から
PRINT "計算時間=";TIME-t0

END


EXTERNAL SUB BackTrack(N,M(,),p) !（左上からの連番）位置pを調査する
IF p<N*N THEN !すべてが埋まるまで
   LET row=INT(p/N) !行と列に換算する
   LET col=MOD(p,N)

   FOR k=0 TO N*N-1 !０〜N*N-1範囲の数字を
      CALL CheckRule(N,M, row,col,k, rc)!矛盾なく置ければ
      IF rc=1 THEN
         SET TEXT COLOR 1
         PLOT TEXT ,AT col+0.5,row+0.5: STR$(k)

         LET M(row,col)=k !ここに置いてみる
         CALL BackTrack(N,M,p+1) !次へ
         LET M(row,col)=-1 !取り消す

         SET TEXT COLOR 0
         PLOT TEXT ,AT col+0.5,row+0.5: STR$(k)
      END IF
   NEXT k

ELSE !すべて埋まったら
   LET ANSWER_COUNT=ANSWER_COUNT+1 !解答数
   PRINT ANSWER_COUNT

   FOR i=0 TO N-1
      FOR j=0 TO N-1
         LET t=M(i,j)
         LET k1=MOD(t,N)+2 !N進法での各桁の値（文字位置を加味）
         LET k2=INT(t/N)+2
         PRINT num$(k2:k2); num$(k1:k1); " "; !解を表示する
      NEXT j
      PRINT
   NEXT i
   PRINT

END IF
END SUB


EXTERNAL SUB CheckRule(N,M(,), row,col,K, rc) !同じ数があるかどうか確認する
LET rc=0

FOR y=0 TO N-1 !埋まっている範囲で未使用の数字か
   FOR x=0 TO N-1
      IF y>=row AND x>=col THEN EXIT FOR
      IF M(y,x)=K THEN EXIT SUB !見つかったので、ＮＧ！
   NEXT x
NEXT y

LET k1=MOD(K,N) !N進法での１桁目
LET k2=INT(K/N) !N進法での２桁目
FOR y=0 TO row-1 !列
   LET t=M(y,col)
   IF MOD(t,N)=k1 THEN EXIT SUB
   IF INT(t/N)=k2 THEN EXIT SUB
NEXT y

FOR x=0 TO col-1 !行
   LET t=M(row,x)
   IF MOD(t,N)=k1 THEN EXIT SUB
   IF INT(t/N)=k2 THEN EXIT SUB
NEXT x

LET rc=1 !見つからないので、ＯＫ！
END SUB 		 

Re: プログラムのお願い

 投稿者：GAI  投稿日：2008年11月 2日(日)13時12分5秒 		返信・引用
  > No.40[元記事へ]

山中和義さんへのお返事です。

まさにこんなことができるプログラムを構成したかったのです。
自分だけであくせく路頭に迷うより、誰かに尋ねると世の中
才能ある人が必ずいるもので、こちらが１ヶ月かかってもできない
ことでも、１時間もあれば見通せる人がいるなんて感動です。
プログラムをコピーさせてもらい、中身の仕組みを分析していきます。
どうも自分はコンピューターに使われている感覚ですが、
山中さんのような人はまさにコンピューターをこき使っている雰囲気です。
私も、コンピューターを思いのまま動かすことが出来るプログラム構成の
力を向上できるよう精進していきたいです。
山中さんは趣味でやられてきたのですか？
それともお仕事で必要でマスターされてきたのですか？
できたらコンピューター歴をお聞かせください。 		 

Re: プログラムのお願い

 投稿者：山中和義  投稿日：2008年11月 2日(日)20時25分34秒 		返信・引用 　編集済
  > No.41[元記事へ]

GAIさんへのお返事です。

仕事と趣味でコンピュータは扱っています。
このBASICは高校数学、工業を題材にプログラミングを楽しんでいます。


●掲載のＣ言語プログラムの説明
ラテン方陣からのアプローチ
作業手順
Step1. 標準形ラテン方陣を求める。
　例. ３×３の場合
　　1 2 3
　　2 3 1
　　3 1 2
Step2. ２つのラテン方陣の組合せる。
　標準形ラテン方陣から対称、回転を含んですべてのラテン方陣を求める。
　オイラー方陣が成立するものを採用する。
　例. ３×３の場合
　　1 2 3　　3 1 2　　13 21 32
　　2 3 1　　2 3 1　　22 33 11
　　3 1 2　　1 2 3　　31 12 23
　オイラー方陣が成立するので、採用。

たとえば、３×３の場合は標準形が１通り、その展開が１２通りあるから
1Ｈ2×１２通りを検証する必要がある。

　N=1、1=1!×0!×1
　N=2、2=2!×1!×1
　N=3、12=3!×2!×1
　N=4、576=4!×3!×4
　N=5、161,280=5!×4!×56
　N=6、812,851,200=6!×5!×9,408
　N=7、6,147,941,990,400=7!×6!×16,942,080

　※標準形ラテン方陣（１行目と１列目が整列しているもの）は
　　N=1,2,3,4,5,6,7,…なら、1,1,1,4,56,9408,16942080,…となる。

方陣が大きくなればそれに伴い増大して容量、計算量が増える。


インタプリタ系言語BASICで処理を考えると、
容量の問題から掲載されたＣ言語の手順のように組合せごとに標準形ラテン方陣を展開したい。
でも、検証する「場合の数」が多いため、処理時間の問題から、ラテン方陣をそのまま記録したい。

これは悩ましい問題である。



!（標準形）ラテン方陣を求める

LET N=5 !大きさ N×N

PUBLIC NUMERIC CntOfLM !その数
LET CntOfLM=0

PUBLIC STRING num$
LET num$="0123456789ABCDEF" !N進法の数字

DIM M(0 TO N*N-1) !平方の方陣
MAT M=(-1)*CON

FOR i=0 TO N-1 !標準形の場合　※１行目と１列目が整列している
   LET M(i*N+0)=i
   LET M(0*N+i)=i
NEXT i

LET t0=TIME
CALL BackTrack(N,M,0) !左上から
PRINT "計算時間=";TIME-t0

END


EXTERNAL SUB BackTrack(N,M(),p) !（左上からの連番）位置pを調査する
IF p<N*N THEN !すべてが埋まるまで
   IF M(p)>=0 THEN !既に置いてあれば
      CALL BackTrack(N,M,p+1) !次へ
   ELSE
      FOR k=0 TO N-1 !数字０〜N-1を
         CALL CheckRule(N,M, p,k, rc)!矛盾なく置ければ
         IF rc=1 THEN
            LET M(p)=k !ここに置いてみる
            CALL BackTrack(N,M,p+1) !次へ
            LET M(p)=-1 !取り消す
         END IF
      NEXT k
   END IF

ELSE !すべて埋まったら
   LET CntOfLM=CntOfLM+1 !解答数
   PRINT CntOfLM

   FOR i=0 TO N-1
      FOR j=0 TO N-1
         LET t=M(i*N+j)+1
         PRINT num$(t+1:t+1); " "; !解を表示する
      NEXT j
      PRINT
   NEXT i
   PRINT

END IF
END SUB


EXTERNAL SUB CheckRule(N,M(), p,K, rc) !同じ数があるかどうか確認する
LET rc=0

LET row=INT(p/N) !行と列に換算する
LET col=MOD(p,N)

FOR i=0 TO row-1 !列
   IF M(i*N+col)=K THEN EXIT SUB
NEXT i

FOR i=0 TO col-1 !行
   IF M(row*N+i)=K THEN EXIT SUB
NEXT i

LET rc=1 !見つからないので、ＯＫ！
END SUB 		 

山中さんへお礼と感想

 投稿者：GAI  投稿日：2008年11月 2日(日)23時33分46秒 		返信・引用
  再度の掲載ありがとうございます。
例の数字：１，１，１，４，５６，９４０８・・・とはどうやって決まっているんだろう？
なにか公式でもあるのかしら、と疑問に思っていましたがつまりこれは実際に構成
したときに、この数しか作れないというものなのですね。
これは計算から求まる値ではないですよね。
このプログラムではっきりとその数の意味するものを理解できました。
　N=1、1=1!×0!×1
　N=2、2=2!×1!×1
　N=3、12=3!×2!×1
　N=4、576=4!×3!×4
　N=5、161,280=5!×4!×56
　N=6、812,851,200=6!×5!×9,408
　N=7、6,147,941,990,400=7!×6!×16,942,080
の計算からN=6では８億以上の組み合わせを調査せねばならないということに
なるわけですか？
本によると、６次のオイラー方陣が不可能であることを理論ではなく、場合列挙の
方法で証明した（１９００年頃G.TARRYという人物）と書かれていました。
当時高速コンピューターもない時代にこんなことができるんでしょうか？
もしこんなに可能性が大量に発生する問題に計算機無しに決着をつけたとしたら
その根性はとんでもないものだと驚愕します。
先人の知恵や執念を垣間見た感慨です。
それにしてもオイラーという人物は、さらに怪物に見えます。 		 

Re: 山中さんへお礼と感想

 投稿者：山中和義  投稿日：2008年11月 4日(火)13時38分41秒 		返信・引用
  > No.43[元記事へ]

GAIさんへのお返事です。

C言語版を移植してみました。ただし、直訳ではありません。
全解求めるようになっていますので、C言語版のように最初の解のみは、
プログラムの最後のSTOP文を有効にしてください。

N=5がすでに厳しいようです。100倍!?ぐらいの速さの差を感じます。
前回紹介したバックトラック法よりは良好です。


!オイラー方陣を求める

LET N=5 !大きさ N×N

!※N=1,2,3,4,5,6,7,…なら、1,1,1,4,56,9408,16942080,…となる。
PUBLIC NUMERIC LM(9408,0 TO 35) !標準形ラテン方陣 N=6

PUBLIC NUMERIC CntOfLM !その数
LET CntOfLM=0

DIM M(0 TO N*N-1) !平方の方陣
MAT M=(-1)*CON
FOR i=0 TO N-1 !標準形　※１行目と１列目が整列している
   LET M(i*N+0)=i
   LET M(0*N+i)=i
NEXT i

LET t0=TIME
CALL BackTrack(N,M,0) !左上から
PRINT CntOfLM
PRINT "計算時間=";TIME-t0



LET t0=TIME

PUBLIC NUMERIC ANSWER_COUNT !解答数
LET ANSWER_COUNT=0

LET cnt=0 !検証回数
LET cc=comb(CntOfLM+2-1,2)

DIM A(0 TO N-1,0 TO N-1),B(0 TO N-1,0 TO N-1)
FOR i=1 TO CntOfLM !標準形Aと標準形Bの展開との重複組合せ 56H2
   FOR y=0 TO N-1 !Aを指定する
      FOR x=0 TO N-1
         LET A(y,x)=LM(i,y*N+x)
      NEXT x
   NEXT y

   FOR j=i TO CntOfLM

      LET cnt=cnt+1 !進捗
      PRINT cnt;"/";cc

      FOR y=0 TO N-1 !Bを指定する
         FOR x=0 TO N-1
            LET B(y,x)=LM(j,y*N+x)
         NEXT x
      NEXT y

      DIM R(N) !順列の初期値
      FOR k=1 TO N
         LET R(k)=k
      NEXT k
      CALL RPerm(N,A,B, R,2) !まず行順を指定する　※１行目は固定
   NEXT j
NEXT i
IF ANSWER_COUNT=0 THEN PRINT "解なし"

PRINT "計算時間=";TIME-t0


END


EXTERNAL SUB BackTrack(N,M(),p) !（左上からの連番）位置pを調査する
IF p<N*N THEN !すべてが埋まるまで
   IF M(p)>=0 THEN !既に置いてあれば
      CALL BackTrack(N,M,p+1) !次へ
   ELSE
      FOR k=0 TO N-1 !数字０〜N-1を
         CALL CheckRule(N,M, p,k, rc)!矛盾なく置ければ
         IF rc=1 THEN
            LET M(p)=k !ここに置いてみる
            CALL BackTrack(N,M,p+1) !次へ
            LET M(p)=-1 !取り消す
         END IF
      NEXT k
   END IF

ELSE !すべて埋まったら
   LET CntOfLM=CntOfLM+1 !数と配置を記録する
   FOR i=0 TO N*N-1
      LET LM(CntOfLM,i)=M(i)
   NEXT i

END IF
END SUB


EXTERNAL SUB CheckRule(N,M(), p,K, rc) !同じ数があるかどうか確認する
LET rc=0

LET row=INT(p/N) !行と列に換算する
LET col=MOD(p,N)

FOR i=0 TO row-1 !列
   IF M(i*N+col)=K THEN EXIT SUB
NEXT i

FOR i=0 TO col-1 !行
   IF M(row*N+i)=K THEN EXIT SUB
NEXT i

LET rc=1 !見つからないので、ＯＫ！
END SUB


EXTERNAL SUB RPerm(N,A(,),B(,), P(),i) !順列を生成して行の並び替え　※辞書式順ではない
IF I<N THEN
   FOR j=i TO N
      LET t=P(i) !i番目とj番目を交換する
      LET P(i)=P(j)
      LET P(j)=t
      CALL RPerm(N,A,B, P,i+1) !再帰呼出し
      LET t=P(i) !元に戻す
      LET P(i)=P(j)
      LET P(j)=t
   NEXT j

ELSE !完了なら
   DIM C(N) !順列の初期値
   FOR j=1 TO N
      LET C(j)=j
   NEXT j
   CALL CPerm(N,A,B,P,C,1) !今度は列順を指定する

END IF
END SUB


EXTERNAL SUB CPerm(N,A(,),B(,),R(), P(),i) !順列を生成して列の並び替え　※辞書式順ではない
IF I<N THEN
   FOR j=i TO N
      LET t=P(i) !i番目とj番目を交換する
      LET P(i)=P(j)
      LET P(j)=t
      CALL CPerm(N,A,B,R, P,i+1) !再帰呼出し
      LET t=P(i) !元に戻す
      LET P(i)=P(j)
      LET P(j)=t
   NEXT j

ELSE !オイラー方陣をつくって検証する

   DIM EM(N,N) !使用できる数字の組と使用状況
   MAT EM=ZER

   !※ラテン方陣の組合せなので、行と列の重複はない。
   FOR i=0 TO N-1 !方陣全体で同じ数があるかどうか確認する
      FOR j=0 TO N-1
         LET rr=A(i,j)+1 !オイラー方陣をつくる
         LET cc=B(R(i+1)-1,P(j+1)-1)+1
         IF EM(rr,cc)=1 THEN EXIT SUB !その数字は使用中なのでＮＧ！
         LET EM(rr,cc)=1
      NEXT j
   NEXT i


   LET ANSWER_COUNT=ANSWER_COUNT+1 !解答数
   PRINT ANSWER_COUNT

   FOR i=0 TO N-1 !答えを表示する
      FOR j=0 TO N-1
         PRINT (A(i,j)+1)*10 + B(R(i+1)-1,P(j+1)-1)+1 ;
      NEXT j
      PRINT
   NEXT i

   !!!STOP !最初に見つけた答え

END IF
END SUB 		 

Re: プログラムのお願い

 投稿者：SECOND  投稿日：2008年11月 4日(火)14時32分41秒 		返信・引用 　編集済
  > No.39[元記事へ]

!掲示のＣ言語のリストを、十進BASIC版に書き直したもので、何も変わっていません。
!全く同じものだと、思います。違っていたら御免なさい。

!check1、check2 の交番する再帰コールは、見ずらいので、
!check1 １本の中に統合したが、内容は同じです。

OPTION BASE 0
LET N= 3 !　2,3,4,5,6
DIM lb(9408,N,N) !　N=1〜7: 1,1,1,4,56,9408,16942080 N=7は非現実的
DIM wb(N,N), xidx(N), yidx(N), fb(N,N)
!
CALL main

SUB makelb(x, y)
   local i,j
   FOR i=0 TO N-1
      FOR j=0 TO x-1
         IF i=wb(y,j) THEN EXIT FOR ! break;
      NEXT j
      IF j>x-1 THEN
         FOR j=0 TO y-1
            IF i=wb(j,x) THEN EXIT FOR ! break;
         NEXT j
         IF j>y-1 THEN
            LET wb(y,x)= i
            IF y=N-1 AND x=N-1 THEN
            !----memcpy(lb[lbs++], wb, sizeof(wb));
               FOR a=0 TO N
                  FOR b=0 TO N
                     LET lb(lbs,a,b)=wb(a,b)
                  NEXT b
               NEXT a
               LET lbs=lbs+1
               !---------------
               EXIT SUB ! return;
            END IF
            IF y=N-1 THEN CALL makelb(x+1, 1) ELSE CALL makelb((x),y+1)
         END IF
      END IF
   NEXT i
END SUB


SUB echk
   local i,j
   MAT fb=ZER ! memset(fb, 0, sizeof(fb));
   FOR i= 0 TO N-1
      FOR j= 0 TO N-1
         IF fb( lb(p,i,j), lb(q,yidx(i),xidx(j)) )>0 THEN EXIT SUB ! return;
         LET fb( lb(p,i,j), lb(q,yidx(i),xidx(j)) )=1
      NEXT j
   NEXT i
   FOR i= 0 TO N-1
      FOR j= 0 TO N-1
         PRINT USING "%#": lb(p,i,j)+1, lb(q,yidx(i),xidx(j))+1;
         IF j=N-1 THEN PRINT ELSE PRINT " ";
      NEXT j
   NEXT i
   STOP ! exit(0);
END SUB


SUB check1(n_)
   local i
   FOR i=n_ TO N-1
      swap xidx(i),xidx(n_)
      !-----check2(n_)
      local i_
      FOR i_= n_ TO N-1
         swap yidx(i_),yidx(n_)
         IF ( yidx(n_)<>xidx(n_)) AND (n_<>1 OR yidx(n_)< xidx(n_) ) THEN
            IF n_=N-1 THEN CALL echk ELSE CALL check1(n_+1)
         END IF
         swap yidx(i_),yidx(n_)
      NEXT i_
      !------
      swap xidx(i),xidx(n_)
   NEXT i
END SUB


SUB main
   FOR i= 0 TO N-1
      LET wb(i,0)= i
      LET wb(0,i)= i
   NEXT i
   LET lbs = 0
   PRINT "N=";N; ! 追加した表示
   CALL makelb(1,1)
   PRINT "lbs=";lbs !追加
   MAT PRINT wb !　　追加
   LET count= 0
   FOR p=0 TO lbs-1
      FOR q=p TO lbs-1
         LET count=count+1
         IF MOD(count,1000)=0 THEN PRINT count
         FOR i= 0 TO N-1
            LET yidx(i)= i
            LET xidx(i)= i
         NEXT i
         CALL check1(1)
      NEXT q
   NEXT p
   PRINT "解は見つかりませんでした."
END SUB

END

!注意：このリストは、for~nextの中から再帰コールをしているので、十進BASICの
!　　　Ver7.2.0 以降 のバージョンが必要です。 		 

Re: プログラムのお願い

 投稿者：山中和義  投稿日：2008年11月 4日(火)16時27分16秒 		返信・引用
  > No.45[元記事へ]

SECONDさんへのお返事です。

SECONDさん、お久しぶりです。

Ｃ言語版のコードをみて思ったのですが

・N=1が求まらない
・順列の生成がおかしい（行や列の交換が不十分）
　→標準形からすべて展開されていない
　→exitの箇所をコメント（無効）にしても全解が得られない
　→N=6で検証していない箇所がある
の疑問があります。

GAIさんを経由してＣ言語版の作者に聞くのが筋と思いますが、
SECONDさんは、どのように感じていますか？ 		 

Re: プログラムのお願い

 投稿者：SECOND  投稿日：2008年11月 4日(火)17時00分31秒 		返信・引用
  > No.46[元記事へ]

山中和義さんへのお返事です。

全く同感です。その様にして頂ければと、思います。 		 

カードマジックで出会った現象

 投稿者：GAI  投稿日：2008年11月 4日(火)22時52分56秒 		返信・引用
  お二人の強力なプログラマーの出現により、C言語とBASIC言語との比較をしながらとってもいい勉強ができています。
Cのスピードは魅力的ですが、どうも約束事が多くて馴染み難いのです。
その点BASICの記述では何をしたいのかがCに較べると読み取り易い気がします。
C言語でプログラムを書いていただいた方には後ほど質問をしておきます。
話は変わりますが・・・
この場を借りて日頃疑問に感じていることを解析してほしいんですが実は自分はカードマジックが大好きでそれに関連した本を読んでいて出会った記述でして、次のような事が起きます。
ぜひ、トランプで確認を！
ハートとスペードを順にA、２、３・・・Qと重ねる。
ハートパケットはテーブルに裏向き（Aが上）で置く。
観客に1〜１２までの好きな数字を決め手もらう。
スペードパケットを手に裏向き（Aが上）に持ち、上から表向きにしながらテーブルへ左、右、左、・・・と２つの山を作りながらカードを重ねていく。
客が決めた数字の枚数目の時、このカードはテーブルの別の場所に捨てられた札として、表向きのまま除く。その代わりとして、ハートパケットの一番上のカードをこのカードの置くべきだった山へ表向きにのせる。後続けていき手持ちのカードが無くなるまで進む。
左の山を持ち上げ、右の山へ重ね、一つになったパケットを手にとり、裏向きで持つ。
同じことをくり返し、最終的に手にはハート、捨て場にはスペードが集まる。
この二つの山をテーブルに並べて置く。
観客にハートまたはスペードから好きなカード（A〜Qまでの中から）の名前を言ってもらう。（例ハートの８を観客が選んだとして説明します。）
客がハートを選択したのなら、まずスペードの山から、上より８枚目のカードを引き出す。
（もし客がスペードの選択をしたのならハートの山からカードを引き出すことになる。）
引き出したカードの数字に従い、今度はハートパケットの上からその数字の枚数目のカードを表向きにする。
ここから客が指定しておいたハートの８が出現する。
＜わかり難いでしょうか？＞
この客に任意で選択させている事（１〜１２を選ばせたり、好きなカードを指定させたり）をやっておきながら、的確に客のカードを当ててしまう仕組みはとっても数学的に巧く計算されていると思われます。
１２という数字が何かキーになる性質を有しているからだろうと予感されます。
このことをプログラムで解明して欲しいんですが・・・ 		 

Re: カードマジックで出会った現象

 投稿者：山中和義  投稿日：2008年11月 5日(水)16時23分20秒 		返信・引用 　編集済
  > No.48[元記事へ]

GAIさんへのお返事です。

たぶんこれで大丈夫でしょう。
剰余（mod）が関係しているのでしょうか？（一種のシャッフルですから）


LET mk$="SCHD" !マーク

SUB dec(C(),p, w) !パケット内上からp位置のカードを削除する
   LET w=C(p)
   FOR i=p TO C(0)-1 !前に詰める
      LET C(i)=C(i+1)
   NEXT i
   LET C(0)=C(0)-1
END SUB
SUB inc(C(),p,w) !パケット内上からp位置にカードを追加する
   IF p<=C(0) THEN
      FOR i=C(0) TO p STEP -1 !後ろにずらす
         LET C(i+1)=C(i)
      NEXT i
   ELSE
      LET p=C(0)+1 !最後
   END IF
   LET C(p)=w
   LET C(0)=C(0)+1
END SUB
DIM TT(0 TO 13*4+1)
SUB add(C1(),C2(), C()) !C1を上、C2を下にパケットを重ねる
   FOR i=1 TO C1(0)
      LET TT(i)=C1(i)
   NEXT i
   FOR i=1 TO C2(0) !続けて
      LET TT(C1(0)+i)=C2(i)
   NEXT i
   LET C(0)=C1(0)+C2(0)
   FOR i=1 TO C(0)
      LET C(i)=TT(i)
   NEXT i
END SUB
SUB clr(C()) !パケットをクリアする
   LET C(0)=0
END SUB
SUB rev(C()) !パケットを裏返す
   FOR i=1 TO INT(C(0)/2)
      swap C(i),C(C(0)-i+1)
   NEXT i
END SUB
SUB disp(C(),m$) !パケットを上から順に表示する
   PRINT m$;"(";C(0);"枚)";
   FOR i=1 TO C(0)
      PRINT C(i);
   NEXT i
   PRINT
END SUB
!-------------------- ここまでがサブルーチン


LET N=12 !枚数

DIM S(0 TO N),H(0 TO N) !スペード、ハートパケットの初期化
FOR i=1 TO N !整列
   LET S(i)=i !スペード 1〜13
   LET H(i)=i+13*2 !ハート 27〜39
NEXT i
LET H(0)=N !枚数
LET S(0)=N

!テーブルの初期化
DIM Y1(0 TO N),Y2(0 TO N),Y3(0 TO N) !山１、山２、捨て場
CALL clr(Y1) !山のクリア
CALL clr(Y2)
CALL clr(Y3)

CALL dump !内容を確認する

SUB dump
   CALL disp(S,"スペード") !トレース
   CALL disp(H,"ハート")
   CALL disp(Y1,"山１")
   CALL disp(Y2,"山２")
   CALL disp(Y3,"捨て場")
   PRINT
END SUB


!１回目
INPUT PROMPT "好きな数字(2〜N)？": K !好きな数字 1〜N

CALL routine

SUB routine !作業の定義
   FOR x=1 TO N !手持ちのカードがなくなるまで
      PRINT x;"枚目をテーブルへ"
      CALL dec(S,1,w) !削除する
      IF x=K THEN !一致する枚数目なら捨て場へ
      !IF MOD(x,K)=0 THEN !一致する枚数目なら捨て場へ
         CALL inc(Y3,1,w)
         CALL dec(H,1,w) !代替として場から
      END IF

      IF MOD(x,2)=0 THEN !左右交互で山に置く
         CALL inc(Y2,1,w)
      ELSE
         CALL inc(Y1,1,w)
      END IF

      CALL dump !内容を確認する
   NEXT x
   PRINT
END SUB




!２回目以降
DO
   CALL add(Y1,Y2, S) !山を重ねて手に持つ
   CALL rev(S)
   CALL disp(S,"スペード")
   PRINT

   IF H(0)=0 THEN EXIT DO !ハートパケットがなくなるまで

   CALL clr(Y1) !山のクリア
   CALL clr(Y2)

   CALL routine
LOOP


MAT H=Y3
CALL rev(H)
CALL disp(H,"ハート")


INPUT PROMPT "カードのマーク？": c$
INPUT PROMPT "数字(1〜N)？": K

IF UCASE$(c$)="H" THEN
   LET w=H(K) !スペードの列になっている
   LET w=S(w)
ELSE
   LET w=MOD(S(K),13) !ハートの列になっている
   LET w=H(w)
END IF
PRINT mid$(mk$,INT(w/13)+1,1); MOD(w,13)


END 		 

Re: カードマジックで出会った現象

 投稿者：SECOND  投稿日：2008年11月 5日(水)17時59分39秒 		返信・引用
  > No.48[元記事へ]

!トランプ は、どの数を選んでも、
!互いに インデックスに　なってしまうようです。難解。

DIM s(12),h(12),w(12),t(12)

PRINT "----- 最初の状態 -----"
CALL ready
CALL printa(s) !　スペード
CALL printa(h) !　ハート
PRINT
!
FOR R=1 TO 12
   PRINT "----- Request";R;"の場合-----"
   CALL ready
   LET k=1
   DO WHILE k< 13
      FOR i=1 TO 12
         LET j=MOD(i,2)*7+INT(i/2) !　分けた２つを重ねた時の位置。
         IF i=R THEN
            LET t(j)=h(k) !　ハートをテーブルへ
            LET w(k)=s(i) !　手元(最初スペード)を「捨て」へ
            LET k=k+1
         ELSE
            LET t(j)=s(i) !　手元(最初スペード)をテーブルへ
         END IF
      NEXT i
      MAT s=t !　テーブルを手元(最初スペード)へ
   LOOP
   CALL printa(s) !　比較・・・手元(最初スペード)
   CALL printa(w) !　比較・・・「捨て」の重なり
   PRINT
NEXT R

SUB printa(a())
   FOR n=1 TO 12
      PRINT USING "## ":a(n);
   NEXT n
   PRINT "　…互いに Index."
END SUB

SUB ready
   FOR i=1 TO 12
      LET s(i)=i
      LET h(i)=i
   NEXT i
END SUB

END 		 

Re: カードマジックで出会った現象

 投稿者：山中和義  投稿日：2008年11月 5日(水)21時53分27秒 		返信・引用
  > No.49[元記事へ]

リフルシャッフルの性質を利用していると思います。

プログラムを実行して表示されるＫは、
「手持ちのカードを左右の山に分けて、左右と重ね１つの山にする」の操作に該当します。
一番上の索引番号が最初に聞いた好きな番号です。どの列でも構いませんが、
その列を上から順に見ていくと、捨て場に積まれる（スペードの）カードの順になります。

ところで置き換えたハートのカードは、この番号位置に置き換わりますが、
最終的に、12回の操作でスペードのカードに対応した位置に整列されることになります。

これで参照位置とその配置位置をうまく絡ませることができます。

ちょうどN回目でもとに戻る場合、たとえばN=2,4,10,12がこの問題を満たすと思います。



!置換（Permutation）の計算

!補助ルーチン
SUB PermPrintOut(A()) !表示する　※標準形（２行ｎ列の行列表記する）
!PRINT "┌";
!FOR i=1 TO UBOUND(A)
!   PRINT USING "###": i;
!NEXT i
!PRINT " ┐"
!PRINT "└";
   FOR i=1 TO UBOUND(A)
      PRINT USING "###": A(i);
   NEXT i
   !PRINT " ┘";
   PRINT
END SUB

!置換
SUB PermIdentity(A()) !恒等置換
   FOR i=1 TO UBOUND(A)
      LET  A(i)=i
   NEXT i
END SUB
SUB PermMultiply(A(),B(), AB()) !積AB　※AB≠BA、A(BC)=(AB)C
   LET  ua=UBOUND(A)
   LET  ub=UBOUND(B)
   IF ua=ub THEN
      FOR i=1 TO ua
         LET  AB(i)=A(B(i)) !※合成写像(AB)(i)=A(B(i))
      NEXT i
   ELSE
      PRINT "次元が違います。A=";ua;" B=";ub
      STOP
   END IF
END SUB
!-------------------- ここまでがサブルーチン


!main

LET N=12 !※2,4,10,12

!A=┌ 1 2 3 4 ┐=(1 2 4 3)　※１行目の順番は固定とする
!　└ 2 4 1 3 ┘
DATA 2,4,6,8,10,12,1,3,5,7,9,11 !配列変数の「添え字と値」に対応させる
!DATA 2,4,6,8,10,1,3,5,7,9 !N=10
!DATA 2,4,1,3 !N=4
!DATA 2,1 !N=2
DIM A(N)
MAT READ A

FOR i=1 TO N
   PRINT USING "###": i;
NEXT i
PRINT

DIM B(N)
CALL PermIdentity(B) !初期値

DIM c(N)
FOR k=1 TO N !回数
   CALL PermMultiply(B,A,c) !シャッフル
   PRINT "K=";k
   CALL PermPrintOut(c) !何回か実行すると元に戻る
   MAT B=c
NEXT k


END 		 

Re: プログラムのお願い

 投稿者：GAI  投稿日：2008年11月 5日(水)22時07分8秒 		返信・引用
  > No.46[元記事へ]

山中和義さんへのお返事です。

> Ｃ言語版のコードをみて思ったのですが
>
> ・N=1が求まらない
> ・順列の生成がおかしい（行や列の交換が不十分）
> 　→標準形からすべて展開されていない
> 　→exitの箇所をコメント（無効）にしても全解が得られない
> 　→N=6で検証していない箇所がある
> の疑問があります。


このことを製作者の方にお尋ねしましたところ、次のようなメールを頂きました。

・N=1が求まらない

  N=1に対処するとプログラムが面倒になるだけですので
無視しています（手間をかけてN=1にわざわざ対処しても、
まったく無意味ですよね？）。

> ・順列の生成がおかしい（行や列の交換が不十分）
> 　→標準形からすべて展開されていない
> 　→exitの箇所をコメント（無効）にしても全解が得られない
> 　→N=6で検証していない箇所がある

  おかしくないはずです。
  すべてを検証すると非常に長い時間がかかりますので、
数学的に考えて検証が必要ないものは省いています。
（省かないと、現実的な時間で求まりません。）

との回答でした。連絡まで 		 

Re: プログラムのお願い

 投稿者：山中和義  投稿日：2008年11月 6日(木)07時10分30秒 		返信・引用
  > No.52[元記事へ]

GAIさんへのお返事です。

お手数おかけしました。ありがとうございます。 		 

カードマジックの続き

 投稿者：GAI  投稿日：2008年11月 6日(木)10時47分33秒 		返信・引用
  ということは、１２枚ずつ計２４枚のカードでなくても、
２，４，１０，１２，１８，３６，５２，５８，６０，６６，８２，１００，・・・
枚ずつの場合でも同様な現象が起こせるということなんでしょうか？

この手品には続きがありまして、一度この現象を見せても客はたまたま当たったとしか感じてくれないので、次のようにさらにカードを混ぜたように見せていく。
まず、一方のパケット（例としてハートの方を選ぶ）にK（１３）カードを一枚をボトムに
付け加える。（パケットは裏向き状態）
これを数回カット（任意の場所から分け、上、下の位置関係を逆にする。）した後、
客に２〜１２の中から好きな数字を言ってもらう。（例：９を言ったとして以下説明）
パケットを表向きにして上から一枚ずつテーブルへ９つの山を作っていく。(左から右へ)
残りのカードは始めの山に戻り、２枚目として重ねていく。（左より４つ目の山で終る）
この最後に置いたカードが一番右の山から数えて何番目の場所で終わったのかを密かに覚える。
（９の場合は右回りにカウントすると４番目、左回りにカウントすると５番目ということになる。）
左か右回りは関係せず、少ない方の数をキー数字（９なら４となる。）とする。
ここで、客に９つの山の一つを任意に選ばせる。
演者はこの山から取り上げ、右へ（右回りにカウントして得た数字だから）４ずつ進んで
行った山の上に重ねる。
同じく重なった山を持ち上げ、次の４右へ進んだ山の上に重ねる。（一番右まできたら、一番左の山へ進んでカウントする。）
これを続けていく。（ただし重ねる山は、最初に置いていた山の位置でカウントすること。　従ってもうカードを取り去った位置もカウントの対象になる。）
＜客からはカードの集め方がランダムに集めているように感じる。＞
一つにまとまったパケット（表向き）を数回カットするが、最後のカットでK（１３）カードがボトムに（表向きなら一番上）なるように、調節し裏向きでテーブルに置く。
このとき、一番下（裏向きの状態なら一番上）にくるカードを盗み見して（数字）覚えておく。
次にスペードのパケット（こちらは１２枚）を取り上げ、エースカードが盗み見をした数に上から数えての枚数目になるように、位置を調節して一度カットをする。
裏向き状態でテーブルに置く。（これで、全てのカード位置と指示位置が対応している）

この作業は気が済むまで、くり返して行ってよい。
（だれでもハートのカードはがっかりするくらいよく混ぜられたと感じるだろう。）

再び、客のリクエストに相当するカードを探しだすことができる。
（またまた、分かり難いでしょうか？） 		 

Re: カードマジックの続き

 投稿者：山中和義  投稿日：2008年11月 7日(金)07時31分4秒 		返信・引用
  > No.54[元記事へ]

GAIさんへのお返事です。

>２，４，１０，１２，１８，３６，５２，５８，６０，６６，８２，１００，・・・

たぶんＯＫだと思います。


>続きのマジックについて

プログラムミスと思いますが、一致するときと一致しないときがあります。
後でプログラムを掲載します。（長編です）


>続きのマジックのテーブルでのハートパケットのシャッフルについて

シャッフルによって元の数字がどこに移動するか確認してみました。
１回目（作る山の数）の好きな数字によって、次のプログラムで表示される表の数字列（横にみる）のいずれかになるようです。
２回目（山の選択）は、１３を底に移動させる調整カットで無効になります。

1  2  3  4  5  6  7  8  9 10 11 12 13
2  4  6  8 10 12  1  3  5  7  9 11 13
3  6  9 12  2  5  8 11  1  4  7 10 13
4  8 12  3  7 11  2  6 10  1  5  9 13
5 10  2  7 12  4  9  1  6 11  3  8 13
6 12  5 11  4 10  3  9  2  8  1  7 13
7  1  8  2  9  3 10  4 11  5 12  6 13
8  3 11  6  1  9  4 12  7  2 10  5 13
9  5  1 10  6  2 11  7  3 12  8  4 13
10  7  4  1 11  8  5  2 12  9  6  3 13
11  9  7  5  3  1 12 10  8  6  4  2 13
12 11 10  9  8  7  6  5  4  3  2  1 13

たとえば、好きな数字に３を指定すると13-3=１０番目になります。
10  7  4  1 11  8  5  2 12  9  6  3 13　… (1)


これがスペードパケットの調整カットとの関係が見えません。（調査中）
１列目の数字（10）か、１の位置（4番目）か、何か、、、



●プログラム

!１３以外の数Ｎに、自分自身Ｎを加えて新しい数を作る。
!その数が１３より大きいときは、１３を引く。
DIM A(13),B(13)
FOR k=1 TO 12
   LET A(k)=k
   LET B(k)=0
NEXT k
FOR i=1 TO 12
   FOR k=1 TO 12
      LET B(k)=MOD(B(k)+A(k),13)
   NEXT k
   LET B(13)=13
   MAT PRINT B;
NEXT i
END 		 

Re: カードマジックの続き

 投稿者：GAI  投稿日：2008年11月 7日(金)09時24分8秒 		返信・引用
  > No.55[元記事へ]

山中和義さんへのお返事です。

> プログラムミスと思いますが、一致するときと一致しないときがあります。

続いて手品を行うということは、最初のマジックを終了したもののパケットをそのまま
の順序で利用するということになります。
（関係ないですかね？）
なお、客が指定する山の数に対応してカードを集める向きとずらし数は
２：右へ１
３：右へ１
４：右へ１
５：左へ２
６：右へ１
７：左へ１
８：左へ３
９：右へ４
１０：右へ３
１１：右へ２
１２：右へ１
となります。
（まさにこれは、１３が素数であることを上手に利用した方法ですね。） 		 

Re: カードマジックの続き

 投稿者：山中和義  投稿日：2008年11月 7日(金)09時25分35秒 		返信・引用 　編集済
  > No.55[元記事へ]

GAIさんへのお返事です。

動作不良です。間違った操作を指摘してください。
1000 !トランプのマジック
1010
1020 !パケット操作のシミュレーション
1030
1040 SUB dec(C(),p, w) !上からp位置のカードを削除する　※1≦p
1050    LET w=C(p)
1060    FOR i=p TO C(0)-1 !前に詰める
1070       LET C(i)=C(i+1)
1080    NEXT i
1090    LET C(0)=C(0)-1 !枚数
1100 END SUB
1110 SUB inc(C(),p,w) !上からp位置にカードを追加する
1120    IF p<=C(0) THEN
1130       FOR i=C(0) TO p STEP -1 !後ろにずらす
1140          LET C(i+1)=C(i)
1150       NEXT i
1160    ELSE
1170       LET p=C(0)+1 !最後へ
1180    END IF
1190    LET C(p)=w
1200    LET C(0)=C(0)+1 !枚数
1210 END SUB
1220 DIM TT(0 TO 13*4+1) !作業用　※１デッキ分
1230 SUB add(C1(),C2(), C()) !C1を上、C2を下に重ねる
1240    FOR i=1 TO C1(0) !C1
1250       LET TT(i)=C1(i)
1260    NEXT i
1270    FOR i=1 TO C2(0) !続けてC2
1280       LET TT(C1(0)+i)=C2(i)
1290    NEXT i
1300    LET TT(0)=C1(0)+C2(0) !枚数
1310    CALL copy(TT,TT(0), C)
1320 END SUB
1330 SUB clr(C()) !空にする
1340    LET C(0)=0
1350 END SUB
1360 SUB rev(C()) !裏返す
1370    FOR i=1 TO INT(C(0)/2)
1380       swap C(i),C(C(0)-i+1) !上下を入れ替える
1390    NEXT i
1400 END SUB
1410 SUB del(C(),p,q) !p位置からq位置までのカードを削除する　※1≦p≦q
1420    IF p>C(0) THEN
1430       PRINT "無効です。";p;q
1440    ELSE
1450       IF p>q THEN
1460          PRINT "p>qで無効です。";p;q
1470       ELSE
1480          LET q=MIN(q,C(0))
1490          FOR i=q+1 TO C(0) !残りを繋げる
1500             LET C(p+i-q-1)=C(i)
1510          NEXT i
1520          LET C(0)=C(0)-(q-p+1) !枚数
1530       END IF
1540    END IF
1550 END SUB
1560 SUB shuffle(C()) !リフルシャッフルを行う　※後半、前半の順に重ねる
1570    FOR i=1 TO C(0)
1580       LET TT(i)=C(INT(i/2)+MOD(i,2)*(INT(C(0)/2)+1))
1590       !LET TT(i)=C(INT((i-1)/2)+MOD(i-1,2)*INT(C(0)/2)+1) !※前半、後半の順
1600    NEXT i
1610    LET TT(0)=C(0) !枚数
1620    CALL copy(TT,TT(0), C)
1630 END SUB
1640 SUB cut(C(),p) !カットする　※p位置以降が上になる
1650    LET p=MIN(p,C(0))
1660    FOR i=1 TO p-1 !前半部分を後へ
1670       LET TT(C(0)+i-p+1)=C(i)
1680    NEXT i
1690    FOR i=p TO C(0) !後半部分を前へ
1700       LET TT(i-p+1)=C(i)
1710    NEXT i
1720    LET TT(0)=C(0) !枚数
1730    CALL copy(TT,TT(0), C)
1740 END SUB
1750 SUB copy(C1(),p, C()) !上からp位置までをコピーする
1760    LET p=MIN(p,C1(0))
1770    FOR i=1 TO p !copy it
1780       LET C(i)=C1(i)
1790    NEXT i
1800    LET C(0)=p !枚数
1810 END SUB
1820 SUB move(C1(),p, C()) !上からp位置までを移動する
1830    CALL copy(C1,p,C)
1840    CALL del(C1,1,p)
1850 END SUB
1860 SUB disp(C(),m$) !上から順に表示する
1870    PRINT m$;"(";C(0);"枚)";
1880    FOR i=1 TO C(0)
1890       PRINT C(i);
1900    NEXT i
1910    PRINT
1920 END SUB
1930
1940
1950 DEF MarkOfCard$(w)=mid$(mk$,INT(w/13)+1,1) !カードを表示する
1960 DEF NumOfCard(w)=MOD(w,13)
1970 DEF CntOfPacket(C())=C(0) !パケット内のカードの枚数
1980
1990 LET mk$="SCHD" !マーク
2000 LET nm$=" A 1 2 3 4 5 6 7 8 910 J Q K" !※２文字ずつ
2010
2020 !スペード、クラブ、ハート、ダイヤパケットを初期化する
2030 DIM cS(0 TO 13),cC(0 TO 13),cH(0 TO 13),cD(0 TO 13)
2040 FOR i=1 TO 13 !整列
2050    LET cS(i)=i !スペード 1〜13
2060    LET cC(i)=i+13 !クラブ 14〜16
2070    LET cH(i)=i+13*2 !ハート 27〜39
2080    LET cD(i)=i+13*3 !ダイヤ 40〜52
2090 NEXT i
2100 LET cS(0)=13 !枚数
2110 LET cC(0)=13
2120 LET cH(0)=13
2130 LET cD(0)=13
2140 !-------------------- ここまでがサブルーチン
2150
2160
2170 LET N=12 !枚数
2180
2190 DIM Y1(0 TO N+1),Y2(0 TO N+1),Y3(0 TO N+1),Y4(0 TO N+1) !山１〜12
2200 DIM Y5(0 TO N+1),Y6(0 TO N+1),Y7(0 TO N+1),Y8(0 TO N+1)
2210 DIM Y9(0 TO N+1),Y0(0 TO N+1),Yj(0 TO N+1),Yq(0 TO N+1)
2220
2230 DIM S(0 TO N+1),H(0 TO N+1) !スペード、ハートパケットの初期化
2240 CALL copy(cS,N, S)
2250 CALL copy(cH,N, H)
2260
2270 CALL dump !内容を確認する
2280 SUB dump
2290    CALL disp(S,"スペード") !トレース
2300    CALL disp(H,"ハート")
2310    CALL disp(Y1,"山１")
2320    CALL disp(Y2,"山２")
2330    CALL disp(Y3,"捨て場")
2340    PRINT
2350 END SUB
2360
2370
2380 !１回目
2390 INPUT PROMPT "好きな数字(1〜N)？": K !好きな数字 1〜N
2400
2410 CALL routine
2420 SUB routine !作業の定義
2430    FOR x=1 TO N !手持ちのカードがなくなるまで
2440    !!!PRINT x;"枚目をテーブルへ"
2450       CALL dec(S,1,w) !削除する
2460       IF x=K THEN !一致する枚数目なら捨て場へ
2470          CALL inc(Y3,1,w)
2480          CALL dec(H,1,w) !代替として場から
2490       END IF
2500
2510       IF MOD(x,2)=0 THEN !左右交互で山に置く
2520          CALL inc(Y2,1,w)
2530       ELSE
2540          CALL inc(Y1,1,w)
2550       END IF
2560
2570       !!!CALL dump !内容を確認する
2580    NEXT x
2590    !!!PRINT
2600 END SUB
2610
2620
2630 !２回〜Ｎ回まで
2640 DO
2650    CALL add(Y1,Y2, S) !山を重ねて手に持つ
2660    CALL rev(S)
2670
2680    CALL clr(Y1) !山のクリア
2690    CALL clr(Y2)
2700
2710    IF CntOfPacket(H)=0 THEN EXIT DO !テーブル上のハートパケットがなくなるまで
2720
2730    CALL routine
2740 LOOP
2750
2760
2770 CALL move(Y3,99, H) !最終の状態
2780 CALL rev(H)
2790
2800 PRINT
2810 CALL dump !内容を確認する
2820
2830
2840 CALL surprise
2850 SUB surprise
2860    INPUT PROMPT "カードのマーク(S,H)？": c$
2870    INPUT PROMPT "数字(1〜N)？": K
2880
2890    IF UCASE$(c$)="H" THEN
2900       LET w=H(K) !スペードの列になっている
2910       LET w=S(w)
2920    ELSE
2930       LET w=MOD(S(K),13) !ハートの列になっている
2940       LET w=H(w)
2950    END IF
2960    PRINT MarkOfCard$(w); NumOfCard(w) !カードを表示する
2970 END SUB
2980
2990 !---------- ↑↑↑↑↑ ---------- 前半のマジック
3000
3010
ここまでが前半のマジックです。（続く） 		 

Re: カードマジックの続き

 投稿者：山中和義  投稿日：2008年11月 7日(金)09時28分59秒 		返信・引用 　編集済
  > No.55[元記事へ]

GAIさんへのお返事です。

（続き）２回目のマジック部分　※N0.56記事を反映、行番号の付加 
3020
3030
3040
3050 !CALL copy(cS,12, S) !!!!!移動先の調査　<-----ここ
3060 !CALL copy(cS,12, H) !!!!!　<-----ここ
3070 PRINT
3080
3090 CALL inc(H,99, 13) !Ｋ（キング）を底に追加する
3100
3110
3120 PRINT "（ハートパケットを）数回カットする。"
3130 FOR x=1 TO 5
3140    CALL cut(H,INT(RND*(N+1))+1)
3150 NEXT x
3160
3170 CALL dump2 !内容を確認する
3180 SUB dump2
3190    CALL disp(S,"スペード") !トレース
3200    CALL disp(H,"ハート")
3210    CALL disp(Y1,"山１")
3220    CALL disp(Y2,"山２")
3230    CALL disp(Y3,"山３")
3240    CALL disp(Y4,"山４")
3250    CALL disp(Y5,"山５")
3260    CALL disp(Y6,"山６")
3270    CALL disp(Y7,"山７")
3280    CALL disp(Y8,"山８")
3290    CALL disp(Y9,"山９")
3300    CALL disp(Y0,"山10")
3310    CALL disp(Yj,"山11")
3320    CALL disp(Yq,"山12")
3330    PRINT
3340 END SUB
3350
3360
3370
3380 INPUT PROMPT "好きな数字（2〜12）": K
3390
3400 CALL routine2_1(H) !各山へ分配する
3410 SUB routine2_1(C())
3420    FOR x=1 TO N+1
3430       CALL dec(C,1,w) !１枚ずつ
3440       !SELECT CASE K-MOD(x-1,K) !それぞれの山へ
3450       SELECT CASE MOD(x-1,K)+1 !それぞれの山へ
3460       CASE 1
3470          CALL inc(Y1,1,w)
3480       CASE 2
3490          CALL inc(Y2,1,w)
3500       CASE 3
3510          CALL inc(Y3,1,w)
3520       CASE 4
3530          CALL inc(Y4,1,w)
3540       CASE 5
3550          CALL inc(Y5,1,w)
3560       CASE 6
3570          CALL inc(Y6,1,w)
3580       CASE 7
3590          CALL inc(Y7,1,w)
3600       CASE 8
3610          CALL inc(Y8,1,w)
3620       CASE 9
3630          CALL inc(Y9,1,w)
3640       CASE 10
3650          CALL inc(Y0,1,w)
3660       CASE 11
3670          CALL inc(Yj,1,w)
3680       CASE 12
3690          CALL inc(Yq,1,w)
3700       CASE ELSE
3710          PRINT "置く山がありません。"
3720          STOP
3730       END SELECT
3740    NEXT x
3750    CALL dump2 !内容を確認する
3760 END SUB
3770
3780
3790 PRINT "右から";MOD(N+1,K);"番目に最後のカードを置きました。"
3800 PRINT
3810
3820
3830
3840 INPUT PROMPT "好きな山を選ぶ（1〜K）": x
3850
3860 DIM dx(N)
3870 DATA 1,1,1,1,-2,1,-1,-3,4,3,2,1 !回収方法　※１なら右へ１、−２なら左へ２の意
3880 MAT READ dx
3890
3900 DIM yy(0 TO N+1)
3910 CALL routine2_2 !各山から回収する
3920 SUB routine2_2
3930    DO
3940       SELECT CASE MOD(x-1,K)+1
3950       CASE 1
3960          CALL move(Y1,99, yy)
3970       CASE 2
3980          CALL move(Y2,99, yy)
3990       CASE 3
4000          CALL move(Y3,99, yy)
4010       CASE 4
4020          CALL move(Y4,99, yy)
4030       CASE 5
4040          CALL move(Y5,99, yy)
4050       CASE 6
4060          CALL move(Y6,99, yy)
4070       CASE 7
4080          CALL move(Y7,99, yy)
4090       CASE 8
4100          CALL move(Y8,99, yy)
4110       CASE 9
4120          CALL move(Y9,99, yy)
4130       CASE 10
4140          CALL move(Y0,99, yy)
4150       CASE 11
4160          CALL move(Yj,99, yy)
4170       CASE 12
4180          CALL move(Yq,99, yy)
4190       CASE ELSE
4200          PRINT "置く山がありません。"
4210          STOP
4220       END SELECT
4230
4240       IF CntOfPacket(yy)=13 THEN EXIT SUB !１つにまとまるまで
4250
4260       PRINT "山";x;"から";
4270       CALL disp(yy,"回収したカード")
4280       LET x=x+dx(K) !右または左へ移動させて該当する山へ重ねる
4290       PRINT "山";x;"に重ねます。"
4300       SELECT CASE MOD(x-1,K)+1
4310       CASE 1
4320          CALL add(yy,Y1, Y1)
4330       CASE 2
4340          CALL add(yy,Y2, Y2)
4350       CASE 3
4360          CALL add(yy,Y3, Y3)
4370       CASE 4
4380          CALL add(yy,Y4, Y4)
4390       CASE 5
4400          CALL add(yy,Y5, Y5)
4410       CASE 6
4420          CALL add(yy,Y6, Y6)
4430       CASE 7
4440          CALL add(yy,Y7, Y7)
4450       CASE 8
4460          CALL add(yy,Y8, Y8)
4470       CASE 9
4480          CALL add(yy,Y9, Y9)
4490       CASE 10
4500          CALL add(yy,Y0, Y0)
4510       CASE 11
4520          CALL add(yy,Yj, Yj)
4530       CASE 12
4540          CALL add(yy,Yq, Yq)
4550       CASE ELSE
4560       END SELECT
4570
4580       CALL dump2 !内容を確認する
4590    LOOP
4600 END SUB
4610
4620
4630 PRINT "（回収したハートパケットを）数回カットする。"
4640 FOR x=1 TO 5 !数回カットする
4650    CALL cut(yy,INT(RND*(N+1))+1)
4660 NEXT x
4670 CALL disp(yy,"")
4680
4690
4700 PRINT "Ｋ（キング）を底へ移動させるために調整カットする。"
4710 FOR x=1 TO N !位置を探す
4720    IF MOD(yy(x),N+1)=0 THEN EXIT FOR
4730 NEXT x
4740 IF x=13 THEN !既に底の場合は何もしない
4750 ELSE
4760    CALL cut(yy,x+1) !差分をカットする
4770 END IF
4780 CALL disp(yy,"")
4790
4800
4810 CALL move(yy,99, H) !最終の状態
4820
4830 LET KEY2=MOD(H(1),N+1) !一番上の数字を記憶する
4840
4850 CALL dump2 !内容を確認する
4860
4870
4880
4890
4900 PRINT KEY2;"の位置に「１」のカードがくるように（スペードパケットを）カットする。"
4910 FOR x=1 TO N !位置を探す
4920    IF MOD(S(x),N+1)=1 THEN EXIT FOR
4930 NEXT x
4940 PRINT "現在の位置";x
4950 IF x>KEY2 THEN !差分をカットする
4960    CALL cut(S,x-KEY2+1)
4970 ELSEIF x<KEY2 THEN
4980    CALL cut(S,N-(KEY2-x)+1)
4990 END IF
5000
5010 CALL dump2 !内容を確認する
5020
5030
5040 CALL surprise
5050
5060 !---------- ↑↑↑↑↑ ----------　後半のマジック
5070
5080
5090 END
以上、長編力作？ 		 

感想

 投稿者：GAI  投稿日：2008年11月 7日(金)19時00分44秒 		返信・引用
  私はよくプログラムが作れないんですが、感覚としてずれを生じている箇所として
山を作らせる数字は２〜１２の範囲でしかないから、下記の辺りの調整か

”
INPUT PROMPT "好きな数字（2〜N:N<=12）": K
2450
2460 CALL routine2_1(H) !各山へ分配する
2470 SUB routine2_1(C())
2480    FOR x=1 TO N+1
2490       CALL dec(C,1,w) !１枚ずつ
2500       SELECT CASE MOD(x-1,K)+1 !それぞれの山へ
”
好きな山を選択するときは、１なら動きはないからDATA の最初は０？
あと2920行では　wlk(K)→wlk(x)?


2870 INPUT PROMPT "好きな山を選ぶ（1〜K:K<=N,ただし0は終了）": x
2880
2890 DIM wlk(N)
2900 DATA 1,1,1,1,-2,1,-1,-3,4,3,2,1 !回収方法　※１なら右へ１、−２なら左へ２の意
2910 MAT READ wlk
2920 LET KEY1=wlk(K) !終端位置を記憶する
2930
2940 DIM yy(0 TO N+1)
2950 CALL routine2_2 !各山から回収する

のような気がします。
でもどこがどう直すかはまったくわかりません。 		 

Re: 感想

 投稿者：山中和義  投稿日：2008年11月 7日(金)19時21分52秒 		返信・引用
  > No.59[元記事へ]

GAIさんへのお返事です。

２回目のマジック部分（No.58記事）の先頭箇所のコメントを削除して実行してください。
スペード、ハートとも、1,2,3,4,5,6,7,8,9,10,11,12でカードの動きがわかります。
これが実際の動きと同じでない箇所がプログラムミスとなります。

お手数ですが、確認してみてください。



!CALL copy(cS,12,S) !!!!!移動先の調査　<----- ここ
!CALL copy(cS,12,H) !!!!!　<----- ここ
PRINT

CALL inc(H,99, N+1) !Ｋ（キング）を底に追加する


PRINT "（ハートパケットを）数回カットする。"
FOR x=1 TO 5
   CALL cut(H,INT(RND*(N+1))+1)
NEXT x

（以下略） 		 

１８次のオイラー方陣

 投稿者：GAI  投稿日：2008年11月 7日(金)19時31分26秒 		返信・引用
              １８次のオイラー直交方陣

0X AB T9 W7 Z5 BT 8W 5C 2A Y8 X6 6Z 3Y 92 C3 11 40 74
BY 8X 56 T4 W2 Z0 6T 3W 07 A5 Y3 X1 1Z 4A 7B 99 C8 2C
9Z 6Y 3X 01 TC WA Z8 1T BW 82 50 YB X9 C5 26 44 73 A7
X4 4Z 1Y BX 89 T7 W5 Z3 9T 6W 3A 08 Y6 70 A1 CC 2B 52
Y1 XC CZ 9Y 6X 34 T2 W0 ZB 4T 1W B5 83 28 59 77 A6 0A
3B Y9 X7 7Z 4Y 1X BC TA W8 Z6 CT 9W 60 A3 04 22 51 85
18 B6 Y4 X2 2Z CY 9X 67 T5 W3 Z1 7T 4W 5B 8C AA 09 30
CW 93 61 YC XA AZ 7Y 4X 12 T0 WB Z9 2T 06 37 55 84 B8
AT 7W 4B 19 Y7 X5 5Z 2Y CX 9A T8 W6 Z4 81 B2 00 3C 63
ZC 5T 2W C6 94 Y2 X0 0Z AY 7X 45 T3 W1 39 6A 88 B7 1B
W9 Z7 0T AW 71 4C YA X8 8Z 5Y 2X C0 TB B4 15 33 62 96
T6 W4 Z2 8T 5W 29 C7 Y5 X3 3Z 0Y AX 78 6C 90 BB 1A 41
23 T1 WC ZA 3T 0W A4 72 Y0 XB BZ 8Y 5X 17 48 66 95 C9
80 38 B3 6B 16 91 49 C4 7C 27 A2 5A 05 XX YY ZZ WW TT
7A 25 A0 58 03 8B 36 B1 69 14 9C 47 C2 YT ZX WY TZ XW
57 02 8A 35 B0 68 13 9B 46 C1 79 24 AC ZW WT TX XY YZ
65 10 98 43 CB 76 21 A9 54 0C 87 32 BA WZ TW XT YX ZY
42 CA 75 20 A8 53 0B 86 31 B9 64 1C 97 TY XZ YW ZT WX

６次では構成不可能であるのに対し、１８次もの大きさでは
このようにできてしまうことに６の不思議さを感じます。
２次と６次だけは作れず、それ以外では可能であることが
さらに不思議です。 		 

Re: 感想

 投稿者：GAI  投稿日：2008年11月 7日(金)20時14分51秒 		返信・引用
  > No.60[元記事へ]

山中和義さんへのお返事です。

> ２回目のマジック部分（No.58記事）の先頭箇所のコメントを削除して実行してください。
> スペード、ハートとも、1,2,3,4,5,6,7,8,9,10,11,12でカードの動きがわかります。
> これが実際の動きと同じでない箇所がプログラムミスとなります。



スペード札とハート札が逆になった状態にあるような気がします。
ハートのK（１３）を付け加えるときに、なにかスペード札の方に加わっているように
感じます。
最初の札の交換のとき、元々手にしていたスペードパケットが、結果的にハートカード
の集まりに変化してしまうことが影響しているのでしょうか？ 		 

追加

 投稿者：GAI  投稿日：2008年11月 7日(金)20時37分36秒 		返信・引用
  > No.62[元記事へ]

ハートカードとして処理されているものをスペードに読み替えてカードの並びをみてみますと、最後 のKを加え山を構成して、集めて一つにしたパケットでKを一番下にコントロールしたカットの後の数の並びが、Kだけは１３番目で正しいですが、１〜１２番 目にあるカード位置がまったく逆で１番が１２番目、２番目が１１番目、３番が１０番目、・・・
となってしまっているようです。 		 

Re: 追加

 投稿者：山中和義  投稿日：2008年11月 7日(金)20時53分27秒 		返信・引用 　編集済
  > No.63[元記事へ]

GAIさんへのお返事です。

> スペード札とハート札が逆になった状態にあるような気がします。
> ハートのK（１３）を付け加えるときに、なにかスペード札の方に加わっているように
> 感じます。
> 最初の札の交換のとき、元々手にしていたスペードパケットが、結果的にハートカード

はい、そうです。
スペード、ハートパケットは論理的な名まえとして扱ってください。
（別にどちらそうだと言う必要はないはずです。互いに参照され合っていますから）
実際の操作は、カードでのマークで処理するのですね？
開始する前にSWAPされればいいだけですので、プログラムは直します。


> ハートカードとして処理されているものをスペードに読み替えてカードの並びをみてみますと、最後のKを加え山を構成して、集めて一つにしたパケットでKを 一番下にコントロールしたカットの後の数の並びが、Kだけは１３番目で正しいですが、１〜１２番目にあるカード位置がまったく逆で１番が１２番目、２番目 が１１番目、３番が１０番目、・・・
> となってしまっているようです。


具体的に「好きな数」「選択した山の番号」などを教えてください。
前出の「１３のテーブル」の数だけ並び替えが起こりますので、区別するために。

それが実際のカードでの動きと違いがありますか？ 		 

点検

 投稿者：GAI  投稿日：2008年11月 7日(金)22時18分20秒 		返信・引用
  最初の段階の客の選んだ数を５
後半での好きな数を３
としてカードが配られていく山の順序を見たら、１，２，３，１，２，３とカードを配らねばならぬところを、１，３，２，１，３，２・・・と配られていっているような様子です。
たぶんこの順序はカードを配り終わったとき、山を回収していく順序と思われます。 		 

追加

 投稿者：GAI  投稿日：2008年11月 7日(金)22時47分46秒 		返信・引用
  そして山になったカードを重ねるとき、山のカードをずらした位置の山の上に重ねるところが、山の下になって重なっていく順序に見えます。（画面でカードの数字の並びを左から順に見るとき、裏向きにして上になる順番として解釈して見ています。）  

Re: 点検

 投稿者：山中和義  投稿日：2008年11月 7日(金)22時53分41秒 		返信・引用 　編集済
  > No.65[元記事へ]

GAIさんへのお返事です。

> 最初の段階の客の選んだ数を５
> 後半での好きな数を３


コメントは無効して、今掲載しているプログラムで実行してみました。
　3050 CALL copy(cS,12, S) !!!!!移動先の調査　<-----ここ
　3060 CALL copy(cS,12, H) !!!!!　<-----ここ

トレースのどこか具体的に指摘してください。
スペード( 12 枚) 1  2  3  4  5  6  7  8  9  10  11  12
ハート( 12 枚) 27  28  29  30  31  32  33  34  35  36  37  38
山１( 0 枚)
山２( 0 枚)
捨て場( 0 枚)

好きな数字(1〜N)？5　<-----※

スペード( 12 枚) 30  31  34  32  27  35  29  33  38  28  37  36
ハート( 12 枚) 5  10  7  1  2  4  8  3  6  12  11  9
山１( 0 枚)
山２( 0 枚)
捨て場( 0 枚)

カードのマーク(S,H)？s　<-----※
数字(1〜N)？3　<-----※
S 3

（ハートパケットを）数回カットする。
スペード( 12 枚) 1  2  3  4  5  6  7  8  9  10  11  12
ハート( 13 枚) 8  9  10  11  12  13  1  2  3  4  5  6  7
山１( 0 枚)
山２( 0 枚)
山３( 0 枚)
山４( 0 枚)
山５( 0 枚)
山６( 0 枚)
山７( 0 枚)
山８( 0 枚)
山９( 0 枚)
山10( 0 枚)
山11( 0 枚)
山12( 0 枚)

好きな数字（2〜12）3　<-----※
スペード( 12 枚) 1  2  3  4  5  6  7  8  9  10  11  12
ハート( 0 枚)
山１( 5 枚) 7  4  1  11  8 　<-----※ここがおかしいのですか！？
山２( 4 枚) 5  2  12  9
山３( 4 枚) 6  3  13  10
山４( 0 枚)
山５( 0 枚)
山６( 0 枚)
山７( 0 枚)
山８( 0 枚)
山９( 0 枚)
山10( 0 枚)
山11( 0 枚)
山12( 0 枚)

右から 1 番目に最後のカードを置きました。

好きな山を選ぶ（1〜K）2
山 2 から回収したカード( 4 枚) 5  2  12  9
山 3 に重ねます。
スペード( 12 枚) 1  2  3  4  5  6  7  8  9  10  11  12
ハート( 0 枚)
山１( 5 枚) 7  4  1  11  8
山２( 0 枚)
山３( 8 枚) 5  2  12  9  6  3  13  10
山４( 0 枚)
山５( 0 枚)
山６( 0 枚)
山７( 0 枚)
山８( 0 枚)
山９( 0 枚)
山10( 0 枚)
山11( 0 枚)
山12( 0 枚)

山 3 から回収したカード( 8 枚) 5  2  12  9  6  3  13  10
山 4 に重ねます。
スペード( 12 枚) 1  2  3  4  5  6  7  8  9  10  11  12
ハート( 0 枚)
山１( 13 枚) 5  2  12  9  6  3  13  10  7  4  1  11  8
山２( 0 枚)
山３( 0 枚)
山４( 0 枚)
山５( 0 枚)
山６( 0 枚)
山７( 0 枚)
山８( 0 枚)
山９( 0 枚)
山10( 0 枚)
山11( 0 枚)
山12( 0 枚)

（回収したハートパケットを）数回カットする。
( 13 枚) 8  5  2  12  9  6  3  13  10  7  4  1  11
Ｋ（キング）を底へ移動させるために調整カットする。
( 13 枚) 10  7  4  1  11  8  5  2  12  9  6  3  13
スペード( 12 枚) 1  2  3  4  5  6  7  8  9  10  11  12
ハート( 13 枚) 10  7  4  1  11  8  5  2  12  9  6  3  13
山１( 0 枚)
山２( 0 枚)
山３( 0 枚)
山４( 0 枚)
山５( 0 枚)
山６( 0 枚)
山７( 0 枚)
山８( 0 枚)
山９( 0 枚)
山10( 0 枚)
山11( 0 枚)
山12( 0 枚)

 10 の位置に「１」のカードがくるように（スペードパケットを）カットする。
現在の位置 1
スペード( 12 枚) 4  5  6  7  8  9  10  11  12  1  2  3
ハート( 13 枚) 10  7  4  1  11  8  5  2  12  9  6  3  13
山１( 0 枚)
山２( 0 枚)
山３( 0 枚)
山４( 0 枚)
山５( 0 枚)
山６( 0 枚)
山７( 0 枚)
山８( 0 枚)
山９( 0 枚)
山10( 0 枚)
山11( 0 枚)
山12( 0 枚)

カードのマーク(S,H)？s
数字(1〜N)？5
S 2
 

新発見

 投稿者：GAI  投稿日：2008年11月 7日(金)23時35分17秒 		返信・引用
  最初の段階の客の数字を５として、ハートとスペードのパケットの構成をしてみると
ハート：４,５,８,６,１，９，３，７，１２，２，１１，１０
スペード：５,１０,７,１,２，４，８，３，６，１２，１１，９
となります。（数字は左より裏向きで重ねたとき上からの順番です。）
ここで面白いことに気がつきました。
ハートのボトムにKを追加して、適当に数回カット後
客の数字を３として、３つの山に配り（パケットは表向きに持って配ることになる）
指定する山を２として、回収して、最後のカットでKをボトムに配置すると
ハート：２,３,６,４,１１，７，１，５，１０，１２，９，８，１３
Aの調整でスペードパケットのカット（Aを２枚目に持って来る）後は
スペード：７,１,２,４,８，３，６，１２，１１，９，５，１０
の配列をなして、お互いインデックスが対応する。
しかし、
スペードの配列の最後にKを加え、同じ様に数度のカット後
３つの山をつくり、２の山から回収を始め一つにまとめ、Kをボトムでカットすると
スペード：１２,８,１,５,１１，３，２，１０，９，６，４，７，１３
これに合わせてハートパケットをAが１２枚目になるようにカットしてやると
ハート：９,３,７,１２，２，１１，１０，４，５，８，６，１
でこれはインデックスにはなんの関係も保存されていません。（不思議！！！）

すなわち、相互同値に見えて実はまったく異なる構造であることになります。
追加すべきはハートのKであり、このことが混乱している原因と思います。 		 

Re: 点検

 投稿者：GAI  投稿日：2008年11月 8日(土)00時14分26秒 		返信・引用
  > No.67[元記事へ]

山中和義さんへのお返事です。

> GAIさんへのお返事です。
>
> > 最初の段階の客の選んだ数を５
> > 後半での好きな数を３
>
>
> コメントは無効して、今掲載しているプログラムで実行してみました。
> 　3050 CALL copy(cS,12, S) !!!!!移動先の調査　<-----ここ
> 　3060 CALL copy(cS,12, H) !!!!!　<-----ここ
>
> トレースのどこか具体的に指摘してください。
>
> <PRE>
> スペード( 12 枚) 1  2  3  4  5  6  7  8  9  10  11  12
> ハート( 12 枚) 27  28  29  30  31  32  33  34  35  36  37  38
> 山１( 0 枚)
> 山２( 0 枚)
> 捨て場( 0 枚)
>
> 好きな数字(1〜N)？5　<-----※
>
> スペード( 12 枚) 30  31  34  32  27  35  29  33  38  28  37  36
> ハート( 12 枚) 5  10  7  1  2  4  8  3  6  12  11  9
> 山１( 0 枚)
> 山２( 0 枚)　　　　　　　　　　　　　　＊ハートパケットの数字の並び
> 捨て場( 0 枚)　　　　　　　　　        　4,5,8,6,1,9,3,7,12,2,11,10
>                                       ここではスペードの30,31,34,・・でトレース
> カードのマーク(S,H)？s　<-----※　　　　＊スペードパケットの数字の並び
> 数字(1〜N)？3　<-----※　　　　　　　　　5,10,7,1,2,4,8,3,6,12,11,9
> S 3                                 ここではハートの列としてトレースされている
>
> （ハートパケットを）数回カットする。
> スペード( 12 枚) 1  2  3  4  5  6  7  8  9  10  11  12
> ハート( 13 枚) 8  9  10  11  12  13  1  2  3  4  5  6  7
> 山１( 0 枚)　　　　　　　　　　＊ここはカードが1,2,3,・・と順序よくなっていま
> 山２( 0 枚)　　　　　　　　　　　すが、さきのカードの順番で続きをやることに
> 山３( 0 枚)　　　　　　　　　　　なります。
> 山４( 0 枚)
> 山５( 0 枚)
> 山６( 0 枚)
> 山７( 0 枚)
> 山８( 0 枚)
> 山９( 0 枚)
> 山10( 0 枚)
> 山11( 0 枚)
> 山12( 0 枚)
>
> 好きな数字（2〜12）3　<-----※
> スペード( 12 枚) 1  2  3  4  5  6  7  8  9  10  11  12
> ハート( 0 枚)
> 山１( 5 枚) 7  4  1  11  8 　<-----※ここがおかしいのですか！？
> 山２( 4 枚) 5  2  12  9　　　　　表向きで配りますから、山１，２，３には
> 山３( 4 枚) 6  3  13  10　　　　　7,6,5,・・・とカードが入ると思います。
> 山４( 0 枚)
> 山５( 0 枚)
> 山６( 0 枚)
> 山７( 0 枚)
> 山８( 0 枚)
> 山９( 0 枚)
> 山10( 0 枚)
> 山11( 0 枚)
> 山12( 0 枚)
>
> 右から 1 番目に最後のカードを置きました。
>
> 好きな山を選ぶ（1〜K）2
> 山 2 から回収したカード( 4 枚) 5  2  12  9
> 山 3 に重ねます。
> スペード( 12 枚) 1  2  3  4  5  6  7  8  9  10  11  12
> ハート( 0 枚)
> 山１( 5 枚) 7  4  1  11  8
> 山２( 0 枚)
> 山３( 8 枚) 5  2  12  9  6  3  13  10　　　＊山を上に重ねますからここは
> 山４( 0 枚)　　　　　　　　　　　　　　　　6,3,13,10,5,2,12,9
> 山５( 0 枚)                                 の順序になると思います。
> 山６( 0 枚)
> 山７( 0 枚)
> 山８( 0 枚)
> 山９( 0 枚)
> 山10( 0 枚)
> 山11( 0 枚)
> 山12( 0 枚)
>
> 山 3 から回収したカード( 8 枚) 5  2  12  9  6  3  13  10
> 山 4 に重ねます。
> スペード( 12 枚) 1  2  3  4  5  6  7  8  9  10  11  12
> ハート( 0 枚)
> 山１( 13 枚) 5  2  12  9  6  3  13  10  7  4  1  11  8 　＊同様にここもそうです
> 山２( 0 枚)
> 山３( 0 枚)
> 山４( 0 枚)
> 山５( 0 枚)
> 山６( 0 枚)
> 山７( 0 枚)
> 山８( 0 枚)
> 山９( 0 枚)
> 山10( 0 枚)
> 山11( 0 枚)
> 山12( 0 枚)
>
> （回収したハートパケットを）数回カットする。
> ( 13 枚) 8  5  2  12  9  6  3  13  10  7  4  1  11
> Ｋ（キング）を底へ移動させるために調整カットする。
> ( 13 枚) 10  7  4  1  11  8  5  2  12  9  6  3  13
> スペード( 12 枚) 1  2  3  4  5  6  7  8  9  10  11  12
> ハート( 13 枚) 10  7  4  1  11  8  5  2  12  9  6  3  13
> 山１( 0 枚)
> 山２( 0 枚)
> 山３( 0 枚)
> 山４( 0 枚)
> 山５( 0 枚)
> 山６( 0 枚)
> 山７( 0 枚)
> 山８( 0 枚)
> 山９( 0 枚)
> 山10( 0 枚)
> 山11( 0 枚)
> 山12( 0 枚)
>
>  10 の位置に「１」のカードがくるように（スペードパケットを）カットする。
> 現在の位置 1
> スペード( 12 枚) 4  5  6  7  8  9  10  11  12  1  2  3
> ハート( 13 枚) 10  7  4  1  11  8  5  2  12  9  6  3  13
> 山１( 0 枚)
> 山２( 0 枚)
> 山３( 0 枚)
> 山４( 0 枚)
> 山５( 0 枚)
> 山６( 0 枚)
> 山７( 0 枚)
> 山８( 0 枚)
> 山９( 0 枚)
> 山10( 0 枚)
> 山11( 0 枚)
> 山12( 0 枚)
>
> カードのマーク(S,H)？s
> 数字(1〜N)？5
> S 2
> </PRE> 		 

Re: 点検

 投稿者：山中和義  投稿日：2008年11月 8日(土)08時04分0秒 		返信・引用
  > No.69[元記事へ]

GAIさんへのお返事です。

お手数おかけしました。ありがとうございます。 		 

Re: 新発見

 投稿者：山中和義  投稿日：2008年11月 8日(土)11時49分44秒 		返信・引用 　編集済
  > No.68[元記事へ]

GAIさんへのお返事です。

ハートのＫ（キング）によるシャッフルをすべて調べて見ました。
すべて関係性は保たれるようです。

結果から「１３でのシャッフル」と「そのカット」（そう呼ぶことにします）の関係性は
確認できますが、数理的にはうまく説明できません。（合同式かな？）

またスペードの方も確認はできます。

!置換（Permutation）の計算
!※技術メモ
!　A=┌ 1 2 3 4 ┐=(1 2 4 3)　※１行目の順番は固定とする
!　　└ 2 4 1 3 ┘
!の場合、
!　DATA 2,4,1,3 !配列変数の「添え字と値」に対応させる
!　MAT READ A
!とプログラムでは記述する。

SUB PermPrintOut(A()) !表示する　※標準形（２行ｎ列の行列表記する）
   MAT PRINT USING(REPEAT$(" ##",UBOUND(A))): A;
   PRINT
END SUB
SUB PermIdentity(A()) !恒等置換
   FOR i=1 TO UBOUND(A)
      LET  A(i)=i
   NEXT i
END SUB
SUB PermInverse(A(), iA()) !逆置換　※iAはA以外の配列を指定すること
   FOR i=1 TO UBOUND(A)
      LET  iA(A(i))=i
   NEXT i
END SUB
SUB PermMultiply(A(),B(), AB()) !積AB　※ABはAかつB以外の配列を指定すること
   LET  ua=UBOUND(A)
   LET  ub=UBOUND(B)
   IF ua=ub THEN
      FOR i=1 TO ua
         LET  AB(i)=A(B(i)) !※合成写像(AB)(i)=A(B(i))
      NEXT i
   ELSE
      PRINT "次元が違います。A=";ua;" B=";ub
      STOP
   END IF
END SUB

SUB PermReverse(A()) !並び順を反転させる
   LET  ua=UBOUND(A)
   FOR i=1 TO INT(ua/2)
      swap A(i),A(ua-i+1)
   NEXT i
END SUB
!-------------------- ここまでがサブルーチン



!main

LET N=12 !※固定

DIM cc(N)
SUB check(SS(),HH()) !参照を確認する　※共に連番で表示されればＯＫ
   PRINT "check!"
   CALL PermMultiply(HH,SS,cc) !AB=BA=I　※恒等置換
   CALL PermPrintOut(cc)

   CALL PermMultiply(SS,HH,cc)
   CALL PermPrintOut(cc)
END SUB


DIM Rev(N) !反転に相当する置換
CALL PermIdentity(Rev)
CALL PermReverse(Rev)

DIM shuffle(N) !リフルシャッフルに相当する置換
DATA 2,4,6,8,10,12,1,3,5,7,9,11
MAT READ shuffle


DIM H(N),S(N) !ハート、スペードの束

FOR R1=1 TO N !前半のマジックでの「好きな数」

   PRINT "----- Request";R1;"の場合-----"

   !●スペードをシャッフルする
   DIM B(N),c(N)
   CALL PermIdentity(B) !初期値
   FOR k=1 TO 12 !回数　※何回か実行すると元に戻る
      LET S(k)=B(R1)
      CALL PermMultiply(B,shuffle,c)
      MAT B=c
   NEXT k
   CALL PermInverse(S,H) !SH=HS=Iより

   DIM RH(N)
   CALL PermMultiply(H,Rev,RH) !ハートをＫ（キング）でシャッフルする場合
   !!!CALL PermMultiply(S,Rev,RH) !スペードをＫ（キング）でシャッフルする場合
   !!!MAT S=H


   FOR R2=1 TO N
      PRINT "表";R2;"の場合"

      !●ハートをシャッフルする
      DIM M(N) !後半のマジックでの「好きな数」「山の選択」
      MAT M=ZER
      FOR i=1 TO R2 !R番目
         FOR k=1 TO 12
            LET M(k)=MOD(M(k)+k,13)
         NEXT k
      NEXT i
      !※「山の選択」は、１３を底に移動させる調整カットで無効になるので、このいずれかになる。

      DIM c1(N)
      CALL PermMultiply(RH,M,c1)
      CALL PermPrintOut(c1)

      !●スペードをカットする
      LET KEY2=c1(1) !移動先
      FOR x=1 TO N !現在位置を探す
         IF S(x)=1 THEN EXIT FOR
      NEXT x
      PRINT x;"から";KEY2;"へ"
      DIM cut(N) !カットに相当する置換
      FOR i=1 TO N
         LET cut(i)=MOD(i+(x-KEY2)-1,12)+1
      NEXT i
      !!!MAT PRINT cut;
      DIM c2(N)
      CALL PermMultiply(S,cut,c2)
      CALL PermPrintOut(c2)

      CALL check(c1,c2)
   NEXT R2

NEXT R1

END



!-----前半のマジックでの「好きな数」が 1 の場合のシャッフル結果-----
!DATA 1, 2, 5, 3,10, 6,12, 4, 9,11, 8, 7 !ハート
!DATA 1, 2, 4, 8, 3, 6,12,11, 9, 5,10, 7 !スペード
!----- 2 の場合-----
!DATA 12, 1, 4, 2, 9, 5,11, 3, 8,10, 7, 6
!DATA  2, 4, 8, 3, 6,12,11, 9, 5,10, 7, 1
!----- 3 の場合-----
!DATA 9,10, 1,11, 6, 2, 8,12, 5, 7, 4, 3
!DATA 3, 6,12,11, 9, 5,10, 7, 1, 2, 4, 8
!----- 4 の場合-----
!DATA 11,12, 3, 1, 8, 4,10, 2, 7, 9, 6, 5
!DATA  4, 8, 3, 6,12,11, 9, 5,10, 7, 1, 2
!----- 5 の場合-----
!DATA 4, 5, 8, 6, 1, 9, 3, 7,12, 2,11,10 !※代替として混ざられる位置
!DATA 5,10, 7, 1, 2, 4, 8, 3, 6,12,11, 9 !※捨て場へ移される順
!----- 6 の場合-----
!DATA 8, 9,12,10, 5, 1, 7,11, 4, 6, 3, 2
!DATA 6,12,11, 9, 5,10, 7, 1, 2, 4, 8, 3
!----- 7 の場合-----
!DATA 2, 3, 6, 4,11, 7, 1, 5,10,12, 9, 8
!DATA 7, 1, 2, 4, 8, 3, 6,12,11, 9, 5,10
!----- 8 の場合-----
!DATA 10,11, 2,12, 7, 3, 9, 1, 6, 8, 5, 4
!DATA  8, 3, 6,12,11, 9, 5,10, 7, 1, 2, 4
!----- 9 の場合-----
!DATA 5, 6, 9, 7, 2,10, 4, 8, 1, 3, 12,11
!DATA 9, 5,10, 7, 1, 2, 4, 8, 3, 6, 12,11
!----- 10 の場合-----
!DATA  3, 4, 7, 5,12, 8, 2, 6,11, 1,10, 9
!DATA 10, 7, 1, 2, 4, 8, 3, 6,12,11, 9, 5
!----- 11 の場合-----
!DATA  6, 7,10, 8, 3,11, 5, 9, 2, 4, 1,12
!DATA 11, 9, 5,10, 7, 1, 2, 4, 8, 3, 6,12
!----- 12 の場合-----
!DATA  7, 8,11, 9, 4,12, 6,10, 3, 5, 2, 1
!DATA 12,11, 9, 5,10, 7, 1, 2, 4, 8, 3, 6




!後半のマジックでのシャッフルに相当する置換
!DATA  1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12 !「１３でのシャッフル」
!DATA  2, 4, 6, 8,10,12, 1, 3, 5, 7, 9,11
!DATA  3, 6, 9,12, 2, 5, 8,11, 1, 4, 7,10
!DATA  4, 8,12, 3, 7,11, 2, 6,10, 1, 5, 9
!DATA  5,10, 2, 7,12, 4, 9, 1, 6,11, 3, 8
!DATA  6,12, 5,11, 4,10, 3, 9, 2, 8, 1, 7
!DATA  7, 1, 8, 2, 9, 3,10, 4,11, 5,12, 6
!DATA  8, 3,11, 6, 1, 9, 4,12, 7, 2,10, 5
!DATA  9, 5, 1,10, 6, 2,11, 7, 3,12, 8, 4
!DATA 10, 7, 4, 1,11, 8, 5, 2,12, 9, 6, 3
!DATA 11, 9, 7, 5, 3, 1,12,10, 8, 6, 4, 2
!DATA 12,11,10, 9, 8, 7, 6, 5, 4, 3, 2, 1
 

Re: 新発見

 投稿者：GAI  投稿日：2008年11月 8日(土)12時24分29秒 		返信・引用
  > No.71[元記事へ]

山中和義さんへのお返事です。


　確認作業御疲れさんでした。

> またスペードの方も確認はできます。   ＊エー！！スペードでも可能ですか？
>
>
>
> !置換（Permutation）の計算
> !※技術メモ
> !　A=┌ 1 2 3 4 ┐=(1 2 4 3)　※１行目の順番は固定とする
> !　　└ 2 4 1 3 ┘
> !の場合、
> !　DATA 2,4,1,3 !配列変数の「添え字と値」に対応させる
> !　MAT READ A
> !とプログラムでは記述する。
>
> SUB PermPrintOut(A()) !表示する　※標準形（２行ｎ列の行列表記する）
>    MAT PRINT USING(REPEAT$(" ##",UBOUND(A))): A;
> END SUB
>
> SUB PermMultiply(A(),B(), AB()) !積AB　※AB≠BA、A(BC)=(AB)C
>    LET  ua=UBOUND(A)
>    LET  ub=UBOUND(B)
>    IF ua=ub THEN
>       FOR i=1 TO ua
>          LET  AB(i)=A(B(i)) !※合成写像(AB)(i)=A(B(i))
>       NEXT i
>    ELSE
>       PRINT "次元が違います。A=";ua;" B=";ub
>       STOP
>    END IF
> END SUB
> !-------------------- ここまでがサブルーチン
>
>
>
> !main
>
> LET N=12 !※固定
>
> DIM TT(N)
> SUB cut(C(),p) !カットする　※p位置以降が上になる
>    FOR i=1 TO p-1 !前半部分を後へ
>       LET TT(N+i-p+1)=C(i)
>    NEXT i
>    FOR i=p TO N !後半部分を前へ
>       LET TT(i-p+1)=C(i)
>    NEXT i
>    FOR i=1 TO N !copy it
>       LET C(i)=TT(i)
>    NEXT i
> END SUB
>
>
> !----- 前半のマジックでの「好きな数」が 1 の場合-----
> DATA 1, 2, 5, 3,10, 6,12, 4, 9,11, 8, 7 !ハート
> DATA 1, 2, 4, 8, 3, 6,12,11, 9, 5,10, 7 !スペード
>
> !----- 2 の場合-----
> DATA 12, 1, 4, 2, 9, 5,11, 3, 8,10, 7, 6
> DATA  2, 4, 8, 3, 6,12,11, 9, 5,10, 7, 1
>
> !----- 3 の場合-----
> DATA 9,10, 1,11, 6, 2, 8,12, 5, 7, 4, 3
> DATA 3, 6,12,11, 9, 5,10, 7, 1, 2, 4, 8
>
> !----- 4 の場合-----
> DATA 11,12, 3, 1, 8, 4,10, 2, 7, 9, 6, 5
> DATA  4, 8, 3, 6,12,11, 9, 5,10, 7, 1, 2
>
> !----- 5 の場合-----
> DATA 4, 5, 8, 6, 1, 9, 3, 7,12, 2,11,10 !※代替として混ざられるスペードパケットの位置
> DATA 5,10, 7, 1, 2, 4, 8, 3, 6,12,11, 9 !※捨て場へ移される順
>
> !----- 6 の場合-----
> DATA 8, 9,12,10, 5, 1, 7,11, 4, 6, 3, 2
> DATA 6,12,11, 9, 5,10, 7, 1, 2, 4, 8, 3
>
> !----- 7 の場合-----
> DATA 2, 3, 6, 4,11, 7, 1, 5,10,12, 9, 8
> DATA 7, 1, 2, 4, 8, 3, 6,12,11, 9, 5,10
>
> !----- 8 の場合-----
> DATA 10,11, 2,12, 7, 3, 9, 1, 6, 8, 5, 4
> DATA  8, 3, 6,12,11, 9, 5,10, 7, 1, 2, 4
>
> !----- 9 の場合-----
> DATA 5, 6, 9, 7, 2,10, 4, 8, 1, 3, 12,11
> DATA 9, 5,10, 7, 1, 2, 4, 8, 3, 6, 12,11
>
> !----- 10 の場合-----
> DATA  3, 4, 7, 5,12, 8, 2, 6,11, 1,10, 9
> DATA 10, 7, 1, 2, 4, 8, 3, 6,12,11, 9, 5
>
> !----- 11 の場合-----
> DATA  6, 7,10, 8, 3,11, 5, 9, 2, 4, 1,12
> DATA 11, 9, 5,10, 7, 1, 2, 4, 8, 3, 6,12
>
> !----- 12 の場合-----
> DATA  7, 8,11, 9, 4,12, 6,10, 3, 5, 2, 1
> DATA 12,11, 9, 5,10, 7, 1, 2, 4, 8, 3, 6
>


この前半のパターンの表はなんとか手にしました。

後半の完成されたプログラムの全体が見たいです。
例のカードシュミレーションの（前半も含む）リストを送ってください。 		 

質問

 投稿者：GAI  投稿日：2008年11月 8日(土)15時32分9秒 		返信・引用
  > No.71[元記事へ]

山中和義さんへのお返事です。


request２での表２の場合の最終パケットの配列が
トランプで実験してみると（左より裏向きにした場合に上から並ぶ順で読む。）
ハ ー ト：7,8,11,9,4,12,6,10,3,5,2,1,(13)
スペード：12,11,9,5,10,7,1,2,4,8,3,6
であったのに対し
置換のプログラムで表示された結果の表では
ハ ー ト：1,2,5,3,10,6,12,4,9,11,8,7,(13)
スペード：2,4,8,3,6,12,11,9,5,10,7,1
となりました。
でもチェックではOKで合ってはいるのですが・・・

他にも
request5,
表５の場合で
実験では
ハ ー ト：7,8,11,9,4,12,6,10,3,5,2,1,(13)
スペード：12,11,9,5,10,7,1,2,4,8,3,6
出力の表では
----- Request 5 の場合-----

表 4 の場合
  6  7 10  8  3 11  5  9  2  4  1 12
11  9  5 10  7  1  2  4  8  3  6 12
check!
1  2  3  4  5  6  7  8  9  10  11  12
1  2  3  4  5  6  7  8  9  10  11  12
表 5 の場合
  1  2  5  3 10  6 12  4  9 11  8  7　　（ハート列）
  1  2  4  8  3  6 12 11  9  5 10  7　　（スペード列）
check!
1  2  3  4  5  6  7  8  9  10  11  12
1  2  3  4  5  6  7  8  9  10  11  12

と最終結果と微妙にずれています。 		 

Re: 質問

 投稿者：山中和義  投稿日：2008年11月 8日(土)17時27分15秒 		返信・引用
  > No.73[元記事へ]

GAIさんへのお返事です。


> request２での表２の場合の最終パケットの配列が
> トランプで実験してみると（左より裏向きにした場合に上から並ぶ順で読む。）
> ハ ー ト：7,8,11,9,4,12,6,10,3,5,2,1,(13)
> スペード：12,11,9,5,10,7,1,2,4,8,3,6
> であったのに対し
> 置換のプログラムで表示された結果の表では
> ハ ー ト：1,2,5,3,10,6,12,4,9,11,8,7,(13)
> スペード：2,4,8,3,6,12,11,9,5,10,7,1
> となりました。

失礼しました。ここでも並び順の判断ミスでした。
プログラムを修正しておきました。 		 

Re: 新発見

 投稿者：山中和義  投稿日：2008年11月 9日(日)11時52分0秒 		返信・引用 　編集済
  > No.72[元記事へ]

GAIさんへのお返事です。

> 後半の完成されたプログラムの全体が見たいです。
> 例のカードシュミレーションの（前半も含む）リストを送ってください。

遅くなりました。
現状のプログラムはここからダウンロードしてください。

また数理的な説明としては、置換で表現（プログラム No.71記事）したことをもって代えさせていただきます。

数学的に１つのことを、たとえば
手の中でシャッフルしたり、場でシャッフルしたり
目先を変えてあたかも違ったことやっているように見せるのがマジックの１つの常套手段ですね。 		 

お礼

 投稿者：GAI  投稿日：2008年11月 9日(日)13時12分40秒 		返信・引用
  すごい！
トランプをいちいち操作することなく、現象を追跡できるなんて・・・
こんなに自由にコンピューターを使いこなせたら楽しいだろうなー（私も頑張ろう！）
ひょんな質問からここまでプログラムを組んでくれたことに感謝いたします。
このソフトは私の宝物になります。
いろいろな質問にお答え頂き、誠にありがとうございました。 		 

質問です・・・

 投稿者：NINA  投稿日：2008年11月 9日(日)22時54分19秒 		返信・引用
  大学の数学の課題で、

「1，2，3，…，ｎ　の順に並んでいる数列のなかで、“＋”と“＝”を入れて式を完成させよ。」

というような、課題がでました。問題の答えの例としては

1＋2＝3
1＋2＋3＋…＋14＝15＋16＋17＋…＋20　（＝105）

という様な感じです。


これを十進BASICで1,000,000桁までくらいの等式をつくれ　ということ言われ、やってみたのですが、
BASICを使うのは初めてなので、どんな風にプログラムを作ればいいのかわかりません。

どなたかご指導いただければと思い、投稿させていただきました。
わかるかた、ぜひよろしくお願いします！！ 		 

Re: 質問です・・・

 投稿者：荒田浩二  投稿日：2008年11月10日(月)14時45分25秒 		返信・引用 　編集済
  > No.77[元記事へ]

NINAさんへのお返事です。

まず、1,000,000桁ではなくn=1,000,000までの間違いですよね。

等式

  1+2+…+(k-1)+k=(k+1)+(k+2)+…+(n-1)+n

を、次のようにnについての2次方程式と考えれば

  (k^2+k)/2=(n^2+n)/2-(k^2+k)/2

nが整数解を持てば等式は成り立ちます。

  FOR k=1 TO 1000000 〜 NEXT k

として、nが整数解を持つか調べればよいのでは。
(1,000,000までに8個ありました) 		 

Re: 質問です・・・

 投稿者：NINA  投稿日：2008年11月10日(月)23時39分46秒 		返信・引用
  > No.78[元記事へ]

荒田浩二さんへのお返事です。



> NINAさんへのお返事です。
>
> まず、1,000,000桁ではなくn=1,000,000までの間違いですよね。

そうでした。ご指摘ありがとうございます。


> 等式
>
>   1+2+…+(k-1)+k=(k+1)+(k+2)+…+(n-1)+n
>
> を、次のようにnについての2次方程式と考えれば
>
>   (k^2+k)/2=(n^2+n)/2-(k^2+k)/2
>
> nが整数解を持てば等式は成り立ちます。
>
>   FOR k=1 TO 1000000 〜 NEXT k
>
> として、nが整数解を持つか調べればよいのでは。
> (1,000,000までに8個ありました)


とてもわかりやすい解説ありがとうございました！求め方、式の書き方は理解できました。

さっそくやってみたのですが、 (k^2+k)/2=(n^2+n)/2-(k^2+k)/2　と打ったところ、エラーの表示がでてしまいました。
そのまま入力したのがいけなかったのでしょうか？？

また、整数解をもつか調べるのはIF文で良いのでしょうか？？

教えていただけますでしょうか？？ 		 

Re: 質問です・・・

 投稿者：山中和義  投稿日：2008年11月11日(火)11時10分6秒 		返信・引用 　編集済
  > No.77[元記事へ]

NINAさんへのお返事です。

> 大学の数学の課題で、
> 「1，2，3，…，ｎ　の順に並んでいる数列のなかで、“＋”と“＝”を入れて式を完成させよ。」

別解を紹介しておきます。

●解き方
たとえばN=10の場合、1○2○3○4○5○6○7○8○9○10 と数列ができる。
○（演算記号＝を入る場所）の数は、10-1=9個あるから場所の可能性は１〜９である。

次に条件を満たす判断方法は、たとえば、３番目とすると
　1○2○3=4○5○6○7○8○9○10
となるから、＝で元の数列は「左辺」と「右辺」に２分割される。
したがって、1○2○3　と　4○5○6○7○8○9○10　の２つの等差数列の和を求めて「左辺＝右辺」で判断すればよい。
ここでは左辺と右辺の和を求めるのではなく「左辺が全体の和の半分に等しい」ということで条件を満たすと判断する。
Σk=n*(n+2)/2の公式を使ってそれぞれ求める。

ここで、S1=1、S2=1+2、S3=1+2+3、… 、Sn=1+2+3+ … +n、すなわちデータ列{Sn}を考える。
これは左辺の和が順に並んだものである。
したがって、「左辺が全体の和の半分に等しい」は
　この1〜n個のデータ列から、Sn/2の値を見つける「探索」の問題
に置き換えることができる。
逐次探索すると毎回の走査が必要で時間がかかる。
S1,S2,…,Snは整列された（小さい順）データ列だから、２分探索が可能である。

●「基本アルゴリズムの課題」としてのサンプル 
!OPTION ARITHMETIC decimal_high

LET t0=TIME

DIM S(1000000) !S1,S2,…,Sn
LET S(1)=1
FOR k=2 TO 1000000
   LET S(k)=S(k-1)+k !左辺 1+ … +(k-1)+k の値
NEXT k


LET c=0 !個数
FOR n=1 TO 1000000

   LET key=S(n)/2 !「全体の半分の値」を見つける

   LET L=1 !下限
   LET H=n !上限
   DO WHILE L<=H !逆転したら終了
      LET M=INT((L+H)/2) !中央
      IF S(M)<=key THEN LET L=M+1 !絞り込む
      IF S(M)>=key THEN LET H=M-1
   LOOP
   !!!PRINT n;L;H

   IF L=H+2 THEN !見つかったら
      LET c=c+1
      PRINT c;"個目"

      PRINT "1 + … +";M;"=";M+1; !左辺と＝
      IF M<n-1 THEN !整形のため
         PRINT "+ … +";n; !右辺
      END IF
      PRINT "（=";S(M);"）" !和
   END IF

NEXT n


PRINT "計算時間=";TIME-t0

END
（実行結果） 
 1 個目
1 + … + 2 = 3 （= 3 ）
 2 個目
1 + … + 14 = 15 + … + 20 （= 105 ）
 3 個目
1 + … + 84 = 85 + … + 119 （= 3570 ）
 4 個目
1 + … + 492 = 493 + … + 696 （= 121278 ）
 5 個目
1 + … + 2870 = 2871 + … + 4059 （= 4119885 ）
 6 個目
1 + … + 16730 = 16731 + … + 23660 （= 139954815 ）
 7 個目
1 + … + 97512 = 97513 + … + 137903 （= 4754343828 ）
 8 個目
1 + … + 568344 = 568345 + … + 803760 （= 161507735340 ）


●「２次方程式を解く」の別解としてのサンプル
FOR k=1 TO 1000000
　ｎについての２次方程式 n^2+n-2*(k^2+k)=0 を解いて正の整数解を得る
NEXT k
これは、数列{Sk,Sk+1,…}の中から、2*Skを探すことです。
無限個の中を探索できないので、（実際は小さい順に整列しているので途中で中止する）

　Sk,Sk+1,…,Sn-1,Sn,Sn+1,…
　　　　　　　　　↑
　　　　　　　　　2*Sk？
この矢印のの位置を２次方程式を解くことで推定している。


実際どこにデータがあるかは、S=Σk=n*(n+2)/2よりSQR(S)の位置と推定されるので、
上記サンプル同様に数列{S1,S2,…,Sn}でSn/2を探すアプローチは以下のようになる。 
!OPTION ARITHMETIC decimal_high

LET t0=TIME


LET c=0 !個数
FOR N=2 TO 1000000

   LET S=N*(N+1)/2 !全部の和

   LET a=INT(SQR(S)) !＝が入る箇所の可能性
   FOR k=a TO a+1
      LET L=k*(k+1)/2 !左辺の和

      IF 2*L=S THEN !2*左辺＝全部の和なら、条件をみたす
         LET c=c+1
         PRINT c;"個目"

         PRINT "1 + … +";k;"="; !左辺と＝
         IF i=N-1 THEN !整形のため
            PRINT k+1;"（=";L;"）" !右辺と和
         ELSE
            PRINT k+1;"+ … +";N;"（=";L;"）"
         END IF
      END IF
   NEXT k

NEXT N


PRINT "計算時間=";TIME-t0

END
 

Re: 質問です・・・

 投稿者：荒田浩二  投稿日：2008年11月11日(火)18時32分18秒 		返信・引用 　編集済
  > No.79[元記事へ]

NINAさんへのお返事です。


> さっそくやってみたのですが、 (k^2+k)/2=(n^2+n)/2-(k^2+k)/2　と打ったところ、エラーの表示がでてしまいました。


　BASICでは、等号は変数に数値を与えるときに使います(代入文)。

たとえば「LET a=b+3」という文は、変数aに数値式b+3の値を代入するという意味です。(変数bが4ならばaの値は7になります)

左辺は一つの変数でなければいけません。「LET b+3=a」と記述すると文法エラーになります。
(十進BASICのヘルプの[入門][変数][let文]を参照して下さい)


  また、BASICは式の変形や方程式を解くといった数式処理には対応していません。
その部分は自分で解くか、解くためのプログラムを作らなければなりません。

前出の問題で言えば、

  (k^2+k)/2=(n^2+n)/2-(k^2+k)/2

を下のように変形することはBASICはしてくれません。

  n^2+n-2*(k^2+k)=0

この解を求めるのも、そのためのプログラムを作る必要があります。


　下は、2次方程式 a*x^2+b*x+c=0 の解の一つを求め整数性を判定するプログラムです。参考にしてください。

  10 LET a=1
  20 LET b=3
  30 LET c=-4
  40 LET D=b^2-4*a*c  ! 判別式
  50 LET x=(-b+SQR(D))/(2*a)  ! 解の公式
  60 PRINT x
  70 IF INT(x)=x THEN PRINT "整数"
  80 END

*70行のIF文で整数の判定をしています。(IF文での等号は両辺が等しいかの判定に使われるので左辺が変数である必要はありません）
*INT(x)やSQR(D)は組込み関数です。(ヘルプ[数値][組込み関数][数値関数]参照)
*40行と50行の「!」は注釈記号です。この記号以降は何を書いてもプログラムの実行に影響を与えません。 		 

確認

 投稿者：小塚貞典  投稿日：2008年11月12日(水)14時25分6秒 		返信・引用
  ＧＭＯ（グローバルメデイアオンライン）は外税です。  

Re: 質問です・・・

 投稿者：山中和義  投稿日：2008年11月13日(木)15時53分38秒 		返信・引用 　編集済
  > No.77[元記事へ]

NINAさんへのお返事です。

> 大学の数学の課題で、
>
> 「1，2，3，…，ｎの順に並んでいる数列のなかで、“＋”と“＝”を入れて式を完成させよ。」

データ列の処理として、もう１つ別解を紹介しておきます。


●「基本アルゴリズムの課題」としてのサンプル（その２）

方程式 n*(n+1)/2=2*k*(k+1)/2 より
２つの数列
　数列 S1={1,3,6,10,15,21,…,n*(n+1)/2,…}、n=1〜1000000
　数列 S2={2,6,12,20,30,42,…,2*k*(k+1)/2,…}、k=1〜1000000-1
を考える。
この２つの数列（データ列）は小さい順に整列されているので、
１つの整列されたデータ列に併合（マージ）することに着目する。
!OPTION ARITHMETIC decimal_high

LET t0=TIME

LET a=1000000

LET n=1 !先頭から
LET k=1

LET c=0 !個数
DO UNTIL n>a OR k>a-1 !どちらかのデータ列が終わるまで
   LET s1=n*(n+1)/2 !データ列を得る
   LET s2=2*k*(k+1)/2

   IF s1=s2 THEN !マージする
      LET c=c+1
      PRINT c;"個目"

      PRINT "1 + … +";k;"=";k+1; !左辺と＝
      IF k<n-1 THEN !整形のため
         PRINT "+ … +";n; !右辺
      END IF
      PRINT "（=";s1/2;"）" !和

      LET k=k+1
      LET n=n+1
   ELSEIF s1>s2 THEN
      LET k=k+1
   ELSE
      LET n=n+1
   END IF
LOOP

PRINT "計算時間=";TIME-t0

END
 

疑問

 投稿者：GAI  投稿日：2008年11月16日(日)07時09分52秒 		返信・引用
  １から３を　　　１　３
　　　　　　　　　２
と配列すれば、上の段の２数の差が（ただし大きい方から小さい方を引く。３−１）
下の数となる。
この規則を敷衍し
１から６までの数字を一度だけ使用して
　　　　　　　●　●　●
　　　　　　　　●　●
　　　　　　　　　●
の位置に入れたい。
試行錯誤の後、６　２　５
　　　　　　　　４　３
　　　　　　　　　１
なる配列が（もちろん他のパターンも存在すると思う。）求められる。
しかし、
次からが人間には限界が出てきて、
では、１〜１０の数字を一度だけ使用して
　　　　　　●　●　●　●
　　　　　　　●　●　●
　　　　　　　　●　●
　　　　　　　　　●
の配列を構成
さらに、１〜１５の数字で
　　　　　●　●　●　●　●
　　　　　　●　●　●　●
　　　　　　　●　●　●
　　　　　　　　●　●
　　　　　　　　　●
１〜２１で
　　　　●　●　●　●　●　●
　　　　　●　●　●　●　●
　　　　　　●　●　●　●
　　　　　　　●　●　●
　　　　　　　　●　●
　　　　　　　　　●
・・・・
・・・・
は構成可能なのだろうか？
この問題を解決してもらいたい。 		 

Re: 疑問

 投稿者：荒田浩二  投稿日：2008年11月16日(日)12時05分29秒 		返信・引用
  > No.84[元記事へ]

GAIさんへのお返事です。

n=10では存在しました。

  9  10   3   8
    1   7   5
      6   2
        4

次のプログラムで発見しましたが、少し工夫すれば全数調査も可能ではないかと思います。

LET k=4  ! 4行
LET n=k*(k+1)/2  ! n=10
DIM a(k,k),check(n)
FOR maxn=1 TO CEIL(k/2)
   FOR r=1 TO n^(n/2)
      MAT check=ZER
      LET a(1,maxn)=n
      LET check(n)=1
      FOR i=1 TO k
         FOR j=1 TO k+1-i
            IF NOT (i=1 AND j=maxn) THEN
               DO
                  LET num=INT((n-1)*RND)+1
               LOOP UNTIL check(num)=0
               LET a(i,j)=num
               LET check(num)=1
            END IF
         NEXT j
      NEXT i
      !MAT PRINT a
      CALL diff
      IF p=0 THEN MAT PRINT a
      LET p=0
   NEXT r
NEXT maxn
SUB diff
   FOR i=1 TO k-1
      FOR j=1 TO k-i
         IF ABS(a(i,j)-a(i,j+1))<>a(i+1,j) THEN
            LET p=1
            EXIT SUB
         END IF
      NEXT j
   NEXT i
END SUB
END 		 

助けて下さい。

 投稿者：GAI  投稿日：2008年11月16日(日)20時54分54秒 		返信・引用
  早速リストをコピーして動かしてみたら、OKでした。
k=5 でやっていますが、朝から動かしていますがまだ終わりません。（１２時間近く。）
せめて、１時間位で調査できないものでしょうか？
どこをどう改良したらよいのか・・・、誰か助け舟が欲しい！！！ 		 

Re: 助けて下さい。

 投稿者：荒田浩二  投稿日：2008年11月16日(日)22時07分56秒 		返信・引用 　編集済
  > No.86[元記事へ]

GAIさんへのお返事です。


ごめんなさい。
あれは20分くらいで取り合えず作ったもので、作りながらも「無駄が多い」と考えてはいました。
ランダム調査で試行回数がCEIL(k/2)*SQR(n^n)ですから、n=15ではなかなか終わらないと思います。

さっそく改良版を作ります。
明日までにはできるかと思います。 		 

Re: 疑問

 投稿者：山中和義  投稿日：2008年11月17日(月)09時14分59秒 		返信・引用
  > No.84[元記事へ]

GAIさんへのお返事です。

●サンプル　その１
前回紹介したバックトラック法による総当りです。
K段の場合、K*(K+1)/2の階乗になります。（K=5、15!=1,307,674,368,000）

この手のパズルはバックトラック法で解けます（時間はかかる）ので、ぜひマスターしてみてください。
PUBLIC NUMERIC ANSWER_COUNT !解答数
LET ANSWER_COUNT=0

LET K=5 !段数　※1〜

LET N=K*(K+1)/2 !１〜Ｋまでの数字
DIM A(N)
MAT A=ZER

LET t0=TIME
PRINT K;"段"
PRINT "1 〜";N;"までの数字"
CALL backtrack(1,K,N,A)
IF ANSWER_COUNT=0 THEN PRINT "解なし"
PRINT "計算時間=";TIME-t0

END


EXTERNAL SUB backtrack(p,K,N,A())
FOR nm=1 TO N
   LET A(p)=nm !仮に設定してみる

   CALL checkrule(p,nm,N,A, rc) !条件を満たすなら
   IF rc=1 THEN

      IF p=N THEN !すべて埋まったら
         LET ANSWER_COUNT=ANSWER_COUNT+1
         PRINT ANSWER_COUNT;"個目"

         FOR i=K TO 1 STEP -1 !上段から
            PRINT REPEAT$(" ",K-i); !右へシフト
            FOR j=1 TO i !この段の数字の数
               PRINT USING "###": A((i-1)*i/2+j);
            NEXT j
            PRINT
         NEXT i
         !!!MAT PRINT A;

      ELSE
         CALL backtrack(p+1,K,N,A) !次へ

      END IF

   END IF
   LET A(p)=0 !元に戻す
NEXT nm
END SUB


EXTERNAL SUB checkrule(p,nm,N,M() ,rc) !条件が満たすかどうか確認する
LET rc=0

!●数字は重複していないか？
FOR i=1 TO p-1
   IF nm=M(i) THEN EXIT SUB !見つかったのでＮＧ！
NEXT i

!●上段の２数の差？
!M(p)の添え字番号と配置
!11 12 …　　　５段目 s=11
!　7 8 9 10　　４段目 s=7
!　 4 5 6　　　３段目 s=4
!　　2 3　　　 ２段目 s=2
!　　 1　　　　１段目 s=1
!
!M(p-1)　M(p)　　x段目
!　　M(p-x)

LET a=1/2 !段数を得る　※xの２次方程式(x-1)*x/2+1-p=0の解
LET b=-1/2
LET c=1-p
LET D=b^2-4*a*c !判別式　※この解は実数のみ
LET x=INT((-b+SQR(D))/(2*a))

IF x>1 THEN !２段目以降なら
   IF p>(x-1)*x/2+1 THEN !この段の２列目以降なら
      IF ABS(M(p-1)-M(p))<>M(p-x) THEN EXIT SUB !不成立なのでＮＧ！
   END IF
END IF

!●左右対称
IF p=N AND M(p)<M(p-x+1) THEN EXIT SUB !上段の左端と右端

LET rc=1 !ＯＫ！
END SUB
（実行結果） 
 5 段
1 〜 15 までの数字
 1 個目
  6 14 15  3 13
   8  1 12 10
    7 11  2
     4  9
      5
計算時間= 36.36
※WindowsME、CPU Pentium��700MHzにて 		 

Re: 疑問

 投稿者：山中和義  投稿日：2008年11月17日(月)10時46分44秒 		返信・引用 　編集済
  > No.88[元記事へ]

GAIさんへのお返事です。

●サンプル　その２
K段の場合、使用する数字は1〜N=K*(K+1)/2となる。
上段の数字のみが自由に設定できる。ただし、重複はしない。
この上段の数字列は、順列P(N,K)で決めることができる。
それによって、下段は階差として順に決まる。
このとき、数字の重複がないか確認する。

K=3なら、N=3*(3+1)/2=6。
上段 2 4 5 とすると

　2 4 5
　 2 1　←上段２つの差
　　1　←上段２つの差

たとえば、２段目１番目の２が重複しているため、ＮＧとなる。

２段　3P2=          6
３段　6P3=        120
４段　10P4=     5,040
５段　15P5=   360,360
６段　21P6=39,070,080　←かなりキツイ
　：
の数を確認する。
PUBLIC NUMERIC ANSWER_COUNT !解答数
LET ANSWER_COUNT=0

LET K=5 !段数　※1〜

LET N=K*(K+1)/2 !１〜Ｎまでの数字
DIM F(N),FF(N),B(K),BB(K)
MAT F=ZER
MAT B=ZER

LET t0=TIME

PRINT K;"段"
PRINT "1 〜";N;"までの数字"
CALL perm(1,N,K, F,B,FF,BB)
IF ANSWER_COUNT=0 THEN PRINT "解なし"

PRINT "計算時間=";TIME-t0

END


EXTERNAL SUB perm(p,N,R, F(),B(),FF(),BB()) !順列nPrを生成する
FOR nm=1 TO N !上段のＫ個の数を決める

   IF F(nm)=0 THEN !数字は重複なしに埋める

      LET F(nm)=1 !使用中とする
      LET B(p)=nm !仮に設定してみる

      IF p=R THEN !すべて埋まったら
         CALL checkrule(R,F,B,FF,BB, rc) !条件を満たすなら
         IF rc=1 THEN

            LET ANSWER_COUNT=ANSWER_COUNT+1
            PRINT ANSWER_COUNT;"個目"

            MAT BB=B
            FOR j=1 TO R !上段
               PRINT USING "###": BB(j);
            NEXT j
            PRINT
            FOR i=R-1 TO 1 STEP -1 !下段へ
               PRINT REPEAT$(" ",R-i); !右へシフト
               FOR j=1 TO i !この段の数字の数
                  LET BB(j)=ABS(BB(j)-BB(j+1))
                  PRINT USING "###": BB(j);
               NEXT j
               PRINT
            NEXT i

         END IF
      ELSE
         CALL perm(p+1,N,R, F,B,FF,BB) !次へ
      END IF

      LET B(p)=0 !元に戻す
      LET F(nm)=0

   END IF

NEXT nm
END SUB


EXTERNAL SUB checkrule(K,F(),B(),FF(),BB(), rc) !条件が満たすかどうか確認する
LET rc=0

!●左右対称
IF B(1)>B(K) THEN EXIT SUB !上段の左端と右端

!●上段の２数の差？
MAT BB=B !作業配列へ
MAT FF=F
FOR x=K-1 TO 1 STEP -1 !x段目
   FOR j=1 TO x !１つ下の段
      LET p=ABS(BB(j)-BB(j+1))
      IF FF(p)=1 THEN EXIT SUB !数字が重複していないか
      LET BB(j)=p
      LET FF(p)=1 !使用中とする
   NEXT j
NEXT x

LET rc=1 !ＯＫ！
END SUB

（実行結果） 
●  5 段
1 〜 15 までの数字
 1 個目
  6 14 15  3 13
   8  1 12 10
    7 11  2
     4  9
      5
計算時間= 23.13 　←多少早くなった


●  6 段
1 〜 21 までの数字
解なし
計算時間= 2978.17
※WindowsME、CPU Pentium��700MHzにて



●改良案
数字Nは必ず上段に存在する。この配置はK通り。
残りK-1箇所に残りの数字を埋める順列はP(N-1,K-1)となる。
これによって、

２段　2×2P1=             4
３段　3×5P2=            30
４段　4×9P3=         2,016
５段　5×14P4=      120,120
６段　6×20P5=   11,162,880
７段　7×27P6=1,491,890,400　←かなりキツイ

となり、７段の求解が現実となる？！ 		 

お礼

 投稿者：GAI  投稿日：2008年11月17日(月)15時17分47秒 		返信・引用
  色々調べましたら５段までは構成できるが、６段以降は不可能（証明はどうやるのだろうか？）とのことでした。
結果をみるとなーんだ！なんですがこれを試行錯誤だけでやってみると、最初の５つの数字を微妙に変化させながらいくらやっても、数段後には重複する数字が出現してくるのです。
まさに成功するには根性の何者でもありません。（私も３日ほど取り組みましたがどうしても５段を発見することができませんでした。トホホ・・・）
このパズルは誰にでもでき、あきらめない気持ちと多少の幸運というギャンブル的要素を含んだとってもいいパズルだと思いました。
だれがこんな発見をして世の中に紹介しているんでしょうか？
またこれが５段で終わりということもありがたいです。
もうこれ以上考えたくもありませんもの・・・
しかし
証明されたとはホントはウソで、余りにもパターン数が多く６，７，８・・・まで構成できないから以降もあり得ないだろうとの感覚だけからそう結論を出しているかもしれません。
ある思いがけない段において構成可能ではなかろうかという思いもどこかに残ります。
どなたか数学的な証明を出して下さい。 		 

Re: 助けて下さい。

 投稿者：荒田浩二  投稿日：2008年11月17日(月)23時52分29秒 		返信・引用 　編集済
  > No.86[元記事へ]

GAIさんへのお返事です。


全数調査用プログラム完成しました。

まず1行目を決めて、差を取っていき数字の重複がないか調査します。

k行でn個の数字とすると、(n-1)個から(k-1)個を取り出した順列pの前半部分にnを挿入して1行目を構成します。

調査回数を減らすために、対称的な数列はキャンセルするようにしました。

たとえば、k=5,n=15で配列pが 7,11,6,9 だとします。

調査するのは、

  15,7,11,6,9
  7,15,11,6,9
  7,11,15,6,9

この3通りとします。

7,11,6,15,9 と 7,11,6,9,15 は、配列pが 9,6,11,7 のときに調査します。

また、このときは 9,6,15,11,7 は調査しません。


  行数     実行時間   調査回数     解
  k=2 --->   0.03 秒         2 回   2個
  k=3 --->   0.08 秒        30 回   4個
  k=4 --->   0.14 秒      1008 回   4個
  k=5 --->   2.05 秒     60060 回   1個
  k=6 ---> 192.16 秒   5581440 回   0個 (2進モードで100.20秒)
  k=7 ---> 未調査    745945200 回   ?個 (2進モードでも4時間近くか?)
  k=8 ---> 未調査 135566323200 回   ?個


DECLARE EXTERNAL SUB combi
PUBLIC NUMERIC k,n,h,pt,count
LET t0=TIME
LET k=5         ! 行数
LET n=k*(k+1)/2 ! 最大値
LET h=INT(k/2)  ! 半分
LET pt=MOD(k,2) ! 奇偶
DIM nn(n-1),c(k-1)
MAT nn=ZER
LET count=0
LET j=0
CALL combi(nn,1,k-1,j,c)
PRINT TIME-t0;"秒",count;"回"
END

EXTERNAL SUB differ(p()) !注意:一部改良しました
DIM a(k,k),ck(n-1)
LET a(1,1)=n
FOR j=2 TO k
   LET a(1,j)=p(j-1)
NEXT j
CALL check
FOR j=2 TO h
   SWAP a(1,j-1),a(1,j)
   CALL check
NEXT j
IF pt=1 AND p(1)<p(k-1) THEN ! nが中央のとき
   SWAP a(1,h),a(1,h+1)
   CALL check
END IF
SUB check
   LET count=count+1
   MAT ck=ZER
   FOR r=1 TO k-1
      LET ck(p(r))=1
   NEXT r
   FOR ii=1 TO k-1
      FOR jj=1 TO k-ii
         LET d=ABS(a(ii,jj)-a(ii,jj+1))
         IF ck(d)=1 THEN EXIT SUB ! 数値重複
         LET ck(d)=1
         LET a(ii+1,jj)=d
      NEXT jj
   NEXT ii
   MAT PRINT a;  ! 解あり
END SUB
END SUB

REM 十進BASIC添付"\BASICw32\SAMPLE\COMBINAT.BAS"より
REM 1〜n-1の集合からr個を選ぶ組合せを生成する。
EXTERNAL SUB combi(nn(),kk,r,j,c())
DECLARE EXTERNAL SUB permu
! kk以降の数からr個を選択する
IF r=0 THEN
   FOR i=1 TO n-1
      IF nn(i)=1 THEN
         LET j=j+1
         LET c(j)=i
      END IF
   NEXT i
   !MAT PRINT c;
   CALL permu(c,1)
   LET j=0
ELSE
   FOR i=kk TO n-r
      LET nn(i)=1
      CALL combi(nn,i+1,r-1,j,c)
      LET nn(i)=0
   NEXT i
END IF
END SUB

REM 十進BASIC添付"\BASICw32\SAMPLE\PERMUTAT.BAS"より
REM (k-1)個の数値の順列を辞書式順序で生成する。
EXTERNAL SUB permu(p(),r)
DECLARE EXTERNAL SUB differ
IF r=k-1 THEN
!MAT PRINT p;
   CALL differ(p)
ELSE
   FOR i=r TO k-1
      LET t=p(i)
      FOR j=i-1 TO r STEP -1
         LET p(j+1)=p(j)
      NEXT j
      LET p(r)=t
      CALL permu(p,r+1)
      LET t=p(r)
      FOR j=r TO i-1
         LET p(j)=p(j+1)
      NEXT j
      LET p(i)=t
   NEXT i
END IF
END SUB 		 

機械語で速度を上げたが

 投稿者：SECOND  投稿日：2008年11月18日(火)04時24分8秒 		返信・引用
  > No.39[元記事へ]

!遅い方の check1,check2,echk ルーチン だけ、機械語で速度を上げたが、
!1.7GHz Pentium-4 128MB で８時間もかかる。Ｃ言語より速いはずなのだが、
!私の書き方が不味いのか？
! http://homepage2.nifty.com/neutro/asm/hojin_43.dll   ...同じフォルダに置く。
! http://homepage2.nifty.com/neutro/asm/hojin_43.asm   ...ソース
!----------------------------------------------------------------------------
!/* ６次のオイラー方陣が存在しないことを確認する. */

OPTION CHARACTER byte
SET TEXT BACKGROUND "opaque"
SET TEXT font"",14
OPTION BASE 0
DIM wb(8,8)
!
LET lb$=REPEAT$( CHR$(0),10000*8*8) !  N=1〜7: 1,1,1,4,56,9408,16942080
LET N= 6 !  2,3,4,5,6
LET cp= 1000 ! カウンターの表示間隔(1~20000)、小さいと速度低下。大きいと中止が困難。
!
CALL main

SUB makelb(x,y)
   local element
   FOR element=0 TO N-1
      FOR i=0 TO x-1
         IF element=wb(y,i) THEN EXIT FOR ! break;
      NEXT i
      IF i>x-1 THEN
         FOR i=0 TO y-1
            IF element=wb(i,x) THEN EXIT FOR ! break;
         NEXT i
         IF i>y-1 THEN
            LET wb(y,x)=element
            IF y=N-1 AND x=N-1 THEN
            !----memcpy(lb[lbs++], wb, sizeof(wb));
               LET w=1+64*lbs
               FOR i=0 TO N-1
                  FOR j=0 TO N-1
                     LET lb$(w+j:w+j)=CHR$(wb(i,j))
                  NEXT j
                  LET w=w+8
               NEXT i
               !--------モニター
               IF MOD(lbs,1000)=0 THEN PRINT "作成中。N=";N;"lbs=";lbs
               !--------
               LET lbs=lbs+1
               EXIT SUB ! return;
            END IF
            IF y=N-1 THEN CALL makelb(x+1,1) ELSE CALL makelb((x),y+1)
         END IF
      END IF
   NEXT element
END SUB

SUB main
   FOR i=0 TO N-1
      LET wb(i,0)=i ! =element
      LET wb(0,i)=i ! =element
   NEXT i
   !------
   PRINT "標準のラテン方陣の作成。"
   LET lbs=0
   CALL makelb(1,1)
   PRINT "作成終了。"
   PRINT
   PRINT "次数 N=";N;"lbs=";lbs;"個"
   PRINT "標準のラテン方陣　2つで、"
   PRINT "　　オイラー方陣を構成可？"
   LET w$=STR$(lbs)
   IF lbs>2 THEN LET w$=w$& "+"& STR$(lbs-1)
   IF lbs>3 THEN LET w$=w$& "+"& STR$(lbs-2)
   IF lbs>4 THEN LET w$=w$& "+..."
   IF lbs>1 THEN LET w$=w$& "+1"
   PLOT TEXT,AT 0.1,0.9 :w$& " が検査回数です。"
   PLOT TEXT,AT 0.1,0.8 :"("& STR$(lbs) &"+1)*"& STR$(lbs)& "/2= "& STR$((lbs+1)*lbs/2)& "回まで、何時間？"
   PRINT "機械語実行中"
   IF check1( CallBackAdr(9), N+16*cp, lbs, lb$)=0 THEN PRINT "解は、有りませんでした。"
   PRINT "終了しました。"
END SUB

!-------------------------------------
FUNCTION check1( moniのアドレス, Ncp, lbs, lb$ )
   ASSIGN "hojin_43.dll","start00"
END FUNCTION

!-------------------------------------
!  hojin.dll が使用する文で、状態表示用。
SUB moni(message$,count), callback 9
   PRINT message$;
   PLOT TEXT,AT 0.1, 0.7 :"count= "&STR$(count)
END SUB

END

!注意：十進BASICの Ver7.2.0 以降 のバージョンが必要です。
 		 

Re: 助けて下さい。

 投稿者：GAI  投稿日：2008年11月18日(火)10時38分17秒 		返信・引用
  > No.91[元記事へ]

荒田浩二さんへのお返事です。

>
>   行数     実行時間   調査回数     解
>   k=2 --->   0.03 秒         2 回   2個
>   k=3 --->   0.08 秒        30 回   4個
>   k=4 --->   0.14 秒      1008 回   4個
>   k=5 --->   2.05 秒     60060 回   1個
>   k=6 ---> 192.16 秒   5581440 回   0個 (2進モードで100.20秒)
>   k=7 ---> 未調査    745945200 回   ?個 (2進モードでも4時間近くか?)
>   k=8 ---> 未調査 135566323200 回   ?個

前回ｋ＝５で丸一日でも計算途中と終了せずになっていたものが、
今回のプログラムで4.28秒（なんという短時間）で結果が出てきました。
６万回以上のチェックがこんな短時間になされているなんて、おいらの頭はなんなんだ！
プログラム一つでこうも違うことになるとは、プログラムの世界も奥深いですね。 		 

Re: 機械語で速度を上げたが

 投稿者：GAI  投稿日：2008年11月18日(火)10時44分11秒 		返信・引用
  > No.92[元記事へ]

SECONDさんへのお返事です。

機械語？？？
私には、このプログラムをどう使ったらよいのか検討もつきません。
一応コピーをしてＢＡＳＩＣ上で走らせましたが、何かのファイルが読めませんと返事が返ってきました。
これを使うにはどうしたらよいか教えて下さい。 		 

mat命令と複素数表示

 投稿者：大熊　正  投稿日：2008年11月18日(火)11時28分38秒 		返信・引用
  最近10進BASICのブルーバックスの本を購入、その虜になってます。
所で、電気関係では、4端子網をマトリクス[A,B,C,D]表示します。10進BASICのMAT文に複素表示の値を入れて計算させるには、どうしたら よいでしょうか。A=5＋3i B=4-6i C=7+2i D=2-3iなどと入れたら[実数でないと駄目]と拒否されました。また複素数表示のMATの積や逆行列、等もどうするのでしょうか。 		 

Re: 助けて下さい。

 投稿者：山中和義  投稿日：2008年11月18日(火)11時41分45秒 		返信・引用
  > No.93[元記事へ]

GAIさんへのお返事です。

> プログラム一つでこうも違うことになるとは、プログラムの世界も奥深いですね。


今回紹介されたプログラムは以下の手法を用いています。

・モンテカルロ法
　ランダムに数字を埋めて条件に合うか確認する。
　確率ですから、「偶然にみつかる」を期待する。
　→荒田浩二さんの１回目

・バックトラック法
　順列や組合せによる数字を発生して、条件に合うように順に数字を埋めていく。（今回は下から）
　枝刈り効果（矛盾発生以降は対象外とする処理）を期待する。（検証回数が減る）
　→私の１回目

・「場合の数」法
　問題に応じた「場合の数」を、順列や組合せを考えて最小回数の検証を行う。
　→荒田浩二さんの２回目
　→私の２回目


プログラミングは、コーディング（言語による表現）より、
アルゴリズム（解き方）を検討するのが主だと思います。 		 

Re: mat命令と複素数表示

 投稿者：山中和義  投稿日：2008年11月18日(火)11時55分10秒 		返信・引用 　編集済
  > No.95[元記事へ]

大熊　正さんへのお返事です。


BASICの編集画面に「複素数」ボタンがあります。オンの状態で複素数の計算が可能です。
通常は、下記のようにプログラムに記述します。

２×２正方行列の各要素に値を設定するプログラム

●例１

OPTION ARITHMETIC COMPLEX !複素数を扱う

LET j=SQR(-1) !虚数単位　※電気系はｊを使う

!M=(a b)
!  (c d)
DIM M(2,2) !２×２の正方行列

LET M(1,1)=5+3*j !a
LET M(1,2)=4-6*j !b
LET M(2,1)=7+2*j !c
LET M(2,2)=2-3*j !d

MAT PRINT M;

END


●例２　※この場合はｊは必要ない

OPTION ARITHMETIC COMPLEX !複素数を扱う

!M=(a b)
!  (c d)
DIM M(2,2) !２×２の正方行列

LET M(1,1)=COMPLEX(5,3) !a
LET M(1,2)=COMPLEX(4,-6) !b
LET M(2,1)=COMPLEX(7,2) !c
LET M(2,2)=COMPLEX(2,-3) !d

MAT PRINT M;

END

複素数は、括弧付きの数字の組（実部、虚部）で表示されます。


掛け算は
  DIM A(2,2),B(2,2),C(2,2),T(2,2)
  MAT T=A*B !T=AB

  MAT T=A*B !T=ABC
  MAT T=T*C
と記述します。
加減乗は２項の演算のみですから、３項以上は２項ずつに分解した記述してください。


定数倍は、MAT T=(2)*A !T=2A
逆行列は、MAT T=INV(A) !T=A^-1
転置行列は、MAT T=TRN(A) !T=tA
行列式は、LET p=DET(A) !p=|A|
これらは１項のみです。

行列の計算には実行列と複素行列の区別はありません。 		 

Re: 機械語で速度を上げたが

 投稿者：SECOND  投稿日：2008年11月18日(火)14時14分21秒 		返信・引用 　編集済
  > No.94[元記事へ]

GAIさんへのお返事です。

> SECONDさんへのお返事です。
>
> 機械語？？？
> 私には、このプログラムをどう使ったらよいのか検討もつきません。
> 一応コピーをしてＢＡＳＩＣ上で走らせましたが、何かのファイルが読めませんと返事が返ってきました。
> これを使うにはどうしたらよいか教えて下さい。

  http://homepage2.nifty.com/neutro/asm/hojin_43.dll

この機械語ファイルを、ダウンロードして、掲示のプログラムと同じフォルダーに置くと
走ります。

※「機械語は、命令語自体を、プログラムして速度を探す世界で、
　　書き方（アルゴリズム）によって、１０倍もの速さが、同じソースで、
　　同じ数学アルゴリズムでも、違ったりもします。 		 

さいころを転がす

 投稿者：山中和義  投稿日：2008年11月18日(火)18時56分39秒 		返信・引用 　編集済
  私からも１つパズルを紹介します。

●問題
４×４の格子がある。左上をスタート、右下をゴールの位置とする。
さいころの目「１」を上にしてスタートに置き、ゴールに向けて転がす。
このとき、ゴールでの目の数が１〜６になる転がし方（経路）を求める。

経路の決め方に、重複通過、迂回、通過点などの制限を設けてもよい。


シミュレータをつくって確認してみました。他にもあると思います。

!「さいころの回転」のシミュレーション

!置換（Permutation）の計算
SUB PermPrintOut(A()) !表示する
   MAT PRINT USING(REPEAT$(" ##",UBOUND(A))): A;
   PRINT
END SUB
SUB PermIdentity(A()) !恒等置換
   FOR i=1 TO UBOUND(A)
      LET A(i)=i
   NEXT i
END SUB
SUB PermInverse(A(), iA()) !逆置換　※iAはA以外の配列を指定すること
   FOR i=1 TO UBOUND(A)
      LET iA(A(i))=i
   NEXT i
END SUB
SUB PermMultiply(A(),B(), AB()) !積AB　※ABはAかつB以外の配列を指定すること
   LET ua=UBOUND(A)
   LET ub=UBOUND(B)
   IF ua=ub THEN
      FOR i=1 TO ua
         LET AB(i)=A(B(i)) !※合成写像(AB)(i)=A(B(i))
      NEXT i
   ELSE
      PRINT "次元が違います。A=";ua;" B=";ub
      STOP
   END IF
END SUB
!-------------------- ここまでがサブルーチン


LET N=6

!展開図の配置と面番号（配列の添え字）との関係
!　□　　　　後　　　　１
!□□□□　左上右下　２３４５
!　□　　　　正　　　　６

!---------- ↓↓↓↓↓ ----------
DIM A(N)
DATA 5,4,1,3,6,2 !目の配置　※展開図参照
MAT READ A

!LET s$="DRDRDR" !手順 1
!LET s$="RRRDDD" !手順 2
!LET s$="RRDDDR" !手順 3
!LET s$="RRDRDD" !手順 4
!LET s$="RDDDRR" !手順 5
LET s$="RDLDRRRD" !手順 6
!---------- ↑↑↑↑↑ ----------


DIM U(N),D(N),L(N),R(N) !置換
!    1,2,3,4,5,6
DATA 3,2,6,4,1,5 !上　※正面を上面にするの（図での水平軸）回転
!!!DATA 5,2,1,4,6,3 !下
DATA 1,3,4,5,2,6 !左
!!!DATA 1,5,2,3,4,6 !右

MAT READ U
CALL PermInverse(U,D)
!!!MAT READ D
MAT READ L
CALL PermInverse(L,R)
!!!MAT READ R


SET WINDOW -1,5,5,-1 !表示領域
DRAW grid !格子

DIM T(N),TT(N) !作業配列
LET x=0.5 !左上
LET y=0.5

MAT T=A !初期状態を表示する
CALL disp(T)

FOR k=1 TO LEN(s$) !スクリプトを実行する

   PLOT LINES: x,y; !経路の結線　始点

   SELECT CASE UCASE$(s$(k:k)) !各方向へ
   CASE "U","N"
      CALL PermMultiply(T,U,TT)
      LET y=y-1
   CASE "D","S"
      CALL PermMultiply(T,D,TT)
      LET y=y+1
   CASE "L","W"
      CALL PermMultiply(T,L,TT)
      LET x=x-1
   CASE "R","E"
      CALL PermMultiply(T,R,TT)
      LET x=x+1
   CASE ELSE
   END SELECT
   MAT T=TT !次へ

   PLOT LINES: x,y; !終点

   CALL disp(T)

NEXT k

SUB disp(T()) !現在の状態を表示する
   CALL PermPrintOut(T)

   LET nm=T(3) !グラフィックスによる
   IF nm=1 THEN !中央
      DRAW eye(4) WITH SHIFT(x,y)
   END IF
   IF nm=3 OR nm=5 THEN
      DRAW eye(1) WITH SHIFT(x,y)
   END IF
   IF nm=2 OR nm=4 OR nm=5 OR nm=6 THEN !左斜め
      DRAW eye(1) WITH SHIFT(x+0.25,y+0.25)
      DRAW eye(1) WITH SHIFT(x-0.25,y-0.25)
   END IF
   IF nm=3 OR nm=4 OR nm=5 OR nm=6 THEN !右斜め
      DRAW eye(1) WITH SHIFT(x+0.25,y-0.25)
      DRAW eye(1) WITH SHIFT(x-0.25,y+0.25)
   END IF
   IF nm=6 THEN !中段
      DRAW eye(1) WITH SHIFT(x+0.25,y)
      DRAW eye(1) WITH SHIFT(x-0.25,y)
   END IF

   !!!SET TEXT JUSTIFY "center","half"
   !!!PLOT TEXT ,AT x,y: STR$(T(3))
END SUB

PICTURE eye(c) !目の１つを表示する
   SET AREA COLOR c
   DRAW disk WITH SCALE(0.1)
END PICTURE

END
 

> No.95[元記事へ]

 投稿者：大熊　正  投稿日：2008年11月18日(火)19時03分13秒 		返信・引用
  早速の御回答有難うございます。
早速明日から、色々やって見ます。
こんなに簡単に複素数のMATガできるなら、ますます10進BASICにはまりそうです。
中山様　有難うございました。 		 

動きました。

 投稿者：GAI  投稿日：2008年11月19日(水)06時55分25秒 		返信・引用
  > No.98[元記事へ]

SECONDさんへのお返事です。

言われたように、ダウンロードし同じフォルダーに入れたら走りだしました。
だいたい３時間程度で全パターンの組み合わせの調査を済ませ、どの組み合わせも
オイラー方陣の用件を満たさない報告がなされました。
調査総数が４千万を超えるものがあるのを、最初に証明した人はコンピューターの
道具がない時代にいったいどうやって調べたというのでしょうか？
最初オイラーさんも１万通り位は挑戦したでしょうがとても全パターンまではやってみようとは思わなかったでしょうね。
そこで、一般には４k＋２　（k=0,1,2,3,・・・）
の場合には存在しないだろうと予想を立てたのでしょう。（１７８２年）
それから、約２００年オイラーさんの言葉が信じられていた。
しかし、ｋ＝２（１０次のオイラー方陣）が

00 47 18 76 29 93 85 34 61 52
86 11 57 28 70 39 94 45 02 63
95 80 22 67 38 71 49 56 13 04
59 96 81 33 07 48 72 60 24 15
73 69 90 82 44 17 58 01 35 26
68 74 09 91 83 55 27 12 46 30
37 08 75 19 92 84 66 23 50 41
14 25 36 40 51 62 03 77 88 99
21 32 43 54 65 06 10 89 97 78
42 53 64 05 16 20 31 98 79 87


00 17 28 39 94 85 76 61 52 43
71 22 37 48 59 96 80 13 04 65
82 73 44 57 68 09 91 35 26 10
93 84 75 66 07 18 29 50 41 32
49 95 86 70 11 27 38 02 63 54
58 69 90 81 72 33 47 24 15 06
67 08 19 92 83 74 55 46 30 21
16 31 53 05 20 42 64 77 88 99
25 40 62 14 36 51 03 89 97 78
34 56 01 23 45 60 12 98 79 87


46 57 68 70 81 02 13 24 35 99
71 94 37 65 12 40 29 06 88 53
93 26 54 01 38 19 85 77 60 42
15 43 80 27 09 74 66 58 92 31
32 78 16 89 63 55 47 91 04 20
67 05 79 52 44 36 90 83 21 18
84 69 41 33 25 98 72 10 56 07
59 30 22 14 97 61 08 45 73 86
28 11 03 96 50 87 34 62 49 75
00 82 95 48 76 23 51 39 17 64

のように構成可能であることが示され、オイラーの予想が覆されました。
またｋ＝４（１８次のオイラー方陣）も


0X AB T9 W7 Z5 BT 8W 5C 2A Y8 X6 6Z 3Y 92 C3 11 40 74

BY 8X 56 T4 W2 Z0 6T 3W 07 A5 Y3 X1 1Z 4A 7B 99 C8 2C

9Z 6Y 3X 01 TC WA Z8 1T BW 82 50 YB X9 C5 26 44 73 A7

X4 4Z 1Y BX 89 T7 W5 Z3 9T 6W 3A 08 Y6 70 A1 CC 2B 52

Y1 XC CZ 9Y 6X 34 T2 W0 ZB 4T 1W B5 83 28 59 77 A6 0A

3B Y9 X7 7Z 4Y 1X BC TA W8 Z6 CT 9W 60 A3 04 22 51 85

18 B6 Y4 X2 2Z CY 9X 67 T5 W3 Z1 7T 4W 5B 8C AA 09 30

CW 93 61 YC XA AZ 7Y 4X 12 T0 WB Z9 2T 06 37 55 84 B8

AT 7W 4B 19 Y7 X5 5Z 2Y CX 9A T8 W6 Z4 81 B2 00 3C 63

ZC 5T 2W C6 94 Y2 X0 0Z AY 7X 45 T3 W1 39 6A 88 B7 1B

W9 Z7 0T AW 71 4C YA X8 8Z 5Y 2X C0 TB B4 15 33 62 96

T6 W4 Z2 8T 5W 29 C7 Y5 X3 3Z 0Y AX 78 6C 90 BB 1A 41

23 T1 WC ZA 3T 0W A4 72 Y0 XB BZ 8Y 5X 17 48 66 95 C9

80 38 B3 6B 16 91 49 C4 7C 27 A2 5A 05 XX YY ZZ WW TT

7A 25 A0 58 03 8B 36 B1 69 14 9C 47 C2 YT ZX WY TZ XW

57 02 8A 35 B0 68 13 9B 46 C1 79 24 AC ZW WT TX XY YZ

65 10 98 43 CB 76 21 A9 54 0C 87 32 BA WZ TW XT YX ZY

42 CA 75 20 A8 53 0B 86 31 B9 64 1C 97 TY XZ YW ZT WX

の様に出来ちゃいます。（こんな配列は神様しかできない。）

いやー人間の脳の力（数学の凄さ）を思い知ります。 		 

Re: 動きました。

 投稿者：SECOND  投稿日：2008年11月19日(水)17時06分33秒 		返信・引用 　編集済
  > No.101[元記事へ]

GAIさんへのお返事です。

ご報告ありがとうございます。”Ｃ”より遅かったらどうしようかと思っていました。
私のパソコンで８時間かかりますので、どうなのかが、わかりませんでした。
もっと、速い速度を研究してみます。

※2008.11.21　hojin_45.dll に取替えると、３時間→２時間２０分ぐらいになります。
  http://homepage2.nifty.com/neutro/asm/hojin_45.dll    ・・・変更した機械語ファイル
  http://homepage2.nifty.com/neutro/asm/hojin_45.asm    ・・・上のソース･リスト
  http://homepage2.nifty.com/neutro/asm/HOJIN_45.BAS    ・・・assign修正、十進BASICファイル
　.asm や.BASファイルは、
　ダウン・ロード窓が出ず、化け文字で開くことが有ります。その場合は、
　「表示」→「エンコード」→「日本語(シフトJIS)」にして、
　「すべて選択」コピー・ペーストして下さい。（メモ帳などに） 		 

２端子対定数（４端子定数）の計算

 投稿者：山中和義  投稿日：2008年11月20日(木)13時40分22秒 		返信・引用
  電気回路計算の演習問題を解いています。
電卓による筆算の検算としてのプログラムをつくってみました。

以前苦労したラダー回路の合成抵抗値が「Ｆ行列の積」と「Ｚへの変換」で算出できます。
!２端子対回路（４端子回路）
!　i1→┌──┐i2→
!　a ─┤A　B├─ b
!E1↑　│　　│　↑E2
!　a'─┤C　D├─ b'
!　　　└──┘
!基本行列Fを用いて
! (E1)=(A B)(E2)
! (i1) (C D)(i2)

OPTION ARITHMETIC COMPLEX !複素数を扱う

LET j=SQR(-1) !虚数単位　※電気系はｊを使う

!●交流回路

LET f=60 !周波数[Hz]
LET w=2*PI*f !角周波数ω

DEF H2Ohm(L)=j*w*L ![H]を[Ω]へ
DEF F2Ohm(C)=1/(j*w*C) ![F]を[Ω]へ
DEF xL(L)=w*L !誘導リアクタンス
DEF xC(C)=1/(w*C) !容量リアクタンス

SUB DispS(z) !複素数をS表示する　※スタインメッツ（Steinmetz）
   PRINT ABS(z);
   IF ABS(z)<>0 THEN
      IF arg(z)<>0 THEN PRINT "∠";DEG(arg(z));"°";
   END IF
   PRINT
END SUB

FUNCTION S2COMPLEX(l,th) !S表示（極座標形式）を複素数へ
   LET S2COMPLEX=COMPLEX(l*COS(RAD(th)),l*SIN(RAD(th)))
END FUNCTION


!●２端子インピーダンス回路行列
!　─Z─　の場合　F=(1 Z)
!　─-─　　　　　　(0 1)
SUB seriesF(Z,F(,))
   LET F(1,1)=1
   LET F(1,2)=Z
   LET F(2,1)=0
   LET F(2,2)=1
END SUB
!　─┬─　の場合　F=(1　 0)
!　　Z 　　　　　　　(1/Z 1)
!　─┴─
SUB shuntF(Z,F(,))
   WHEN EXCEPTION IN
      LET F(1,1)=1
      LET F(1,2)=0
      LET F(2,1)=1/Z
      LET F(2,2)=1
   USE
      PRINT "０で割れません。"
      STOP
   END WHEN
END SUB

!●パラメータの相互変換　※一部
SUB F2Z(F(,), Z(,)) !ＦパラメータをＺパラメータへ
   LET Z(1,1)=F(1,1) !A
   LET Z(1,2)=DET(F) !AD-BC
   LET Z(2,1)=1
   LET Z(2,2)=F(2,2) !D
   WHEN EXCEPTION IN
      MAT Z=(1/F(2,1))*Z !(1/C)倍
   USE
      PRINT "Ｚパラメータは存在しません。"
      STOP
   END WHEN
END SUB
SUB F2Y(F(,),Y(,)) !ＦパラメータをＹパラメータへ
   LET Y(1,1)=F(2,2) !D
   LET Y(1,2)=-DET(F) !BC-AD
   LET Y(2,1)=-1
   LET Y(2,2)=F(1,1) !A
   WHEN EXCEPTION IN
      MAT Y=(1/F(1,2))*Y !(1/B)倍
   USE
      PRINT "Ｙパラメータは存在しません。"
      STOP
   END WHEN
END SUB

SUB Z2Y(Z(,),Y(,)) !ＺパラメータをＹパラメータへ
   WHEN EXCEPTION IN
      MAT Y=INV(Z) !Y=Z^-1
   USE
      PRINT "Ｙパラメータは存在しません。"
      STOP
   END WHEN
END SUB
!-------------------- ここまでがサブルーチン


DIM mF(2,2),mZ(2,2),mY(2,2) !F,Z,Yパラメータ
DIM T1(2,2),T2(2,2) !作業用

!●はしご回路の合成抵抗　a-b端子間

!a─R1┬R3┬R5┬ … ┬Rn┬─┬ …
! 　　R2　R4　R6　 Rn-1 Rn+1
!b──┴─┴─┴ 　 ┴─┴─┴
!
LET R1=1 !1,2,1,2,…,1,2,1
LET R2=2

CALL seriesF(R1,T1) !─R1┬
CALL shuntF(R2,T2)  !　　R2

MAT mF=IDN !単位行列
FOR i=1 TO 5 !段数
   MAT mF=mF*T1 !─R1┬R1┬ … ┬R1┬
   MAT mF=mF*T2 !　 R2　R2　　 R2　R2
NEXT i
MAT mF=mF*T1 !─R1┐

CALL F2Z(mF,mZ) !要素a
MAT PRINT mZ;



!●T型LC回路
!　─L─┬─L─
!　　　 C
!　─-─┴─-─
!ω=1[rad/sec]、L=2[H]、C=1[F]
LET L=2
LET C=1
LET w=1 !問題に合わせる


!●Ｆパラメータ、基本行列
MAT mF=IDN !単位行列

CALL seriesF(H2Ohm(L),T1)
MAT mF=mF*T1

CALL shuntF(F2Ohm(C),T2)
MAT mF=mF*T2

MAT mF=mF*T1

PRINT "Ｆパラメータ"
MAT PRINT mF;


!●Ｚパラメータ、インピーダンス行列 V=Z*I
CALL F2Z(mF,mZ)
PRINT "Ｚパラメータ"
MAT PRINT mZ;


!●Ｙパラメータ、アドミタンス行列 I=Y*V
CALL F2Y(mF,mY)
PRINT "Ｙパラメータ"
MAT PRINT mY;


!●Ｙパラメータ（別解）Y=Z^-1
CALL Z2Y(mZ,mY)
PRINT "Ｙパラメータ"
MAT PRINT mY;


END
 

mat命令と複素数計算

 投稿者：大熊　正  投稿日：2008年11月21日(金)15時11分26秒 		返信・引用
  大熊　です。

前回　NO95 NOの御回答有難うございました。山中さんを中山さんと間違えて投稿しました。失礼を御許しください。
その後だいぶ10進BASICを進めてますが、下記の不具合でストップしてます。
MAT T=INV(A)　が出来ないのです。


OPTION ARITHMETIC COMPLEX
LET j=SQR(-1)
LET R1=5000
LET R2=5000
LET C1=0.1*10^( -6 )
LET C2=0.1*10^( -6 )
LET F=100
LET SZ=0.001
LET NP=4
LET ZC1=1/(2*PI*F*C1)
LET ZC2=1/(2*PI*F*C2)
OPTION BASE 1
PRINT "ZCI=";ZC1

DIM A(NP,NP),B(NP,NP),T(NP,NP),E1(NP)

LET A(1,2)=1/R1+SZ*j
LET A(2,3)=1/R2+SZ*j
LET A(2,4)=SZ+1/ZC1*j
LET A(3,4)=SZ+1/ZC2*j
MAT PRINT A

LET E1(1)=1
LET E1(4)=0
PRINT"下記のごとくMAT PRINT E1とやると横に一文字になる。"
MAT PRINT E1
PRINT"下記のごとくMAT PRINT USING REPEAT$RIで縦に一文字並び良

好。"
MAT PRINT USING REPEAT$(" #.#### ",1):E1
MAT T=INV(A)


STOP

早速ですが、上記の文を作り、マトリクス[A]を作り実行すると、最後の　MAT T=INV(A)で
「EXTYPE 3009 引数が定義外の値」となり、ストップします。
どこが不良の原因でしょうか。
また、一列のE(5)などを作り、PRINT E 　をやると、横一列に表示します。
四端子網の　A*E 等は大丈夫でしょうか。縦に変更してT=TRAN(E) そしてA*T でしょうか。 		 

Re: mat命令と複素数計算

 投稿者：山中和義  投稿日：2008年11月21日(金)16時36分32秒 		返信・引用 　編集済
  > No.104[元記事へ]

大熊　正さんへのお返事です。

> 早速ですが、上記の文を作り、マトリクス[A]を作り実行すると、最後の　MAT T=INV(A)で
> 「EXTYPE 3009 引数が定義外の値」となり、ストップします。
> どこが不良の原因でしょうか。

行列Aが、逆行列を持たない行列だからです。
Aは筆算で逆行列は存在しますか？


> また、一列のE(5)などを作り、PRINT E 　をやると、横一列に表示します。
> 四端子網の　A*E 等は大丈夫でしょうか。縦に変更してT=TRAN(E) そしてA*T でしょうか。

DIM A(3,3)
DIM X(3),B(3)
MAT B=A*X !(3行,3列)(3行,1列)=(3行,1列)として計算される
MAT PRINT B !横へ
MAT B=X*A !(1行,3列)(3行,3列)=(1行,3列)として計算される
MAT PRINT B !横へ
END
この場合、X,Bはベクトル扱いになります。
X,Bを行列として扱う場合は、（X,Bに対してTRNを適用する場合）
行または列のみの行列は、たとえば
　３行１列なら DIM B(3,1)
　１行３列なら DIM B(1,3)
としてください。 		 

Re: 旧掲示板の投稿をキャッシュからサルベージ

 投稿者：teriam  投稿日：2008年11月21日(金)20時03分4秒 		返信・引用
  > No.34[元記事へ]

大事な情報だと思うのでご本人の了解は得てませんが再掲します。

> 十進BASICの旧掲示板が10月上旬から運営会社aroundの活動停止により事実上閉鎖されました。
> 「掲示板過去ログ」に保管されていなかった101〜110ページの投稿を検索サイトのキャッシュから拾い出す方法を紹介します。
> ただしキャッシュですから、すべてのページが保存されているわけではありません。
> 分割して投稿されたプログラムなどは、部分的にしか拾えないかもしれません。
> また、キャッシュは日々更新されますのであと1,2ヶ月もしたらほとんどのページが削除されると思います。
> 数日前と比較してもヒット数が減っています。
> 必要な投稿は早めにパソコンに保存しておくことをお勧めします。
>
>
> 1.検索サイトGoogleで "十進BASIC掲示板" を検索します。
>   (余計な情報を排除するためダブルクォテーション(")で囲みましょう)
>
> 2.検索結果の最後に、
>     最も的確な結果を表示するために、上の○○件と似たページは除外されています。
>     検索結果をすべて表示するには、ここから再検索してください。
>   とあるのでクリックして下さい。
>
> 3.検索結果のうち、URLが freebbs.around.ne.jp で始まるものが旧掲示板の投稿です。
>   /basic/ または &pg= の後ろにある数字が旧掲示板のページ番号です。
>   （URLが www.geocities.jp とあるのは「掲示板過去ログ」にあるのでそちらをご覧ください）
>
> 4.内容を見るには必ずキャッシュをクリックして下さい。
>   （見出しをクリックすると接続エラーになります）
>
> 5.下の語句からも検索できます。他の検索サイトからも検索してみて下さい。
>     "freebbs.around.ne.jp/article/b/basic/"
>
>     "freebbs.around.ne.jp/kyview","basic" 		 

Re: mat命令と複素数計算

 投稿者：SECOND  投稿日：2008年11月23日(日)07時44分19秒 		返信・引用 　編集済
  > No.104[元記事へ]

大熊　正さんへのお返事です。

> MAT T=INV(A)　が出来ないのです。

IF DET(A)<>0 THEN !　行列式｜A｜の値
   MAT T=INV(A)
ELSE
   PRINT "A は、逆行列を持たない"
END IF


※十進BASIC の、１次元配列、行ベクトルと列ベクトル

行列 (a)
┌              ┐
│ 1.000   2.000│
│ 3.000   4.000│
└              ┘
ベクトル (v1)
(  1.000   2.000 )　･･･この状態は、行か、列かが、不定になっている。

MAT v2=a*v1　･･･右へ書けば、列ベクトル v1 として計算される。
┌              ┐┌      ┐
│ 1.000   2.000││ 1.000│
│ 3.000   4.000││ 2.000│
└              ┘└      ┘
v2＝(  5.000  11.000 )

MAT v2=v1*a　･･･左へ書けば、行ベクトル v1 として計算される。
┌              ┐┌              ┐
│ 1.000   2.000││ 1.000   2.000│
└              ┘│ 3.000   4.000│
                  └              ┘
v2＝(  7.000  10.000 ) 		 

Re: mat命令と複素数計算

 投稿者：島村1243  投稿日：2008年11月23日(日)10時38分16秒 		返信・引用
  > No.104[元記事へ]

大熊　正さんへのお返事です。

> 大熊　です。
> ***中略***
> その後だいぶ10進BASICを進めてますが、下記の不具合でストップしてます。
> MAT T=INV(A)　が出来ないのです。
> ***中略***
> LET A(1,2)=1/R1+SZ*j
> LET A(2,3)=1/R2+SZ*j
> LET A(2,4)=SZ+1/ZC1*j
> LET A(3,4)=SZ+1/ZC2*j
> MAT PRINT A
> ***中略***
> 早速ですが、上記の文を作り、マトリクス[A]を作り実行すると、最後の　MAT T=INV(A)で
> 「EXTYPE 3009 引数が定義外の値」となり、ストップします。
> どこが不良の原因でしょうか。

アドミタンス行列[A]と節点法を使って、電気回路網の電流[I]=[A][E]、インピーダンス[Z]=INV(A)を計算するプログラムを作成するつもりの様ですね。
プログラム原稿を見ると、下記節点間アドミタンスが未設定であることがエラーの原因です。

未設定の節点間アドミタンス
A(2,1)!=A(1,2)
A(3,2)!=A(2,3)
A(4,3)!=A(3,4)

したがって「INV(A)」よりも前に
A(2,1)=A(1,2)
A(3,2)=A(2,3)
A(4,3)=A(3,4)

を追記すればエラーは出ません。
なお、本来は対地間アドミタンス｛A(1,1),A(2,2),A(3,3),A(4,4)｝や、アドミタンスが接続されない節点間のアドミタンスは０と 設定すべきです（本件ではBASICアプリケーションが未指定の節点間アドミタンス＝０と自動初期値設定をしてしまうのでトラブルにはなりませんが注意が 必要です）。 		 

あるシャッフル方法の規則性

 投稿者：GAI  投稿日：2008年11月23日(日)12時46分19秒 		返信・引用
  例：１から１８の番号順にカードが並んでいるとする。（裏向きトップが１）
このカード群を裏向きに持ち、上から1枚ずつ裏向きのままテーブルへ左から右へ３枚並べ
たら、元に戻って２枚目をまた左から右の山へ配る。
これを繰り返しそれぞれの山の枚数が６枚ずつになり、手持ちのカードが無くなる。
次に左の山を持ち上げ、隣の山に重ね、重なった山を持ち上げ、右の山へ重ね一つにする。
このシャッフルを繰り返すと９回繰り返した時点で、カードの順番が元に戻る。
このシャッフルの規則を調べたい（元の状態にどの条件で戻るのか）のですが、
一般にカードがｎ枚あり
山をp個（p<=nとする）作って、このシャッフルをしていく場合、何回繰り返せば元に戻るのでしょうか？
（n=7,p=3なら３回で元に戻りました。）

これを知るためのプログラムを作って貰えないでしょうか？
これを使って新作のカードマジックを作りたいのでよろしくお願いします。
ちなみに、トランプ全部５２枚の場合２山、３山、４山、・・・、１３山
での復元回数も知りたいのですが・・・ 		 

!万華鏡

 投稿者：SECOND  投稿日：2008年11月23日(日)16時05分47秒 		返信・引用
  !万華鏡

OPTION ARITHMETIC NATIVE
DIM px(12),py(12)

MAT READ px
DATA 0.20, 0.40, 0.60, 0.80, 0.70, 0.60, 0.50, 0.40, 0.30, 0.20, 0.40, 0.60
MAT READ py
DATA 0.11, 0.11, 0.11, 0.11, 0.29, 0.47, 0.65, 0.47, 0.29, 0.11, 0.11, 0.11

SET WINDOW -1/4,1/4, -1/4,1/4
!----------
LET N=3
DO
   LET s=MOD(s,36)+1
   LET s2=INT((s-1)/4)+1
   SET DRAW mode hidden
   CLEAR
   DRAW D4(N) WITH SHIFT(-0.5,-0.5/SQR(3))*ROTATE(PI*2/36*s+PI)
   SET DRAW mode explicit
   WAIT DELAY 0.2
LOOP

!------
PICTURE D4(k)
   IF 0< k THEN
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*SHIFT(1/4,SQR(3)/4) !　上
      DRAW D4(k-1) WITH SCALE(1/2,-1/2)*SHIFT(1/4,SQR(3)/4) !　中
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*ROTATE(-PI*2/3)*SHIFT(1/4,SQR(3)/4) !　左
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*ROTATE(PI*2/3)*SHIFT(1,0) !　右
   ELSE
      DRAW Set01
   END IF
END PICTURE

!------ 種の三角図
PICTURE Set01
   PLOT LINES: 0,0; 1,0 ;0.5,SQR(3)/2 ;0,0
   SET AREA COLOR 5 !2
   DRAW disk WITH SCALE(0.1)*SHIFT(px(s2),py(s2)) ! 飾り１
   SET AREA COLOR 6 !3
   DRAW disk WITH SCALE(0.1)*SHIFT(px(s2+1),py(s2+1)) ! 飾り２
   SET AREA COLOR 7 !4
   DRAW disk WITH SCALE(0.1)*SHIFT(px(s2+2),py(s2+2)) ! 飾り３
   SET AREA COLOR 1
   DRAW disk WITH SCALE(0.1)*SHIFT(px(s2+3),py(s2+3)) ! 飾り４
END PICTURE

END 		 

Re: あるシャッフル方法の規則性

 投稿者：GAI  投稿日：2008年11月24日(月)08時50分50秒 		返信・引用
  > No.109[元記事へ]

GAIさんへのお返事です。
自分へ返事を出すのも変ですが、私なりのプログラムを作って調べてみました。

！４山でのシャッフル調査
100 OPTION BASE 1
110 INPUT  PROMPT "カードの枚数は？":n
120 INPUT  PROMPT "山の数は？:４を入力しておいて下さい。":p
130 INPUT  PROMPT "シャッフル回数？":t
140
150 DIM a(n)
160 DIM b(n)
170 DIM c(n)
180 DIM d(n)
190 DIM e(n)
200 DIM f(n)
210
220 FOR i=1 TO n
230    LET a(i)=i
240 NEXT i
250
260 FOR q=1 TO t
270    FOR k=1 TO INT(n/p)
280       LET b(k)=a(p*(k-1)+1)
290       LET c(k)=a(p*(k-1)+2)
300       LET d(k)=a(p*(k-1)+3)
310       LET e(k)=a(p*(k-1)+4)
320       PRINT USING "####":b(k);
330       PRINT USING "####":c(k);
340       PRINT USING "####":d(k);
350       PRINT USING "####":e(k);
360       PRINT
370    NEXT k
380
390    FOR i=1 TO n/p
400       LET f(i)=b(n/p-i+1)
410       LET f(n/p+i)=c(n/p-i+1)
420       LET f(2*n/p+i)=d(n/p-i+1)
430       LET f(3*n/p+i)=e(n/p-i+1)
440    NEXT i
450
460    FOR i=1 TO n
470       LET a(i)=f(i)
480       PRINT ;q;"回";
490       PRINT USING "####":a(i);
500       PRINT
510    NEXT i
520
530 NEXT q
540 END
550

！３山でのシャッフル調査
100 OPTION BASE 1
110 INPUT  PROMPT "カードの枚数は？":n
120 INPUT  PROMPT "山の数は？:３を入力しておいて下さい。":p
130 INPUT  PROMPT "シャッフル回数？":t
140
150 DIM a(n)
160 DIM b(n)
170 DIM c(n)
180 DIM d(n)
190!DIM e(n)
200 DIM f(n)
210
220 FOR i=1 TO n
230    LET a(i)=i
240 NEXT i
250
260 FOR q=1 TO t
270    FOR k=1 TO INT(n/p)
280       LET b(k)=a(p*(k-1)+1)
290       LET c(k)=a(p*(k-1)+2)
300       LET d(k)=a(p*(k-1)+3)
310       !    LET e(k)=a(p*(k-1)+4)
320       PRINT USING "####":b(k);
330       PRINT USING "####":c(k);
340       PRINT USING "####":d(k);
350       !   PRINT USING "####":e(k);
360       PRINT
370    NEXT k
380
390    FOR i=1 TO n/p
400       LET f(i)=b(n/p-i+1)
410       LET f(n/p+i)=c(n/p-i+1)
420       LET f(2*n/p+i)=d(n/p-i+1)
430       !  LET f(3*n/p+i)=e(n/p-i+1)
440    NEXT i
450
460    FOR i=1 TO n
470       LET a(i)=f(i)
480       PRINT ;q;"回";
490       PRINT USING "####":a(i);
500       PRINT
510    NEXT i
520
530 NEXT q
540 END
550

カードマジックをやる上では、これ位が妥当であろう。

こうやって調べましたら次の様な結果を得ました。
             ＜３山でのシャッフル＞
トランプ枚数     正順復元回数         逆順復元回数
　　　　　6                3
　　　　　 9                4                   2
　　　　　 12               6                   3
　　　　　15               4
　　　　　18               9
　　　　　 21              10                   5
　　　　　 24              20                  10
　　　　　27               3
　　　　　30              15
　　　　　 33              16                   8
　　　　　36               9
　　　　　39               4
　　　　　42              21
　　　　　 45              22                  11
　　　　　48              21
　　　　　51               6


              ＜４山でのシャッフル＞
トランプ枚数      正順復元回数       逆順復元回数
　　　　　 8                6                  3
　　　　　12               3
　　　　　 16               4                  2
　　　　　 20               6                  3
　　　　　24               5
　　　　　28               7
　　　　　 32              10                  5
　　　　　36               9
　　　　　40               5
　　　　　44               6
　　　　　48              21
　　　　　52              13


これを眺めると以外にも混ぜているように見せかけて、元に戻すことが起こる
現象をつくることが可能であることがわかりました。
２７枚での３山か、２０枚での４山あたりが使えそうです。 		 

Re: あるシャッフル方法の規則性

 投稿者：山中和義  投稿日：2008年11月24日(月)17時07分13秒 		返信・引用 　編集済
  > No.111[元記事へ]

GAIさんへのお返事です。

> これを眺めると以外にも混ぜているように見せかけて、元に戻すことが起こる
> 現象をつくることが可能であることがわかりました。


逆置換で元に戻すことを考える。

ｎ枚ｐ山のとき、n=k*pならｎ枚ｋ山に分配・収集が考えられる。

たとえば
18枚3山の場合、各山6枚ずつ
　16,13,10,7,4,1 !山１　※上から順に
　17,14,11,8,5,2 !山２
　18,15,12,9,6,3 !山３
となる置換になる。（出題の参考例のシャッフル）
これに対して、18枚6山、各山3枚ずつ
　6,12,18 !山１
　5,11,17 !山２
　4,10,16 !山３
　3, 9,15 !山４
　2, 8,14 !山５
　1, 7,13 !山６
となる逆置換である。

この置換は、上記の置換の後に適用すると計２回で元に戻る。
カード操作は、ほぼ同じ操作で実現できる。「カードを下から順に」とか、、、


。。。と言う具合に、私も少し考えてみました。
また、逆順のときに１回で逆順させるシャッフルを行う（途中で枚数を数える振りをして、１山にカードを置いていくなど）
などの組合せで、回数とかを減らすことができますね。 		 

シャッフル法則合点！！！

 投稿者：GAI  投稿日：2008年11月24日(月)18時41分33秒 		返信・引用
  オッー！！！　ワンダフル
ｎ×ｍ枚のカードをまずｎ山に分けるシャッフルを行なった後
次はｍ山でのシャッフルをしたら、最後に枚数を確認する操作に紛れて順番を逆転してやればどの枚数でも３回の操作でフォールスシャッフルが可能という訳ですね。
これなら、枚数での正順復元回数をいちいち覚えておかなくても大丈夫だ！
４×５＝２０枚程度がいいかも！（任意の枚数でも２つ数の掛け算さえやれば済むんだ。）
数学が得意な方はどうしてこうも頭が柔軟なんだろう。
自分はある山だけに限定して思考をしてしまう・・・
たいへん参考になるアドバイスありがとうございました。 		 

mat命令と複素数計算

 投稿者：大熊　正  投稿日：2008年11月24日(月)18時50分22秒 		返信・引用
  大熊　です。
山中様、島村様、そしてSECOND様
色いろの御教授　本当に有難うございました。

その総てが、現在の私に理解できたとは、到底思ってませんが、
10進BASICが更に好きになったことは確かです。「持つべきは、
先達なり」・・・と感謝いたしております。

そこで、電気回路{A}では、コンデンサーなどのアドミッタンス
が周波数（Ｆ）特性を持ちます、更に電源[B}も同様です。

（１）マトリクス[A]の中にコンデンサーなどのアドミッタンス
　　　をスマートに入れる方法。
（２）同じく　電源のマトリクス[B}に、SIN（F,T)表示等で
　　　スマートに入れる方法。
（３）電源の周波数と大きさ、出力の関係、将来のグラフ化に
　　　備え、INV(A)*B　等とした上で更に、全体を
　　　　　FOR F=100 TO 10000 STEP 100・・「INB (A)*B」・
　　　　　・・・NEXT F
       等とやるのでしょうか、全体の方法が私にはまだ見え
　　　　てません。
（４）最終的には、片対数表のグラフ表示に成るのでしょうが、
　　　これを　　　やった、参考資料や、文献などがありまし
　　　たら御教えください。
　　　ＣＲ　一段の回路でも現在の私には、大変参考になります。
（５）実は、最終的には「有限要素法」にまでたどり着きた
　　　いのですが、　　　10進BASICでこれをやった、先達の文献
　　　などありましたら御教えください。従来の　[N88 BASIC ??]
　　　でやった参考書はあるのですが、真似してプログラムすると
　　　「文法の相違か、あちこちでつっかえ全く動かず」
　　　現在は、諦めている状況です。

「もっと、自分で苦労し、真面目にやれ」とのお叱りの言葉も
　きこえますが、なるべく早く「初歩の段階」を済ませ先に
　行きたいので　よろしく御願いします。

敬具 		 

古代生物

 投稿者：SECOND  投稿日：2008年11月25日(火)03時38分43秒 		返信・引用
  !古代生物( 再投稿コンパクト)

SET TEXT FONT "ＭＳ 明朝",12
SET TEXT BACKGROUND "OPAQUE"
SET POINT STYLE 1
!----------------
LET t$="アンモナイト"
LET N=101
LET xm=-0.63
LET ym=0.5
LET h=1.5
RANDOMIZE 19650218
SET WINDOW xm-h,xm+h, ym-h,ym+h
PLOT TEXT,AT xm+h*0.1,ym+h*0.85:t$& "    N="& USING$("###",N)
SET POINT COLOR 44
CALL fa(N, 0.4, 0.2)
beep
!----------------
LET t$="シダの葉"
LET N=19
LET xm=0.32
LET ym=0.5
LET h=0.6
RANDOMIZE 19650218
SET WINDOW xm-h,xm+h, ym-h,ym+h
DRAW axes
PLOT TEXT,AT xm+h*0.1,ym+h*0.7:t$& "    N="& USING$("###",N)
PLOT TEXT,AT xm-h*0.75, ym+h*0.85:"しばらく御待ち下さい。"
SET POINT COLOR 10
CALL fs(N, 0,0)
CALL fs(N, 0,0)
beep
PLOT TEXT,AT xm-h*0.75, ym+h*0.85:"　描画の終了　　　　　"

!------------------------------------------------------------
!　複数の縮小アファイン変換 (アンモナイト)
DEF A1x(x,y)=-0.289993*x-0.001347*y+0.593333
DEF A1y(x,y)= 0.001986*x-0.196662*y-0.32 !　p1=0.06124
DEF A2x(x,y)=-0.073058*x-0.024834*y+0.793333
DEF A2y(x,y)=-0.006353*x+0.285589*y-0.056667 !　p2=0.022236
DEF A3x(x,y)= 0.939186*x-0.218787*y-0.046667
DEF A3y(x,y)= 0.214337*x+0.958685*y+0.01 !　p3=0.916524
!------------------------------------------------------------
SUB fa(k, x,y)
   IF 0< k THEN
      CALL fa(k-1, A3x(x,y),A3y(x,y))
      IF RND< 0.0668176 THEN CALL fa(k-1, A1x(x,y),A1y(x,y))
      IF RND< 0.024261 THEN CALL fa(k-1, A2x(x,y),A2y(x,y))
   END IF
   PLOT POINTS: x,y
END SUB

!------------------------------------------------------------
! 複数の縮小アファイン変換 (シダの葉)
DEF W1x(x,y)= 0.836*x+0.044*y
DEF W1y(x,y)=-0.044*x+0.836*y+0.169 ! p1=0.4
DEF W2x(x,y)=-0.141*x+0.302*y
DEF W2y(x,y)= 0.302*x+0.141*y+0.127 ! p2=0.2
DEF W3x(x,y)= 0.141*x-0.302*y
DEF W3y(x,y)= 0.302*x+0.141*y+0.169 ! p3=0.2
DEF W4x(x,y)= 0
DEF W4y(x,y)= 0.175337*y ! p4=0.2
!------------------------------------------------------------
!確率的プロット(p1~p4)は、変形されています。
SUB fs(k, x,y)
   IF 0< k THEN
      CALL fs(k-1, W1x(x,y),W1y(x,y))
      IF RND< 0.3 THEN CALL fs(k-1, W2x(x,y),W2y(x,y))
      IF RND< 0.3 THEN CALL fs(k-1, W3x(x,y),W3y(x,y))
      IF RND< 0.3 THEN CALL fs(k-1, W4x(x,y),W4y(x,y))
   END IF
   PLOT POINTS: x,y
END SUB

END 		 

Re: mat命令と複素数計算

 投稿者：山中和義  投稿日：2008年11月25日(火)11時29分9秒 		返信・引用
  > No.114[元記事へ]

大熊　正さんへのお返事です。

> （１）マトリクス[A]の中にコンデンサーなどのアドミッタンスをスマートに入れる方法。
> （２）同じく　電源のマトリクス[B}に、SIN（F,T)表示等でスマートに入れる方法。

１要素ずつ代入文で設定するのが基本になります。
サブルーチンや関数を使って、最小限の要素を指示することも可能です。（サンプル参照）

RC回路、これでいいのでしょうか？　具体的に提示した方が問題解決が早いと思います。


> （４）最終的には、片対数表のグラフ表示に成るのでしょうが、

周波数特性のグラフですか？


> （５）実は、最終的には「有限要素法」にまでたどり着きたいのですが、

tについての微分方程式を解くということですか？


２端子対回路（４端子回路）として処理したサンプル
1000 !２端子対回路（４端子回路）
1010 !　i1→┌──┐i2→
1020 !　a ─┤A　B├─ b
1030 !E1↑　│　　│　↑E2
1040 !　a'─┤C　D├─ b'
1050 !　　　└──┘
1060 !基本行列Fを用いて
1070 ! (E1)=(A B)(E2)
1080 ! (i1) (C D)(i2)
1090
1100 OPTION ARITHMETIC COMPLEX !複素数を扱う
1110
1120 LET j=SQR(-1) !虚数単位　※電気系はｊを使う
1130
1140 !●交流回路
1150
1160 LET f=60 !周波数[Hz]
1170 DEF w=2*PI*f !角周波数ω
1180 DEF w2f=w/(2*PI) !ωからfを求める
1190
1200 DEF H2Ohm(L)=j*w*L ![H]を[Ω]へ
1210 DEF F2Ohm(C)=1/(j*w*C) ![F]を[Ω]へ
1220 DEF xL(L)=w*L !誘導リアクタンス
1230 DEF xC(C)=1/(w*C) !容量リアクタンス
1240
1250 SUB DispS(z) !複素数をS表示する　※スタインメッツ（Steinmetz）
1260    PRINT ABS(z);
1270    IF ABS(z)<>0 THEN
1280       IF arg(z)<>0 THEN PRINT "∠";DEG(arg(z));"°";
1290    END IF
1300    PRINT
1310 END SUB
1320
1330 FUNCTION S2COMPLEX(l,th) !S表示（極座標形式）を複素数へ
1340    LET S2COMPLEX=COMPLEX(l*COS(RAD(th)),l*SIN(RAD(th)))
1350 END FUNCTION
1360 FUNCTION i2COMPLEX(im,th) !瞬時値式を複素数へ　※最大値、初期位相
1370    LET i2COMPLEX=S2COMPLEX(im/SQR(2),th) !実効値、初期位相
1380 END FUNCTION
1390
1400
1410 !●基本２端子対回路
1420 !　─Z─　の場合　F=(1 Z)
1430 !　─-─　　　　　　(0 1)
1440 SUB seriesF(Z,F(,)) !直列挿入
1450    MAT F=IDN
1460    LET F(1,2)=Z !インピーダンス
1470 END SUB
1480 !　─┬─　の場合　F=(1　 0)
1490 !　　Z 　　　　　　　(1/Z 1)
1500 !　─┴─
1510 SUB shuntF(Z,F(,)) !並列挿入
1520    WHEN EXCEPTION IN
1530       MAT F=IDN
1540       LET F(2,1)=1/Z !アドミタンス
1550    USE
1560       PRINT "０では割れません。"
1570       STOP
1580    END WHEN
1590 END SUB
1600
1610 !●パラメータの相互変換　※一部
1620 SUB F2Z(F(,), Z(,)) !ＦパラメータをＺパラメータへ
1630    LET Z(1,1)=F(1,1) !A
1640    LET Z(1,2)=DET(F) !AD-BC
1650    LET Z(2,1)=1
1660    LET Z(2,2)=F(2,2) !D
1670    WHEN EXCEPTION IN
1680       MAT Z=(1/F(2,1))*Z !(1/C)倍
1690    USE
1700       PRINT "Ｚパラメータは存在しません。"
1710       STOP
1720    END WHEN
1730 END SUB
1740 SUB F2Y(F(,),Y(,)) !ＦパラメータをＹパラメータへ
1750    LET Y(1,1)=F(2,2) !D
1760    LET Y(1,2)=-DET(F) !BC-AD
1770    LET Y(2,1)=-1
1780    LET Y(2,2)=F(1,1) !A
1790    WHEN EXCEPTION IN
1800       MAT Y=(1/F(1,2))*Y !(1/B)倍
1810    USE
1820       PRINT "Ｙパラメータは存在しません。"
1830       STOP
1840    END WHEN
1850 END SUB
1860 !-------------------- ここまでがサブルーチン
1870
1880
1890 DIM mF(2,2),mZ(2,2),mY(2,2) !F,Z,Yパラメータ
1900 DIM vi(2),vo(2) !電流や電圧のベクトル
1910 DIM T1(2,2),T2(2,2) !作業用
1920
1930
1940 !●１次ＲＣ回路、直列ＲＣ回路、ローパスフィルタ
1950 !i1→　　　i2→
1960 !　─R─┬─
1970 !E1↑　 C　↑E2
1980 !　─-─┴─
1990 !i1=3*SQR(2)*SIN(377*t)[A]、R=30[Ω]、C=66.3[μF]
2000
2010 LET R=30
2020 LET C=66.3e-6
2030
2040
2050 !●Ｆパラメータ、基本行列
2060 MAT mF=IDN !単位行列
2070
2080 CALL seriesF(R,T1)
2090 MAT mF=mF*T1 !縦続接続
2100
2110 CALL shuntF(F2Ohm(C),T2)
2120 MAT mF=mF*T2
2130
2140 PRINT "Ｆパラメータ"
2150 MAT PRINT mF;
2160
2170
2180 !●Ｚパラメータ、インピーダンス行列 V=Z*I
2190 CALL F2Z(mF,mZ)
2200 PRINT "Ｚパラメータ"
2210 MAT PRINT mZ;
2220
2230
2240 !●(E1)=[F](E2)より
2250 !　(i1)　　(i2)
2260 LET vi(2)=i2COMPLEX(3*SQR(2),0) !3[A}
2270 PRINT "i1=";
2280 CALL DispS(vi(2))
2290 LET vi(1)=mZ(1,1)*vi(2) !E=R*i、150∠-53.1°[V]
2300 PRINT "E1=";
2310 CALL DispS(vi(1))
2320 PRINT
2330
2340 MAT T1=INV(mF) !出力側を算出する
2350 MAT vo=T1*vi
2360
2370 PRINT "E2=";
2380 CALL DispS(vo(1))
2390 PRINT "i2=";
2400 CALL DispS(vo(2))
2410 PRINT
2420
2430
2440 !●Ｙパラメータ、アドミタンス行列 I=Y*V
2450 CALL F2Y(mF,mY)
2460 PRINT "Ｙパラメータ"
2470 MAT PRINT mY;
2480
2490
2500 END
 

レス、遅くなりました。

 投稿者：NINA  投稿日：2008年11月25日(火)23時07分41秒 		返信・引用
  荒田様、山中様、親切なご説明ありがとうございました！！

お二人のおかげで、十進BASICのすごさがわかったような気がします。
そして、自分の勉強不足も…。
これを機に、十進BASICを少しでも使えるように勉強したいと思います。


返事が遅くなったこと、連名でのお返事本当に申し訳ありません。
ありがとうございました。 		 

Re: mat命令と複素数計算

 投稿者：山中和義  投稿日：2008年11月26日(水)08時19分38秒 		返信・引用 　編集済
  > No.114[元記事へ]

大熊　正さんへのお返事です。
> （１）マトリクス[A]の中にコンデンサーなどのアドミッタンスをスマートに入れる方法。
> （２）同じく　電源のマトリクス[B}に、SIN（F,T)表示等でスマートに入れる方法。

節点電位法によるサンプルです。
以前第１掲示板に投稿した直流回路の改修版になります。
1000 !電気回路シミュレーション（節点電位法）　交流回路
1010
1020 !・各節点の電位を表示する
1030 !・各素子への電流、電位を表示する
1040
1050 OPTION ARITHMETIC COMPLEX
1060
1070 LET j=SQR(-1) !虚数単位　※電気系はｊを使う
1080
1090 LET f=60 !周波数[Hz]
1100 DEF w=2*PI*f !角周波数ω
1110
1120 DEF H2Ohm(L)=j*w*L ![H]を[Ω]へ
1130 DEF F2Ohm(C)=1/(j*w*C) ![F]を[Ω]へ
1140 DEF xL(L)=w*L !誘導リアクタンス
1150 DEF xC(C)=1/(w*C) !容量リアクタンス
1160
1170 SUB DispS(z) !複素数をS表示する　※スタインメッツ（Steinmetz）
1180    PRINT ABS(z);
1190    IF ABS(z)<>0 THEN
1200       IF arg(z)<>0 THEN PRINT "∠";DEG(arg(z));"°";
1210    END IF
1220    !PRINT
1230 END SUB
1240
1250 FUNCTION S2COMPLEX(l,th) !S表示（極座標形式）を複素数へ
1260    LET S2COMPLEX=COMPLEX(l*COS(RAD(th)),l*SIN(RAD(th)))
1270 END FUNCTION
1280 FUNCTION i2COMPLEX(im,th) !瞬時値式を複素数へ　※最大値、初期位相
1290    LET i2COMPLEX=S2COMPLEX(im/SQR(2),th) !実効値、初期位相
1300 END FUNCTION
1310 !-------------------- ここまでがサブルーチン
1320
1330 !---------- ↓↓↓↓↓ ----------
1340 LET Ns=0 !電圧源の数
1350 LET Nd=3 !節点の数
1360 !---------- ↑↑↑↑↑ ----------
1370
1380 LET N=Nd+Ns
1390
1400 !●キルヒホッフの電流則より、節点方程式を組み立てる
1410 DIM A(N,N),x(N),b(N) !連立方程式 Ax=b
1420 MAT A=ZER
1430 MAT b=ZER
1440
1450
1460 DIM el_tmp$(100),ev_tmp(100),nd1_tmp(100),nd2_tmp(100) !素子の属性
1470 LET K=0
1480
1490 SUB AddElements(el$,ev,nd1,nd2) !回路を記録する
1500    LET K=K+1 !連番で回路を記録する　※注意. 方程式の成分番号と一致しない
1510    LET el_tmp$(K)=el$
1520    LET ev_tmp(K)=ev
1530    LET nd1_tmp(K)=nd1
1540    LET nd2_tmp(K)=nd2
1550
1560
1570    !連立方程式を組み立てる
1580    ! ┌　 │　 ┐┌　┐ ┌　┐
1590    ! │Ｇ │±1││V │=│I │
1600    !───┼─────────
1610    ! │±1│-Zp││Ip│ │Ep│
1620    ! └　 │　 ┘└　┘ └　┘
1630
1640    SELECT CASE UCASE$(el$(1:1)) !素子に応じて
1650    CASE "V" !電圧源なら
1660       LET p=VAL(el$(2:LEN(el$)))+Nd !番号を得る
1670       LET A(nd1,p)=A(nd1,p)-1 !電流Ipが節点iから節点jへ流れたとして、(Vi-Vj)-Ip*Zp=Ep
1680       LET A(p,nd1)=A(p,nd1)-1
1690       LET A(nd2,p)=A(nd2,p)+1
1700       LET A(p,nd2)=A(p,nd2)+1
1710       LET A(p,p)=A(p,p)+0 !内部抵抗Zpは０とする
1720       LET b(p)=b(p)+ev !起電力
1730
1740    CASE "I" !電流源なら
1750       LET b(nd1)=b(nd1)-ev
1760       LET b(nd2)=b(nd2)+ev
1770
1780    CASE ELSE !素子なら
1790       LET Gij=1/ev
1800       !対角成分　※節点に接続された素子（アドミタンス）の和
1810       LET A(nd1,nd1)=A(nd1,nd1)+Gij
1820       LET A(nd2,nd2)=A(nd2,nd2)+Gij
1830       !その他の成分　※節点に接続された素子（アドミタンス）に-1をかけたものの和
1840       LET A(nd1,nd2)=A(nd1,nd2)-Gij
1850       LET A(nd2,nd1)=A(nd2,nd1)-Gij
1860
1870    END SELECT
1880 END SUB
1890 !-------------------- ここまでがサブルーチン
1900
1910 !---------- ↓↓↓↓↓ ----------
1920
1930 !●回路図　※１次ＲＣ回路、直列ＲＣ回路、ローパスフィルタ
1940 !　─２─R1─３─
1950 !　　│　　　│
1960 !　　i3　　　C2
1970 !　　│　　　│
1980 !　─１───┴─
1990 !　　│
2000 !　　≡アース
2010 !　i3=3*SQR(2)*SIN(377*t)[A]、R1=30[Ω]、C2=66.3[μF]
2020
2030 !素子: Rn,Vn,In、n:番号（連番）　※２文字目以降は番号
2040 !値:
2050 !端子番号（起点）: １以上の値　※節点
2060 !端子番号: １以上の値　※節点
2070
2080 CALL AddElements("R1",30,2,3) !30[Ω]、枝路電流は2→3と仮定する
2090 CALL AddElements("C2",F2Ohm(66.3e-6),3,1) !C=66.3[μF]
2100 CALL AddElements("i3",i2COMPLEX(3*SQR(2),0),1,2) !3[A]
2110
2120 !※電圧源の番号は１からの連番　例. CALL AddElements("V1",?,?,?) !?[V]
2130 !なし
2140
2150 LET GND=1 !※アース
2160
2170 !---------- ↑↑↑↑↑ ----------
2180
2190
2200 FOR i=1 TO Nd !結線されていない節点　1*Vi=0
2210    IF A(i,i)=0 THEN LET A(i,i)=1
2220 NEXT i
2230 LET A(GND,GND)=0 !電位を０とする
2240
2250 MAT PRINT A;
2260 MAT PRINT b;
2270
2280
2290 DIM Ai(N,N) !連立方程式を解く
2300 MAT Ai=INV(A)
2310 MAT x=Ai*b
2320
2330
2340 FOR i=1 TO Nd !各節点の電位、流れ込む電流を表示する
2350    PRINT "節点";STR$(i);":";
2360    CALL DispS(x(i))
2370    PRINT "[V] ,";
2380    CALL DispS(b(i))
2390    PRINT "[A]"
2400 NEXT i
2410 PRINT
2420
2430 FOR i=1 TO K-Ns !各素子に流れる電流、電位を表示する
2440    PRINT el_tmp$(i);":";
2450    LET t$=el_tmp$(i)(1:1)
2460    IF UCASE$(t$)="I" THEN !電流源なら
2470       CALL DispS(ev_tmp(i))
2480       PRINT "[A]",
2490       CALL DispS(x(nd2_tmp(i))-x(nd1_tmp(i)))
2500       PRINT "[V]"
2510    ELSE
2520       CALL DispS((x(nd1_tmp(i))-x(nd2_tmp(i)))/ev_tmp(i))
2530       PRINT "[A]",
2540       CALL DispS(x(nd1_tmp(i))-x(nd2_tmp(i)))
2550       PRINT "[V]"
2560    END IF
2570 NEXT i
2580 PRINT
2590
2600 FOR i=1 TO Ns !電圧源に流れる電流、電位を表示する
2610    PRINT el_tmp$(K-Ns+i);":";
2620    CALL DispS(x(Nd+i))
2630    PRINT "[A]",
2640    CALL DispS(ev_tmp(K-Ns+i))
2650    PRINT "[V]"
2660 NEXT i
2670
2680
2690 END
 

(無題)

 投稿者：大熊　正  投稿日：2008年11月26日(水)12時16分55秒 		返信・引用
  山中様
大熊です。毎回、御丁寧な回答を有難うございます。
総てをまだ理解できないでいますが、SUB命令のスタイルなどを
一辺に覚えました。

所で、御回答で気になることがあるので質問いたします。

（１）　電流でやってますが、そのため　E1に位相が付いています。
　　　　周波数特性（ボード線図）などでは、
        E1 100Vで位相0度を加えると　E2 I2 、そして最後にI1
　　　　はどうか・・・・。
　　　　のように逆に成ると思います。電圧と電流の比例関係から
　　　　E1の結果を単純に逆計算、E1を100Vに直し、E1の位相を
　　　　E2に加減するという事になるのでしょうか。

（２）　1090 LET f=60 !周波数
　　　　となってますが、周波数特性（ボード線図）などでは、
　　　　周波数　ｆ＝１０　から　１００００まで
　　　　等と成ります。
　　　　下に　DATA　文を付け、READ DATA 等とやるのでしょうか。
　　　　周波数を　DIM FF(ｆの指定,1)
        出力も　　DIM EE2(出力の格納,1)
　　　　等とやると、可能とおもいますが、いかがでしょうか。


（３）　例えば、このローパスフィルターが5段つずいたら、
　　　　Ｆ行列を5乗するのですか、
　　　　其の時　(A)^5 でしょうか。または、FOR --NEXTですか。


（４）　私の「有限要素法」とは、・・・熱とか、磁気や電位の表示で
　　　　たとえば、楕円形の板が在ったとき、その形状を小さな三角▽に
　　　　分割し、連立方程式を立てる。・・・時間tにも関係します。
　　　　楕円の板のA(X,Y)に100度を加えると他の部分A(P,Q)の温度は
        どうなるか,・・・また、それを色で表示せよ・・・。
　　　　時間的にはどうか・・・・と言ったような問題です。
　　　　実は、無料のソフトがあるようなのですが、「リナックス」とか
　　　　で作られ、総ての問題に対しまだ今は、完全には完成出来てない
　　　　と聞きました。N88でのソフトに,近い問題のソフト例があり
　　　　また昔ですが、本（￥2,300)も出ています。
　　　　「BASICによる　有限要素法の基礎」戸川 隼人　サイエンス社
　　　　これは、マトリクスで解いていません。従ってソフトの見通し
　　　　が悪く、この部分は一体何をしてるのか良く分らない・・・
　　　　という欠点があります。マトリクスと複素数の両方ができる
　　　　10進BASICなら、それが可能で、あるいはもう既に出来てる
　　　　のかと思い質問・投稿しました。

（５）　脱線ですが、この投稿欄に機械語のことがありました。SECOND様
　　　　このソフトは万能で、たとえば、今回のローパスフィルタでも
　　　　其のソフトのある同じホルダーにおけば、動作可能なのですか。 		 

Re: (無題)

 投稿者：山中和義  投稿日：2008年11月26日(水)13時42分16秒 		返信・引用 　編集済
  > No.119[元記事へ]

大熊　正さんへのお返事です。


>（１）　電流でやってますが、そのため　E1に位相が付いています。
>
>（２）　1090 LET f=60 !周波数
>　　　　となってますが、周波数特性（ボード線図）などでは、
>　　　　周波数　ｆ＝１０　から　１００００まで　等と成ります。

fのFOR 〜NEXT文で毎回計算し直せばいいかと思います。
繰り返し部分をサブルーチン化するとプログラムの見通しが良くなると思います。


例.

※サブルーチン部分は省略
DIM mF(2,2),mZ(2,2) !F,Zパラメータ
DIM vi(2),vo(2) !電流や電圧のベクトル
DIM T1(2,2),T2(2,2) !作業用

!●１次ＲＣ回路、直列ＲＣ回路、ローパスフィルタ、積分回路
!i1→　　　i2→
!　─R─┬─
!E1↑　 C　↑E2
!　─-─┴─
!E1=5[V]、R=1k[Ω]、C=0.1[μF]

LET R=1e3
LET C=0.1e-6

SUB routine
!※Ｆパラメータ、基本行列
   MAT mF=IDN !単位行列
   CALL seriesF(R,T1) !縦続接続
   MAT mF=mF*T1
   CALL shuntF(F2Ohm(C),T2)
   MAT mF=mF*T2


   !※Ｚパラメータ、インピーダンス行列 V=Z*I
   CALL F2Z(mF,mZ)


   !※(E1)=[F](E2)より
   !　(i1)　　(i2)
   LET vi(1)=5 !5[V]
   LET vi(2)=vi(1)/mZ(1,1) !i=V/R、?[A]

   MAT T1=INV(mF) !出力側を算出する
   MAT vo=T1*vi
END SUB


SET bitmap SIZE 800,400 !画面を横長へ
!※２SET bitmap SIZE 300,600 !画面を横長へ
SET WINDOW -1,6, -1,2 !表示領域
!※２SET WINDOW -1,6, -91,1 !表示領域
!※３SET WINDOW -1,6, -20,1 !表示領域
DRAW grid !目盛り

FOR f=1 TO 6 !ｘ軸が対数
   PLOT TEXT ,AT f-0.3,-0.15: mid$("10  100 1k  10k 100k1M  ",4*(f-1)+1,4)
NEXT f
FOR f=10 TO 100000 STEP 100 !周波数[Hz]
   CALL routine

   LET vv=vo(1)/vi(1)
   PLOT LINES: LOG10(f),ABS(vv); !振幅特性
   !※２PLOT LINES: LOG10(f),DEG(ATN(Im(vv)/Re(vv))); !位相θ
   !※３PLOT LINES: LOG10(f),20*LOG10(ABS(vv)); !利得[dB]
NEXT f


END



>（３）　例えば、このローパスフィルターが5段つずいたら、

行列のべき乗はMAT文では記述できませんので、FOR〜NEXT文で乗算を繰り返します。


例.
!●はしご回路の合成抵抗　a-b端子間

!a─R1┬R3┬R5┬ … ┬Rn┬ …
! 　　R2　R4　R6　 Rn-1 Rn+1
!b──┴─┴─┴ 　 ┴─┴
!
LET R1=1 !1,2,1,2,…,1,2,1
LET R2=2

CALL seriesF(R1,T1) !─R1┬
CALL shuntF(R2,T2)  !　　R2

MAT mF=IDN !単位行列
FOR i=1 TO 5 !段数
   MAT mF=mF*T1 !─R1┬R1┬ … ┬R1┬
   MAT mF=mF*T2 !　 R2　R2　　 R2　R2
NEXT i
MAT mF=mF*T1 !─R1┐

PRINT "Ｆパラメータ"
MAT PRINT mF;
 

Re: (無題)

 投稿者：SECOND  投稿日：2008年11月26日(水)18時25分24秒 		返信・引用
  > No.119[元記事へ]

大熊　正さんへのお返事です。

> （５）　脱線ですが、この投稿欄に機械語のことがありました。SECOND様
> 　　　　このソフトは万能で、たとえば、今回のローパスフィルタでも
> 　　　　其のソフトのある同じホルダーにおけば、動作可能なのですか。


機械語について、あやまった御理解が、見受けられますが、私のカン違いかも知れません。
その場合は、以下、聞き流してください。

機械語は、アセンブラー(Assembler) とも呼ばれ、その昔、BASIC も Ｃ言語も無かった時代に、
最初に有った言語、即ち、ＣＰＵ、プロセッサが、直接認識できる、唯一の言語です。

機械語は１６進コードそのもので見づらい。
そこで、mov ax,1234h とか、push ax などの、シンボルを、１対１で機械語に、対応させて、
見やすくしたものを、アセンブラー言語 と呼んでいます。

十進 BASIC.EXE 本体は、その記述を、機械語に翻訳するための「システム言語プログラム」
という事です。その他の方面の言語なども全て、同様です。

最終的に、機械語にならないと、ＣＰＵは、認識、実行できません。

-------------------------------------------------------------------
投稿した機械語は、本来、BASIC.EXE が、翻訳する文の一部を、
手で、直接に翻訳代行したものと言えます。

なぜ、そんな事をしたのかと、いうのは、
翻訳の冗長性を外したり、高速のための書き方、追求でした。
ご質問の件は、ご推察されるとおりで、専用に書き直さないと、使用できません。 		 

周波数プログラム

 投稿者：大熊　正  投稿日：2008年11月27日(木)15時48分15秒 		返信・引用
  山中様　　　大熊です。
周波数のプログラムを有難うございました。
サブルーチンにつなげたら直ぐ軽快に動きました。

（１）最後のＤＢ表示の＃３と位相表示の＃２のグラフ
　　　を一緒に表示したいのですが、
　　　今のままで、「！」マークを外し、そのまま
　　　つなげても動きませんでした。
　　　ＤＢの縦目盛りは左側に、位相の0−90度目盛りは
　　　右側にといった具合です。
　　　こうすると、本にある「ボード線図」ずばりに
　　　なります。


（２）位相表示は、なにか周波数の文字の上が表示されて
　　　ません。
　　　私の　バージョンは、VER 5.02　ですが、
　　　最新はVER 7.2.8 のようです。
　　　これが原因でしょうか。
　　　私は、ハードデスクの「Ｄ」に本「ブルーバックス」
　　　に添付のＣＤ　ROM を指示に従い展開したのですが、
　　　インターネット上の「（仮称）10進BASIC」にある
　　　VER 7.2.8 のを、そのまま同じ「フォルダー」に
　　　コピー「展開？｝したら駄目でしょうか。
　　　前のVER 5.02 は、この本のサンプルも一緒に
　　　入ってるのでどこまでがVER 5.02 本体なのか
　　　分らずVER 5.02 だけ消すのは困難なのです。

　　　VER 5.02をVER 7.2.8 で上書きするのはどう
　　　するのですか。

（３）突然ですが、同じ行数と列数のMATには、
       固有値成るものが、あるそうですが、
　　　この 		 

周波数特性　続き　大熊

 投稿者：大熊　正  投稿日：2008年11月27日(木)15時55分50秒 		返信・引用
  山中　様　　大熊です。
確認のつもりが間違って投稿を押してしまいました。



（３）突然ですが、同じ行数と列数のMATには、
       固有値なるものが、あるそうですが、
　　　 この命令語は単独で在るのでしょうか。
　　　または、此れを解いて表示するプログラム
　　　があれば御教えください。



　敬具 		 

リラックス

 投稿者：SECOND  投稿日：2008年11月27日(木)19時09分8秒 		返信・引用 　編集済
  !４つの振り子（再投稿 失われたログ）

!２重振子Chaos
LET g= 9.8 !m/s^2
LET m1=0.1 !kg
LET m2=0.1 !kg
LET L1= 5 !m
LET L2= 5 !m
!
LET dt=0.05 !sec. 演算ピッチ。
!
LET μ2=m2/(m1+m2)
LET L21=L2/L1
DEF ss1(w2,θ1,θ2)=-g/L1*SIN(θ1) -μ2*L21*w2^2*SIN(θ1-θ2)
DEF ss2(w1,θ1,θ2)=-g/L2*SIN(θ2) +w1^2*SIN(θ1-θ2)/L21
DEF D(θ1,θ2)=1-μ2*COS(θ1-θ2)^2
DEF α1(w1,w2,θ1,θ2)=( ss1(w2,θ1,θ2) -L21*μ2*COS(θ1-θ2)*ss2(w1,θ1,θ2) )/D(θ1,θ2)
DEF α2(w1,w2,θ1,θ2)=(-ss1(w2,θ1,θ2)*COS(θ1-θ2)/L21 +ss2(w1,θ1,θ2) )/D(θ1,θ2)

SUB RK(θ1,θ2,w1,w2)
   LET w11=w1
   LET w12=w2
   LET α11=α1(w1,w2,θ1,θ2)
   LET α12=α2(w1,w2,θ1,θ2)
   !
   LET w21=w1+α11*dt/2
   LET w22=w2+α12*dt/2
   LET α21=α1(w21,w22,θ1+w11*dt/2,θ2+w12*dt/2)
   LET α22=α2(w21,w22,θ1+w11*dt/2,θ2+w12*dt/2)
   !
   LET w31=w1+α21*dt/2
   LET w32=w2+α22*dt/2
   LET α31=α1(w31,w32,θ1+w21*dt/2,θ2+w22*dt/2)
   LET α32=α2(w31,w32,θ1+w21*dt/2,θ2+w22*dt/2)
   !
   LET w41=w1+α31*dt
   LET w42=w2+α32*dt
   LET α41=α1(w41,w42,θ1+w31*dt,θ2+w32*dt)
   LET α42=α2(w41,w42,θ1+w31*dt,θ2+w32*dt)
   !
   LET θ1=θ1+(w11+2*w21+2*w31+w41)*dt/6
   LET θ2=θ2+(w12+2*w22+2*w32+w42)*dt/6
   LET w1=w1+(α11+2*α21+2*α31+α41)*dt/6
   LET w2=w2+(α12+2*α22+2*α32+α42)*dt/6
END SUB

!----init.
LET a_1=PI*0.8 !初期角度１
LET a_2=PI*0.9 !　　〜　２
LET a_3=0 !　初期角速度１
LET a_4=0 !　　　　〜　２
!
LET b_1=-a_1+0.001
LET b_2=-a_2
LET b_3=0
LET b_4=0
!
LET c_1=a_1
LET c_2=a_2+0.002
LET c_3=0
LET c_4=0
!
LET d_1=-a_1
LET d_2=-a_2+0.003
LET d_3=0
LET d_4=0
!
!----run
LET w=14
SET WINDOW -w,w,-w,w
SET LINE width 2 !4
SET LINE COLOR 2 !43
LET r1=SQR(m1)
LET r2=SQR(m2)
LET t0=TIME
DO
   LET t=TIME
   IF dt=< ABS(t-t0) THEN
      SET DRAW mode hidden
      CLEAR
      PLOT TEXT,AT 0.25*w,0.9*w:"マウス 右ボタンで、終了。"
      PLOT TEXT,AT -0.98*w,0.93*w,USING"演算ピッチ=#.### 秒":dt
      PLOT TEXT,AT -0.98*w,0.87*w,USING"描画ピッチ=#.### 秒":t-t0
      LET t0=t
      SET AREA COLOR 15
      DRAW disk WITH SCALE(3.86,4.67)
      SET AREA COLOR 1
      DRAW PDL1X2(a_1,a_2) WITH ROTATE(a_1)*SHIFT(-3,3)
      DRAW PDL1X2(b_1,b_2) WITH ROTATE(b_1)*SHIFT(3,3)
      DRAW PDL1X2(c_1,c_2) WITH ROTATE(c_1)*SHIFT(-3,-3)
      DRAW PDL1X2(d_1,d_2) WITH ROTATE(d_1)*SHIFT(3,-3)
      CALL RK(a_1,a_2,a_3,a_4)
      CALL RK(b_1,b_2,b_3,b_4)
      CALL RK(c_1,c_2,c_3,c_4)
      CALL RK(d_1,d_2,d_3,d_4)
      SET DRAW mode explicit
   END IF
   WAIT DELAY 0 !ノートパソコン等の消費電力を押える。
   MOUSE POLL mx,my,mlb,mrb
LOOP UNTIL mrb=1

PICTURE PDL1X2(θ1,θ2)
   DRAW circle WITH SCALE(0.3)
   DRAW PDLM(L1,r1)
   DRAW PDLM(L2,r2) WITH ROTATE(θ2-θ1)*SHIFT(0,-L1)
END PICTURE

PICTURE PDLM(L,r)
   PLOT LINES: 0,0;0,-L
   DRAW disk WITH SCALE(r)*SHIFT(0,-L)
END PICTURE

END 		 

Re: リラックス

 投稿者：GAI  投稿日：2008年11月27日(木)19時35分53秒 		返信・引用
  > No.125[元記事へ]

SECONDさんへのお返事です。

前回の古代生物といい、今回のものといい大変面白く遊び心満載です。
SECONDさんが作られた作品をどんどんアップして紹介してください。
こんなことがプログラムを組むことで可能なんだといつも驚かされます。
お仕事はプログラマーなんですか？ 		 

Re: 周波数プログラム

 投稿者：山中和義  投稿日：2008年11月27日(木)19時37分25秒 		返信・引用 　編集済
  > No.123[元記事へ]

大熊　正さんへのお返事です。


> （１）最後のＤＢ表示の＃３と位相表示の＃２のグラフを一緒に表示したいのですが、


縦軸の目盛りが違うので、調整が必要かと思います。半固定で表示するようにしてみました。

例.

後半のグラフ描画の部分
!SET bitmap SIZE 600,600 !画面を大きくする
SET WINDOW -0.5,6.5, -50,5 !表示領域
DRAW grid(1,5) !左端の目盛り

FOR f=1 TO 6 !ｘ軸が対数
   PLOT TEXT ,AT f-0.3,-0.15: mid$("10  100 1k  10k 100k1M  ",4*(f-1)+1,4)
NEXT f

FOR f=10 TO 100000 STEP 100 !周波数[Hz]
   CALL routine
   LET vv=vo(1)/vi(1)
   PLOT LINES: LOG10(f),20*LOG10(ABS(vv)); !利得[dB]
NEXT f
PLOT LINES


SET TEXT COLOR 2
FOR i=5 TO -45 STEP -5 !右端の縦軸目盛り
   PLOT TEXT ,AT 6,i: STR$(i*2)&"°"
NEXT i

SET LINE COLOR 2
FOR f=10 TO 100000 STEP 100 !周波数[Hz]
   CALL routine
   LET vv=vo(1)/vi(1)
   PLOT LINES: LOG10(f),DEG(ATN(Im(vv)/Re(vv)))/2; !位相θ　※1/2倍
NEXT f
PLOT LINES


END


> （２）位相表示は、なにか周波数の文字の上が表示されてません。


周波数のグラフは、目盛りが１度ずつ狭いところに重ね書きされて解読できない状態になります。
たとえば、３０度ずつ間隔の指定もできますが、今回はしていません。（手抜きです）


> 　　　VER 5.02をVER 7.2.8 で上書きするのはどうするのですか。


・BASIC本体のフォルダ D:\BASIC32w 全体です。これをエクスプローラで削除してください。
・その後、ダウンロードした新しいBASICをこのフォルダにインストールします。
・本のサンプルプログラム、たぶん別のフォルダにまとめられていると思いますので、
　BASIC本体をインストールした後、（BASIC本体とは別のフォルダに）コピーすればいいと思います。
　※BASIC本体にもかなりのサンプルが添付されています。


> （３）突然ですが、同じ行数と列数のMATには、固有値なるものが、あるそうですが、
> 　　　この命令語は単独で在るのでしょうか。
> 　　　または、此れを解いて表示するプログラムがあれば御教えください。


命令語はありません。プログラムをつくって求める必要があります。


BASIC VER5.02本体
 

Re: リラックス

 投稿者：SECOND  投稿日：2008年11月27日(木)20時05分43秒 		返信・引用
  > No.126[元記事へ]

GAIさんへのお返事です。

ごめんなさい.もう種切れです。(^ ^; プログラマーでもなんでもありません。

これらは、全て、数学の先人たちが、残してくれた遺産です。
ねむくなるような数理的な世界を、楽しくできれば、なによりです。 		 

困惑？

 投稿者：GAI  投稿日：2008年11月28日(金)10時18分16秒 		返信・引用
  今まで何事もなく立ち上がっていた十進ＢＡＳＩＣの画面が、突然下のタスクバーには入り込むのですが、プログラムを貼り付ける画面が広がらず（テキスト画面とグラフィック画面は広がる。）コピーしたプログラムを動かそうとしても動かせない状態になってしまいました。
どうやって元の状態に出来るのか解らずにいます。
ちなみに一度全てを削除して、もう一度インストゥールを繰り返しましたが、結果は同じでした。
解決方法がありましたらよろしくご教授下さい。
なおｏｓはWINDOW xp です。 		 

Re: 困惑？

 投稿者：山中和義  投稿日：2008年11月28日(金)10時56分15秒 		返信・引用 　編集済
  > No.129[元記事へ]

GAIさんへのお返事です。

Windows Meでの話ですが、
・他のアプリケーションと併用（同時、その後も含む）するとこの現象（同じ？）が起こります。
　十進BASICでプログラムを実行するとリソースメモリ（実装メモリとは違う）を消費しているみたいです。
　このリソース不足状態で発生しやすいです。また、起動もできない場合があります。
　例. インターネットエクスプローラでPDFファイルを閲覧しながら、プログラムする。

対処
・OS（パソコン）を再起動して、併用しない。 		 

周波数プログラム その他

 投稿者：大熊　正  投稿日：2008年11月28日(金)13時40分34秒 		返信・引用
  山中　様　　　大熊です。

（１）振幅と位相の同時表示の追加プログラムを有難うございました。
　　　直ぐ実施したら、上手く動きました。
（２）ver の変更の件ですが、

　　　BASIC VER5.02本体
　　とある35のファイル総てを、一つづつ消すのでしょうか、

　　　消す場合「ごみ箱」は駄目ときいていましたが、
　　　「エクスプローラー」はどこにあるのでしょうか。

（３）ver5.02のある、ファイルホルダーから
　　　「エクスプローラー」で一つづつ35個のファイル
　　　を消して、インターネットにある　ver7.2.8を
　　　指定、展開先が、元のver5.02のある、
　　　ファイルホルダーと理解して宜しいですか。
（４）インターネットの「仮称10進basic]では、
　　　２つのプログラムが「・・・の場合は、こちら・・」
　　　と書いてありますが、ハードデスクの「Ｄ」では、
　　　下の二番目でしょうか。

敬具。 		 

Re: 周波数プログラム その他

 投稿者：山中和義  投稿日：2008年11月28日(金)14時40分32秒 		返信・引用 　編集済
  > No.131[元記事へ]

大熊　正さんへのお返事です。

> 　　　BASIC VER5.02本体
>  　　とある35のファイル総てを、一つづつ消すのでしょうか、
>


１つずつ削除していくのが無難でしょう。
まとめてのファイル削除はいろいろなやり方があります。
たとえば、ドラグ、ShiftやCtrlキー押しながらをクリックでの範囲指定など。

5.02が入っているフォルダに、自作などのファイルがなければ、そのフォルダをまるごと削除しても良いです。
（入っている場合はバックアップして後で元にもどせば良いだけですが、、、）


> 　　　消す場合「ごみ箱」は駄目ときいていましたが、
>

削除されたファイルなどは一端ごみ箱に入ると思いますが、後でごみ箱を空にしてください。


> 　　　「エクスプローラー」はどこにあるのでしょうか。
>

デストップ上の「マイコンピュータ」（コンピュータのアイコン）を右クリックして表示されるメニューにあります。
エクスプローラの画面は、マイコンピュータをダブルクリック（シングルクリック設定されている場合もある）
して表示される画面（ファイル、フォルダなどの一覧を見る画面）のことです。


> （３）ver5.02のある、ファイルホルダーから
> 　　　「エクスプローラー」で一つづつ35個のファイル
> 　　　を消して、インターネットにある　ver7.2.8を
> 　　　指定、展開先が、元のver5.02のある、
> 　　　ファイルホルダーと理解して宜しいですか。

はい。


> （４）インターネットの「仮称10進basic]では、
> 　　　２つのプログラムが「・・・の場合は、こちら・・」
> 　　　と書いてありますが、ハードデスクの「Ｄ」では、
> 　　　下の二番目でしょうか。
>


上の「Windows95/98/Me/NT4.0/2000/XP/Vista　インストーラ版」の方が良いと思います。

ZIPファイルの解凍が可能なら、下の「Windows95/98/Me/NT4.0/2000/XP/Vista　アーカイブ版」でも大丈夫です。 		 

Re: 周波数特性　続き　大熊

 投稿者：山中和義  投稿日：2008年11月28日(金)20時05分5秒 		返信・引用 　編集済
  > No.124[元記事へ]

大熊　正さんへのお返事です。

> （３）突然ですが、同じ行数と列数のMATには、固有値なるものが、あるそうですが、
>　　　　略
> 　　　または、此れを解いて表示するプログラムがあれば御教えください。

!直接法による行列の固有値を求める

OPTION ARITHMETIC COMPLEX

LET i=SQR(-1) !虚数単位

LET cEps=1e-8 !誤差　※単精度


LET N=3 !N次正方行列

FUNCTION tr(A(,)) !行列Aのトレース
   LET t=0
   FOR j=1 TO N
      LET t=t+A(j,j)
   NEXT j
   LET tr=t
END FUNCTION


DIM c(N) !多項式 X^N+c(1)*X^(N-1)+c(2)*X^(N-2)+ … +c(N-1)*X+c(N) の係数
SUB DKA_00(A(),Xr()) !DKA法（Durand Kerner Aberth）
   LET r=1 !初期値を仮定する
   FOR j=2 TO N
      LET rn=ABS(A(j))^(1/j)
      if r<rn then LET r=rn
   NEXT j
   FOR j=1 TO N !半径rの円に等間隔に配置する
      LET Xr(j)=-A(1)/N+r*EXP( 2*PI*i/N *(j-3/4) ) !アーバスの初期値
   NEXT j

   FOR m=0 TO 100 !反復　※調整要
      LET mfx=0
      LET maj=0
      FOR j=1 TO N
         LET Xk=1
         LET fx=1
         FOR w=1 TO N
            LET fx=fx*Xr(j)+A(w)
            IF w<>j THEN LET Xk=Xk*(Xr(j)-Xr(w))
         NEXT w
         LET Xr(j)=Xr(j)-fx/Xk
         IF mfx<ABS(fx) THEN LET mfx=ABS(fx)
         IF maj<ABS(fx/Xk) THEN LET maj=ABS(fx/Xk)
      NEXT j
      IF mfx<cEps AND maj<cEps THEN EXIT FOR !収束したら
   NEXT m
END SUB
!-------------------- ここまでがサブルーチン


DIM A(N,N) !行列A
!DATA 1,0,0 !λ=1（３重根）
!DATA 0,1,1
!DATA 0,0,1

!DATA 0,1,1 !λ=2,-1（重根）
!DATA 1,0,1
!DATA 1,1,0

!DATA 3,0,0 !λ=3,±i
!DATA 0,2,-5
!DATA 0,1,-2

DATA 2,1,-1 !λ=3,2,1
DATA 0,3,0
DATA 0,2,1

MAT READ A

MAT PRINT A;


!n次正方行列Aの固有多項式 det(tE-A)=t^n+c1*t^(n-1)+ … + cn を求める。
DIM X(N,N),cE(N,N)
MAT X=IDN !frame法
FOR k=1 TO N
   MAT X=A*X
   LET c(k)=-tr(X)/k
   MAT cE=(c(k))*IDN
   MAT X=X+cE
NEXT k
MAT PRINT c;

!ニュートン法などで解く。解が固有値になる。
DIM lmd(N)
CALL DKA_00(c,lmd)

FOR k=1 TO N
   PRINT "固有値=";lmd(k)
NEXT k



!※N個求まった場合の検算
LET s=1
FOR k=1 TO N
   LET s=s*lmd(k)
NEXT k
PRINT s, DET(A) !固有値の積=行列の行列式　Πλi=|A|

LET s=0
FOR k=1 TO N
   LET s=s+lmd(k)
NEXT k
PRINT s, tr(A) !固有値の和=行列のトレース　Σλi=trA


END
 

バージョンアップの件

 投稿者：大熊　正  投稿日：2008年11月29日(土)12時45分44秒 		返信・引用
  （１）山中様　大熊です。
　　　バージョンアップは、お蔭様で上手く行きました。
　　　固有値も含め今までのソフトも順調に動きました。
      有難うございます。

（２）SECOND様　しだとアンモナイトの画も綺麗に出ま
      した。 		 

トランプマジックの創作

 投稿者：GAI  投稿日：2008年11月29日(土)19時30分52秒 		返信・引用
  十進BASICとは何の関係もありませんが、
今日一日、数学的構造を活かせるマジックができないかと挑戦してみて、次の手順を考えましたので、是非一度トランプを手にしてやってみて下さい。

＊デックのセット方法（裏向きトップよりの順）
赤カード：３，４，８, J , K （マークはなんでもよい。）
黒カード：２，３, ４，６，８, K（同じくマークはなんでもよい。）
4枚のAをまず抜き出しておき、トップからの枚数目に次のカードを配置してください。

（裏向きトップからの枚数目のカードの配置：●カードはなんでもよい。）
１●　　　　１１●　　　　２１ハートA　　３１●　　　　 ４１赤４　　　　５１赤J

２●　　　　１２●　　　　２２●　　 　　３２クラブA　　４２●　　　　  ５２●

３●　　　　１３黒４　　　２３●　 　　　３３黒３   　　４３●

４●　    　１４ダイアA   ２４●　　   　３４●　   　　４４●

５赤K   　　１５●　    　２５黒２   　　３５●　   　　４５黒６

６●　　  　１６●    　　２６●　     　３６●　   　　４６●

７●　  　　１７黒K   　　２７●     　　３７黒８　   　４７●

８●　  　　１８●    　　２８●     　　３８●　     　４８●

９赤８  　　１９●　  　　２９赤３ 　　　３９●     　　４９スペードA

１０●　  　２０●    　　３０●   　　　４０●     　　５０●

（やり方）
このようにセットしたパケットをなにげにテーブルに表向きにリボンスプレッドして
普通のカードであることを示す。
順番が狂わぬように集め、裏向きに手に持つ。
ここで一度フォールスカット（順番は元の状態に戻るようにする、偽のカット）をする。
奇数番目のカードをアップする（１，３，５・・・枚目のカードを上に少しずらす。）
これを最後までカードが互い違いになるまで繰り返し、上に上げたカードを全て抜き出し
テーブルに裏向きのまま置く。（順番が崩れないように注意。）＜リバースフェローシャッフルと呼ぶ。＞
手に残ったパケットで再び同じようにリバースフェローシャッフルをする。
抜き出したカード群は前の取り出してテーブルに置いている上に重ねておく。
これを繰り返すと手元には一枚のカードが残る。
これをテーブルに表向きに出すとクラブのAが現れる。
次に、テーブルに重ねていたパケットを大体半分になるように客に分けてもらう。
（正確に半分でなくてよく、上半分24枚〜27枚まで許される。）
上半分を演者がもらい、客のパケットの下半分の枚数を数える振りをしてパケットの上から一枚ずつテーブルにカウントしながら順序を逆転させる。
下半分の枚数が２７枚〜２４枚に入らない時は（枚数がオーバーする時）、カウントし終わった客のパケットのボトムから、演者のパケットのボトムへ数枚を何 気に移動させる。あるいはその逆に少ない場合は演者のパケットのボトムから数枚抜き出し、それの順序を逆転した数枚のカードを客のパケットのボトムに追加 しておく。
いずれにしても、客のパケットの枚数を２７枚〜２４枚の範囲に調節しておく。
調整したパケットを客に渡す。
演者と客はお互いのパケットを前の操作と同様にリバースフェローシャッフルをしていく。
それぞれ一枚ずつのカードが残るので、それをテーブルに表向きにする。
演者はダイアのA、客はハートのAが出現する。
これでテーブルには３枚のAが揃ったので、残りがスペードのA
ここで客に２つのパケットのうち、演者が捨てて重ねているパケットか、客が捨てた方のパケットかを選択させる。（ここは少し賭けであるが、客が自分の方のパケットを選ぶと心理的にみて構成している。）
こちらの思惑どうりに客が自分のパケットを選んだら（マジシャンズチョイスで客のパケットの方を選んだように見せかけるとよいだろう。）、パケットを受け取りテーブルに
時計の文字盤の様に１，２，３、・・・１２時の位置にカードを上から裏向きのまま配置していく。
残ったカードは中央の針の位置に表向きにして置く。演者の方のパケットも表向きで重ねておく。
ここで客に１２時の位置に置いたカード以外が選ばれるように誘導しながら、文字盤の位置にあるカードを一つを選ばせる。（１２時を選ばせていい時は、客のパケット枚数が２４枚または２５枚の時に限る。）
（もし、客が６時の位置を選んだら貴方の勘はすばらしいと褒めてそのカードをめくって、最後のスペードのAを出して終了する。）
客が選んだカードを表向きにして、そのカードの数字が
黒ならそのカードの次から数えて時計回りの向きにその数だけ進み、そこのカードをめくって取り除いていく。（めくったカードは中央に表向きで重ねていく。）
また客が指定したカードが赤のカードなら反時計回りに進んでめくり、取り除いていく。
これを繰り返していく（取り除いたカードの次からまた進んで＜最初の客が選んだカードの数ぶん＞次のカードをめくる。）と最後に６時の位置にあったカードが一枚だけ残る。
このカードを思わせぶりに焦らせて表にすると、まさに最後のスペードのAが出現する。
他のカードに２枚として同じカードが含まれていないことを、中央にある表向きに重なっているパケットをテーブルにリボンスプレッドして演技を終わる。

原理的には二進法の利用と、継子立ての遊びを組み合わせた様な手順になります。
朝から取り組み、今ようやくどうにかまとめました。
何か手違いが生じたら、お教えください。
更に改良部分がありましたらヒントをお願いします。 		 

「古代生物」について。

 投稿者：SECOND  投稿日：2008年11月29日(土)20時07分15秒 		返信・引用 　編集済
  Ｖ7.2.1 までは、乱数が異なり、動作できません、以降のバージョンが必要です。

※あやまって、cookie を、消してしまい、修正できなくなりました、すみません。
　無理に動かすと、図が汚くなると思います。 		 

Re: トランプマジックの創作

 投稿者：山中和義  投稿日：2008年11月30日(日)17時53分57秒 		返信・引用 　編集済
  > No.135[元記事へ]

GAIさんへのお返事です。

> ここで客に１２時の位置に置いたカード以外が選ばれるように誘導しながら、文字盤の位置にあるカードを一つを選ばせる。（１２時を選ばせていい時は、客のパケット枚数が２４枚または２５枚の時に限る。）


時計状に配置するときのパケットの内容
元のカードの配置位置なら
２６の場合
  37  5  45  29  13  49  41  33  25  17  9  1  51  47  43  39  35  31  27  23  19  15  11  7  3
２７の場合
  37  5  45  29  13  49  41  33  25  17  9  1  51  47  43  39  35  31  27  23  19  15  11  7  3  50

実際のカードでは、黒は正、赤は負とすると
  8 -13  6 -3  4 sA -4  3  2  13 -8  ? -11  ?  ? …
となる。

１番目のカードがこの位置にくるので、もう１つの「赤Ｊ」にすればよいと思います。



> 原理的には二進法の利用と、継子立ての遊びを組み合わせた様な手順になります。


解りづらかったので、シミュレータをつくってみました。
継子立てにはいろいろな手法があるので、少しプログラムを修正すると対応できると思います。
!継子立て（ヨセフスの問題）をシミュレートする

LET N=12 !石の数　※
LET P=-3 !除いていく位置　※<----------
LET a=4 !開始位置　※<----------


!●数理的

IF P>0 THEN !時計まわりなら
   PRINT MOD(a-1+f(N,P),N)+1
ELSE !反時計まわりなら
   PRINT MOD((N-a)-1+f(N,ABS(P)),N)+1 !左右反転して時計まわりにする
END IF
PRINT
FUNCTION f(n,p) !１番から時計まわりにp番目を取り除く
   IF n=1 THEN LET f=1 ELSE LET f=MOD(p-1+f(n-1,p),n)+1
END FUNCTION



!●シミュレータ

DIM s(N) !石の状態
FOR i=1 TO N !連番をつける
   LET s(i)=i
NEXT i

SET WINDOW -2,2,-2,2 !表示画面
LET r=1.5 !石の位置
SET TEXT JUSTIFY "center","half" !文字の位置
LET r2=1.8

CALL disp_stone !初期状態

PRINT "開始位置=";a
PRINT "除いていく位置=";P

!LET s(a)=0
!CALL disp_stone
LET k=N !残りの個数

DO UNTIL k=1 !残りの石が１つになるまで
   LET c=0 !カウンタ
   DO UNTIL c=ABS(P) !該当位置を見つける
      LET a=a+SGN(P) !±１　※正の場合、時計まわり
      LET b=MOD(a-1,N)+1 !配置位置を換算する
      IF s(b)>0 THEN LET c=c+1 !石がある場合のみカウントする
   LOOP
   PRINT b !取り除く
   LET s(b)=-1
   LET k=k-1

   CALL disp_stone !現在の状態
LOOP


SUB disp_stone !環状に並べる
   SET DRAW mode hidden !ちらつきを抑える（開始）
   CLEAR
   FOR i=1 TO N
      LET th=RAD(90-i/N*360) !Ｙ軸から時計まわり
      LET x=COS(th) !位置
      LET y=SIN(th)
      PLOT TEXT ,AT r2*x,r2*y: STR$(i) !番号
      IF s(i)>=0 THEN DRAW disk WITH SCALE(0.1)*SHIFT(r*x,r*y) !石
   NEXT i
   SET DRAW mode explicit !ちらつきを抑える（終了）
   WAIT DELAY 0.5
END SUB

END
 

そうだ！

 投稿者：GAI  投稿日：2008年11月30日(日)22時29分22秒 		返信・引用
  そうだ！！！
1枚目と５１枚目を共に赤のJであれば２４〜２７枚のいずれでも対応できるんですね。
（１枚目には気付いてはいるのだが、どうして共にセットしておけばいいと思いつかないんだろう、情けない。）
いつも急所を押さえるヒントを与えてもらい、ありがとうございます。
ほんとに助かります。 		 

再度トランプで

 投稿者：GAI  投稿日：2008年12月 1日(月)22時44分34秒 		返信・引用
  トランプが続いてすみませんが、次の手順を再現できるプログラムができないでしょうか？
１．一組のカード（５２枚）をまずよくシャッフルする。
２．デックを表向きに持ち、奇数のカードをアップジョグ（上にすこしずらす）していき
　　これらのカード全てを抜き取り（順番を変えないで）、ボトム側へ回す。
３．上半分（偶数群）から４，８，Q　のカードを、
　　下半分（奇数群）から３，７，J　のカードをアップジョグしていき、これらを抜き取り、ボトムへ
４．上三分の一位から２，１０のカード
　　中三分の一位からA，９のカード
　　下三分の一位から７，８のカードをアップジョグして、これを抜き取りボトムへ
５．上から順に、６，５，４，３，２，Aのカードをアップジョグして抜き取りボトムへ
６．赤カードをアップジョグしてボトムへ
７．上半分（黒カード群）からクラブ、下半分（赤カード群）からダイアカードをアップジョグしてボトムへ
以上の手順を行なうと、デックは裏向きトップから
ダイア、クラブ、ハート、スペードの順に
A,2,3,・・・J,Q,k　と揃う。（原理は２進法の応用）
これをどのカードを選びますか？
の質問を受けながら入力待ちとして（2番では奇数、６番では赤、7番ではマーク、他は数字）進行していけるようにしたい。
他の任意のカードの配列もこの方法を使って調べたいので、数字と色とマークが独立に選択できていけるよであればうれしいのですが... 		 

Re: 再度トランプで

 投稿者：山中和義  投稿日：2008年12月 3日(水)11時06分36秒 		返信・引用
  > No.139[元記事へ]

GAIさんへのお返事です。

> トランプが続いてすみませんが、次の手順を再現できるプログラムができないでしょうか？

> これをどのカードを選びますか？
> の質問を受けながら入力待ちとして（2番では奇数、６番では赤、7番ではマーク、他は数字）進行していけるようにしたい。


メニュー形式ではありませんが、再現するプログラムを試作してみました。
コーディング形式がマンネリなので、今回は「文字列操作」でカードの動きを実現しています。
また、ビジュアル表示も追加していますが、必要に応じてその部分を削除してください。
十進BASICは、ビットマップ画像の処理が苦手ですから処理速度は期待できません。

ここからダウンロード

（実行画面）
 

カードが並んでいます

 投稿者：GAI  投稿日：2008年12月 3日(水)19時28分13秒 		返信・引用
  おおおおーワンダフル。
トランプが実際に並んでいます。（どこから現れたのか？）
いちいち手作業でやっていた操作が一瞬で終了します。
しかも毎回カードは見事にばらばらでスタートできます。
中の構造はおぼろげながら読み解けますが、細部はまだ解読する力が私にはありません。
こんな長い過程のプログラムがよくこんな短時間にできますね。
問題を見た瞬間、だいたいこうプログラムを組めばいいんだとわかるもんなんですか？
プログラムを恐る恐る一部手直しをして、例えばダイアの２，４，５のカードだけをアウトジョグしてボトムへ回そうとあれこれ挑戦したのですが、いずれも機械がいうことを聞いてくれません。
ダイアと他のマークを含めた２，４，５のカードがアウトジョグされたりします。
AND で繋ごうと試みても、”ここにはANDは入れられません”などのコメントを受けます。
プログラムで特定のカード（マークと数字の指定）を、アウトジョグするにはどのように
記述したらよいか教えてください。 		 

Re: カードが並んでいます

 投稿者：山中和義  投稿日：2008年12月 3日(水)20時09分59秒 		返信・引用
  > No.141[元記事へ]

GAIさんへのお返事です。

> 例えばダイアの２，４，５のカードだけをアウトジョグしてボトムへ回そう

> プログラムで特定のカード（マークと数字の指定）を、アウトジョグするにはどのように記述したらよいか教えてください。


FOR i=1 TO N !該当するカード　※マークと数字
   k=CNum(c$,i)
   IF CMark$(c$,i)="D" AND ( k=2 OR k=4 OR k=5 ) THEN LET flg(i)=1
NEXT i
CALL shuffle(c$,flg)


または

FOR i=1 TO N !該当するカード　※カード
   SELECT CASE CGet$(c$,i)
   CASE "D2","D4","D5"
      LET flg(i)=1
   CASE ELSE
   END SELECT
NEXT i
CALL shuffle(c$,flg) 		 

旧掲示板

 投稿者：白石　和夫  投稿日：2008年12月 4日(木)20時48分13秒 		返信・引用
  旧掲示板が復活しています。
フリーソフトWeBoxを利用してWeb全体を取り込んで過去ログのページにアップしました。

http://www.geocities.jp/thinking_math_education/log/logs.html

  

グラフィックでお願いします。

 投稿者：GAI  投稿日：2008年12月 5日(金)07時34分7秒 		返信・引用
  カードでのグラフィックが可能なことを利用して、次の現象を再現したいのですが
絵札（J,Q,K)とAの１６枚を使う。
このカードを裏向きに４×４の行列形式に並べ(下の番号順に並べる）
カードの位置を（演者側から見た番号）
1  2  3  4
5  6  7  8
9  10 11 12
13 14 15 16
とする。
これ全体を一枚の紙と見立てて一枚のカードの大きさに折る操作を行なう。
＜折り方の方法＞
何処の位置（カードとカードの間の縦または横線）
でもかまわない部分を指定してもらい
例えば 1  2  3  4
     --------------
　　　 5  6  7  8
の間の線ならば、1  2  3  4
のカードをひっくり返して
　　　　　　　　5  6  7  8
のカードの上に重ねる。
また　2 |  3
      6 |  7
     10 | 11
     14 | 15
の線なら右半分（または左半分でもよい。）
を全て折り返して(カードはひっくり返ることになる。）

3 →  2
4 →  1
7 →  6
8 →  5
11 → 10
12 →  9
15 → 14
16 → 13
と重ねることとする。

これを客にその都度線を指定させ、１６枚のカードが一つに重なるまで続ける。
（パケットは表向き、裏向きが混ざった状態にある。）
このパケットにおまじないをかけ、テーブルにリボンスプレッドしてみる。
（このとき、パケット全体をひっくり返しておく必要がある時が起きることもある。）

（パターンK）
仕込み：１６枚のパケットの上から3,4,9,12枚目にKを配置しておく。
スタート：４×４に並べたカードの
　　　　　1,4,6,8,11,12,14,16番を表向きにする。（これは客から見てKに見える。）

（パターンA）
仕込み：１６枚のパケットの上から5,7,8,16枚目にAを配置しておく。
スタート：４×４に並べたカードの
　　　　　1,3,5,6,7,9,11,14番を表向きにする。（これは客から見てAに見える。）

（パターンJ）
仕込み：１６枚のパケットの上から4,9,10,15枚目にJを配置しておく。
スタート：４×４に並べたカードの
　　　　　2,5,7,9,12,13番を表向きにする。（これは客から見てJに見える。）

（パターンQ）
仕込み：１６枚のパケットの上から1,4,14,16枚目にQを配置しておく。
スタート：４×４に並べたカードの
　　　　　3,4,6,8,9,11番を表向きにする。（これは客から見てQに見える。これは少し苦しい）

これらの仕込みと最初の初期設定からの折り返しを繰り返して、最後のパケットでの
スプレッドをするとそれぞれのパターンでの４枚だけのカードが 表向きで出現し、
他のカードは裏向きになっている。

というものです。（すみません、説明が長すぎて・・・） 		 

Re: グラフィックでお願いします。

 投稿者：山中和義  投稿日：2008年12月 5日(金)19時39分34秒 		返信・引用 　編集済
  > No.144[元記事へ]

GAIさんへのお返事です。

> （パターンK）
> 仕込み：１６枚のパケットの上から3,4,9,12枚目にKを配置しておく。
> スタート：４×４に並べたカードの
> 　　　　　1,4,6,8,11,12,14,16番を表向きにする。（これは客から見てKに見える。）


折り紙の数理ですね。

●解析結果
向きが不動な箇所は、1,3,6,8,9,11,14,16である。　2,4,5,7,10,12,13,15は、反転する。
４×４配置なら
1  *  3  *
*  6  *  8
9  * 11  *
* 14  * 16
となる。

ところで、各カードの配置場所は、

  1  *  *  4  *  6  *  8  *  * 11 12  * 14  * 16 <-- Ｋのパターン
　 ↓ 　 ↓ ↓ 　 ↓ 　 　 ↓ 　 ↓ ↓ 　 ↓
  1  2  *  *  5  6  7  8  * 10 11  * 13 14 15 16 <-- シャッフル後
したがって、3,4,9,12にＫを配置しておけばよい。

  1  *  3  *  5  6  7  *  9  * 11  *  * 14  *  * <-- Ａのパターン
　 ↓ 　 ↓ ↓ 　 ↓ 　 　 ↓ 　 ↓ ↓ 　 ↓
  1  2  3  4  *  6  *  *  9 10 11 12 13 14 15  * <-- シャッフル後
したがって、5,7,8,16にＡを配置しておけばよい。

  *  2  *  *  5  *  7  *  9  *  * 12 13  *  *  * <-- Ｊのパターン
　 ↓ 　 ↓ ↓ 　 ↓ 　 　 ↓ 　 ↓ ↓ 　 ↓
  *  *  *  4  *  *  *  *  9 10  *  *  *  * 15  * <-- シャッフル後
したがって、4,9,10,15にＪを配置しておけばよい。

  *  2  3  *  *  6  *  8  9  * 11  * 13 14  *  * <-- Ｑのパターン
　 ↓ 　 ↓ ↓ 　 ↓ 　 　 ↓ 　 ↓ ↓ 　 ↓
  *  *  3  4  5  6  7  8  9 10 11 12  * 14 15  * <-- シャッフル後
したがって、1,2,13,16にＱを配置しておけばよい。（訂正を反映）


次のプログラムで確認できます。どちらを折りたたむかで位置(a,b)は変わります。
LET N=4 !N行N列
LET a=-2 !折りたたむ位置(a,b)
LET b=2
DATA 0,1,1,0 !Ｑパターン　※1:表、0:裏
DATA 0,1,0,1
DATA 1,0,1,0
DATA 1,1,0,0
DIM M(N,N)
MAT READ M
FOR y=1 TO N !行
   FOR x=1 TO N !列
      IF MOD(ABS(x-a)+ABS(y-b),2)=1 THEN !格子上での距離　※1:反転、0:そのまま
         LET M(y,x)=1-M(y,x) !論理否定
      END IF
      PRINT M(y,x); !「０が４つ」または「１が４つ」の位置
   NEXT x
   PRINT
NEXT y
END


シミュレータによるプログラムはこちらからダウンロード（前回と同じ、前回分も同梱）
 

御礼

 投稿者：GAI  投稿日：2008年12月 5日(金)20時33分6秒 		返信・引用
  さっそく製作して頂いて貰ってありがとうございます。
楽しく使わせていただいております。
日頃カードでやっているマジックをプログラムにすると、こんな風に構成していくのかと
BASICを勉強するのにとっても役に立ちますし、その意味を掴むのに好都合です。
自分はたかがトランプですが、そこにいろいろな数理や法則、組み合わせの妙などの技巧が構成していける点に興味があり、新しい作品を創造していくことが楽しみです。
これをコンピュータでシュミレートできれば試行錯誤を厭わない強みが手に入ります。
部分的に書き換えて現象がどう変化していくのかを知ることができ、改良や改善点の発見に大いに役立ちます。
これからも何かとお願いするかと思いますのでお助け下さい。
次から次への製作依頼に応じて下さいまして、重ね重ねありがとうございました。 		 

訂正

 投稿者：GAI  投稿日：2008年12月 5日(金)22時58分14秒 		返信・引用
  アップした後、数値の間違いに気付き訂正をしておいて下さい。
（パターンQ）で
仕込み：１，２，１３，１６枚目とし
スタート：２，３，６，８，９，１１，１３，１４番
への変更をお願いします。 		 

さいころ賭博

 投稿者：GAI  投稿日：2008年12月 7日(日)20時46分54秒 		返信・引用
  ＜パターン�機�
４つのさいころがあり
A={2,3,3,9,10,11}、B={0,1,7,8,8,8}、C={5,5,6,6,6,6}、D={4,4,4,4,12,12}
の目が各面に印字されているとします。
あなたと私はこの中からそれぞれ一つのさいころを選んでさいころを振ります。
出た目が大きいほうが相手から千円を受け取ることができます。
でも少なくとも１００回は勝負することにします。（選んださいころは変えない。）
さて貴方はどのさいころを選びますか？


＜パターン�供�
同じく４つのさいころが
X={5,5,6,6,7,7}、Y={1,2,3,9,10,11}、Z={0,1,7,8,8,9}、W={3,4,4,5,11,12}
の目でできています。
同じく勝負しますが（これも１００回は戦う条件つき）同じ目が出ればアイコでやり直しをします。
さてあなたが選ぶさいころはどれ？ 		 

Re: さいころ賭博

 投稿者：荒田浩二  投稿日：2008年12月 8日(月)09時22分26秒 		返信・引用
  > No.148[元記事へ]

GAIさんへのお返事です。

10万回の実験ではＤとＷがわずかに有利とでました。
期待値の1.324とは、1回に1000円かけると平均1324円戻ってくるという意味です。
下のプログラムでは対戦人数を2〜4人に指定できます。
ただし全員違うサイコロを選択するとします。
3人、4人ではＡとＹが有利とでました。
理論値を求めるのもそれほど難しくはないと思いますが、どうでしょう？


DECLARE EXTERNAL SUB combination
LET k=100000 ! 対戦回数
LET p=2 ! パターン
LET n=4 ! サイコロの種類
LET f=6 ! サイコロの面数
INPUT PROMPT "対戦人数は？ " : r
IF r<2 OR r>n THEN STOP
DIM code$(p,n),dice(p,n,f),d(r),win(r),sumwin(p,n),a(n),com(COMB(n,r),r)
MAT READ code$,dice
MAT a=ZER(n)
MAT sumwin=ZER
LET total=(COMB(n,r)-COMB(n-1,r))*k
LET count=0 ! COMB(n,r)
CALL combination(a,n,1,r,com,count)
FOR pp=1 TO p
   FOR i=1 TO count
      MAT win=ZER
      FOR j=1 TO k
         LET maxd=-1
         FOR ri=1 TO r
            LET d(ri)=dice(pp,com(i,ri),INT(f*RND)+1)
            IF d(ri)>maxd THEN
               LET maxd=d(ri)
               LET w=ri
            ELSEIF d(ri)=maxd THEN ! 引き分け
               LET w=0
            END IF
         NEXT ri
         IF w=0 THEN LET j=j-1 ELSE LET win(w)=win(w)+1
      NEXT j
      LET maxw=0
      FOR ri=1 TO r
         LET sumwin(pp,com(i,ri))=sumwin(pp,com(i,ri))+win(ri)
         PRINT code$(pp,com(i,ri));win(ri);"  ";
         IF win(ri)>maxw THEN
            LET w=ri
            LET maxw=win(ri)
         END IF
      NEXT ri
      PRINT "勝者 ";code$(pp,com(i,w));win(w);"勝";k-win(w);"敗";
      PRINT USING " 期待値 #.####":r*win(w)/k
   NEXT i
   PRINT "総合勝敗"
   FOR ni=1 TO n
      PRINT code$(pp,ni);sumwin(pp,ni);"勝";total-sumwin(pp,ni);"敗";
      PRINT USING " 期待値 #.####":r*sumwin(pp,ni)/total
   NEXT ni
   PRINT
NEXT pp
DATA A,B,C,D,X,Y,Z,W
DATA 2,3,3,9,10,11  ! A
DATA 0,1,7,8,8,8    ! B
DATA 5,5,6,6,6,6    ! C
DATA 4,4,4,4,12,12  ! D
DATA 5,5,6,6,7,7    ! X
DATA 1,2,3,9,10,11  ! Y
DATA 0,1,7,8,8,9    ! Z
DATA 3,4,4,5,11,12  ! W
END

REM 十進BASIC添付"\BASICw32\SAMPLE\COMBINAT.BAS"より
REM 1〜nの集合からr個を選ぶ組合せを生成する。配列com(,)
EXTERNAL SUB combination(a(),n,k,r,com(,),count)
! k以降の数からr個を選択する
IF r=0 THEN
   LET count=count+1
   LET ri=1
   FOR i=1 TO n
      IF a(i)=1 THEN
         LET com(count,ri)=i
         LET ri=ri+1
      END IF
   NEXT i
ELSE
   FOR i=k TO n-r+1
      LET a(i)=1
      CALL combination(a,n,i+1,r-1,com,count)
      LET a(i)=0
   NEXT i
END IF
END SUB 		 

Re: さいころ賭博

 投稿者：GAI  投稿日：2008年12月 8日(月)11時26分21秒 		返信・引用
  > No.149[元記事へ]

荒田浩二さんへのお返事です。

１０万回の勝負とはすごい。
２人でやる場合しか考慮していなかったので、３，４人でのプログラムまで構成されているのに驚きました。
自分で組んだプログラムに較べ、なんと効率よく組まれているかと感心いたしました。
さてここは賭博です。
当然胴元が有利になるような戦略を立てて下さい。
例の計算結果を眺め、期待値が高くなる組み合わせで作戦を練ります。
＜ヒント＞：二人で同時に選ぶように見せかけ、客が先にさいころを選ばせます。 		 

ファイルの開き方

 投稿者：初心者A  投稿日：2008年12月 8日(月)12時05分31秒 		返信・引用
  十進Basicで保存したファイルをダブルクリックしても開きません。
どうしたらダブルクリックで開けるのですか？
プログラムを起動してから、ファイルを開くのは実施できます。
初心者なのでよろしくお願いします。 		 

Re: ファイルの開き方

 投稿者：白石　和夫  投稿日：2008年12月 8日(月)14時37分17秒 		返信・引用 　編集済
  > No.151[元記事へ]

いくつか方法があります。
１つめは，インストーラ版ダウンロードのページからBASIC728setup.exeをダウンロードして実行することです。これが一番簡単です。
２つめ2は，BASICのフォルダにある,SETUP.BATを実行することです。なお，エクスプローラで拡張子を表示する設定になっていないと“.BAT”の部分は表示されません。
３つめは，FAQのページのBASファイルの関連付けの修正にあります。 		 

Re: ファイルの開き方

 投稿者：初心者A  投稿日：2008年12月 8日(月)15時38分6秒 		返信・引用
  > No.152[元記事へ]

白石　和夫先生へ

十進BASICの開発者である白石和夫先生から、早速回答をいただき、恐縮しております。
高校教師をしているので、日常の授業教材として活用させていただきたいと思います。

指示された２つめの方法で、上手く実行できました。
本当にありがとうございました。
今後ともよろしくご指導下さい。


> いくつか方法があります。
> １つめは，インストーラ版ダウンロードのページからBASIC728setup.exeをダウンロードして実行することです。これが一番簡単です。
> ２つめ2は，BASICのフォルダにある,SETUP.BATを実行することです。なお，エクスプローラで拡張子を表示する設定になっていないと“.BAT”の部分は表示されません。
> ３つめは，FAQのページのBASファイルの関連付けの修正にあります。 		 

十進BASICのプログラムについて

 投稿者：ド素人  投稿日：2008年12月11日(木)11時59分5秒 		返信・引用
  十進BASICで擬似乱数を使ったプログラムを作成したいと思っています。打率のデータを基に、どういう打順を組めば効率よく点が取れるのかを、乱数を発生させて作りたいのですが、どうしたらいいでしょうか？  

Re: 十進BASICのプログラムについて

 投稿者：山中和義  投稿日：2008年12月11日(木)19時54分8秒 		返信・引用
  > No.154[元記事へ]

ド素人さんへのお返事です。

打った、送ったの単純で、5000試合の平均を表示します。
１試合ごとの内訳は、PRINT文の注釈を削除すれば表示されます。
ただし、5000回試合の表示には時間がかかります。（実用的でない）
!打順考察のためのシミュレーション

DATA 0.2, 0.2, 0.3, 0.3, 0.3, 0.2, 0.2, 0.1, 0.1
!DATA 0.1, 0.2, 0.2, 0.3, 0.2, 0.1, 0.3, 0.2, 0.3
!DATA 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2
DIM D(9) !９人分の打率
MAT READ D

RANDOMIZE

LET N=5000 !試合数
FOR x=1 TO N

   DIM SM(N) !総合得点
   LET P=1 !打順

   FOR w=1 TO 9 !９回まで

      LET B=0 !塁の状態
      LET S1=0 !得点
      LET O=0
      DO UNTIL O=3 !３アウトまで
      !PRINT P;"番打者：";
         IF RND<D(P) THEN !ヒットなら
            LET t=INT(RND*10)+1 !長打率など　※１〜10
            SELECT CASE t
            CASE 1,2,3,4
               LET v=1
            CASE 5,6,7
               LET v=2
            CASE 8,9
               LET v=3
            CASE ELSE
               LET v=4
            END SELECT
            !PRINT v;"塁打", !１〜４

            LET B=B*10+1 !v塁打で走者を送る
            LET S1=S1+INT(B/10^3)
            LET B=MOD(B,10^3)
            FOR i=0 TO v-2
               LET B=B*10
               LET S1=S1+INT(B/10^3)
               LET B=MOD(B,10^3)
            NEXT i
         ELSE
            LET O=O+1
            !PRINT "アウト",
         END IF
         !PRINT USING "# %%%": S1,B !塁の状態

         LET P=P+1 !次へ
         IF P>9 THEN LET P=1
      LOOP

      !PRINT w;"回";S1;"点"
      !PRINT
      LET SM(w)=SM(w)+S1
   NEXT w

NEXT x


LET S=0 !得点の分布
FOR w=1 TO 9
   PRINT w;"回";SM(w)/N;"点"
   LET S=S+SM(w)
NEXT w
PRINT "総合得点=";S/N


END
 

Re: 十進BASICのプログラムについて

 投稿者：ド素人  投稿日：2008年12月15日(月)16時11分49秒 		返信・引用
  > No.155[元記事へ]

山中和義さんへのお返事です。

素早いお返事ありがとうございます。とても助かりました。またわからないことがあったら投稿させていただきます。 		 

Re: 十進BASICのプログラムについて

 投稿者：荒田浩二  投稿日：2008年12月16日(火)12時15分34秒 		返信・引用
  > No.154[元記事へ]

ド素人さんへのお返事です。

9人での打順は 9!=362880通りありますが、各打順ごとに1000試合をシミュレートしました。
試合のシミュレーションは単純にヒット3本で1点、以下ヒット1本ごとに1点追加。
実行には2進モードで約2時間20分かかりました。
ただし1000試合では試行回数が少なく、とくに各打者の打率のバラつきが小さいときは結果の信頼性は低いと思います。
上位100位を出力しましたが、あくまでも傾向を知るていどだと承知して下さい。

DECLARE EXTERNAL SUB perm
PUBLIC NUMERIC player,games,rank,total_point,worst_point
PUBLIC NUMERIC ave(9),best_order(100,9),best_point(100)
PRINT TIME$
LET t=TIME
LET player=9   ! 9!=362880通り
LET games=1000 ! 試合数
LET rank=100   ! ランク
MAT READ ave
DATA .460,.420,.380,.340,.300,.260,.220,.180,.140
!DATA .380,.360,.340,.320,.300,.280,.260,.240,.220
DIM a(player)
FOR i=1 TO player
   LET a(i)=i
NEXT i
MAT best_order=ZER
MAT best_point=ZER
LET total_point=0
LET worst_point=10*games
CALL perm(a,1)
FOR i=1 TO rank
   PRINT USING "No##  打順" : i;
   FOR j=1 TO player
      PRINT best_order(i,j);
   NEXT j
   PRINT USING "  期待値-%.### 点":best_point(i)/games
NEXT i
PRINT "最低期待値 =";worst_point/games;"点"
PRINT "平均 =";total_point/(games*FACT(player));"点"
PRINT TIME-t;"sec"
END

EXTERNAL SUB simulation(order())
LET sum_point=0
FOR i=1 TO games
   LET at_bat=0
   FOR inning=1 TO 9 ! 9回
      LET out_count=0
      LET hit=0
      DO
         IF ave(order(MOD(at_bat,player)+1))>RND THEN
            LET hit=hit+1
            IF hit>=3 THEN LET sum_point=sum_point+1
         ELSE
            LET out_count=out_count+1
         END IF
         LET at_bat=at_bat+1
      LOOP UNTIL out_count=3
   NEXT inning
NEXT i
LET total_point=total_point+sum_point
IF sum_point>best_point(rank) THEN ! ランク付け
   LET best_point(rank)=sum_point
   FOR j=1 TO player
      LET best_order(rank,j)=order(j)
   NEXT j
   FOR i=rank TO 2 STEP -1
      IF best_point(i)>best_point(i-1) THEN
         SWAP best_point(i),best_point(i-1)
         FOR j=1 TO player
            SWAP best_order(i,j),best_order(i-1,j)
         NEXT j
      ELSE
         EXIT SUB
      END IF
   NEXT i
ELSEIF sum_point<worst_point THEN
   LET worst_point=sum_point
END IF
END SUB

REM 十進BASIC添付"\BASICw32\SAMPLE\PERMUTAT.BAS"より
REM 1〜nの順列を辞書式順序で生成する。
EXTERNAL SUB perm(a(),n)
DECLARE EXTERNAL SUB simulation
IF n=player THEN
   CALL simulation(a)
ELSE
   FOR i=n TO player
      LET t=a(i)
      FOR j=i-1 TO n STEP -1
         LET a(j+1)=a(j)
      NEXT j
      LET a(n)=t
      CALL perm(a,n+1)
      LET t=a(n)
      FOR j=n TO i-1
         LET a(j)=a(j+1)
      NEXT j
      LET a(i)=t
   NEXT i
END IF
END SUB

No 1  打順 2  1  3  4  6  5  7  9  8   期待値 2.952 点
No 2  打順 3  4  1  2  5  6  9  8  7   期待値 2.914 点
No 3  打順 4  3  5  1  2  6  8  7  9   期待値 2.905 点
No 4  打順 6  3  4  1  2  5  9  8  7   期待値 2.902 点
No 5  打順 7  6  3  2  1  5  4  8  9   期待値 2.895 点
No 6  打順 3  1  2  4  5  6  7  9  8   期待値 2.889 点
No 7  打順 1  5  4  3  2  6  9  8  7   期待値 2.880 点
No 8  打順 4  1  3  2  5  6  8  9  7   期待値 2.879 点
No 9  打順 4  2  3  1  5  6  8  9  7   期待値 2.879 点
No10  打順 6  5  3  1  2  4  7  8  9   期待値 2.879 点
No11  打順 2  5  4  1  3  6  7  9  8   期待値 2.878 点
No12  打順 4  2  5  1  3  6  9  8  7   期待値 2.875 点
No13  打順 1  2  5  4  3  7  6  9  8   期待値 2.871 点
No14  打順 5  3  4  2  1  6  7  9  8   期待値 2.870 点
No15  打順 5  4  2  1  3  9  7  8  6   期待値 2.869 点
No16  打順 2  1  3  4  5  6  7  9  8   期待値 2.867 点
No17  打順 4  2  3  1  5  6  9  8  7   期待値 2.865 点
No18  打順 5  1  3  4  2  6  7  8  9   期待値 2.865 点
No19  打順 2  3  4  5  1  7  6  8  9   期待値 2.864 点
No20  打順 6  2  4  3  1  5  9  8  7   期待値 2.864 点
No21  打順 3  6  4  1  2  8  9  5  7   期待値 2.863 点
No22  打順 5  4  2  1  3  6  7  9  8   期待値 2.862 点
No23  打順 6  2  1  4  3  7  9  5  8   期待値 2.861 点
No24  打順 7  5  3  1  2  4  6  8  9   期待値 2.861 点
No25  打順 3  1  2  5  4  6  7  9  8   期待値 2.860 点
No26  打順 2  1  5  4  9  8  7  6  3   期待値 2.859 点
No27  打順 2  3  1  4  5  6  8  9  7   期待値 2.858 点
No28  打順 7  3  4  1  2  9  8  5  6   期待値 2.857 点
No29  打順 2  4  1  3  5  7  6  8  9   期待値 2.856 点
No30  打順 9  5  4  1  3  2  6  7  8   期待値 2.856 点
No31  打順 2  1  5  3  4  7  6  9  8   期待値 2.853 点
No32  打順 4  1  3  5  2  6  7  9  8   期待値 2.852 点
No33  打順 4  1  5  3  2  9  7  8  6   期待値 2.852 点
No34  打順 4  5  3  2  1  6  9  8  7   期待値 2.852 点
No35  打順 2  5  1  4  3  6  9  7  8   期待値 2.851 点
No36  打順 3  4  2  1  7  6  9  5  8   期待値 2.850 点
No37  打順 5  3  4  2  1  6  9  8  7   期待値 2.850 点
No38  打順 2  3  1  4  5  6  9  8  7   期待値 2.849 点
No39  打順 4  2  3  5  1  6  7  9  8   期待値 2.849 点
No40  打順 2  4  1  5  3  7  9  8  6   期待値 2.848 点
No41  打順 5  7  4  1  3  2  8  9  6   期待値 2.847 点
No42  打順 2  4  1  5  3  7  8  9  6   期待値 2.846 点
No43  打順 4  3  2  1  5  7  8  9  6   期待値 2.845 点
No44  打順 1  4  2  3  8  7  9  5  6   期待値 2.844 点
No45  打順 4  3  1  2  5  6  9  7  8   期待値 2.844 点
No46  打順 7  3  2  1  4  5  6  9  8   期待値 2.844 点
No47  打順 4  2  3  1  5  9  7  8  6   期待値 2.843 点
No48  打順 5  2  3  1  4  6  8  7  9   期待値 2.843 点
No49  打順 5  3  2  4  1  7  6  8  9   期待値 2.842 点
No50  打順 2  1  4  3  5  8  6  7  9   期待値 2.841 点
No51  打順 4  6  3  1  2  8  5  9  7   期待値 2.841 点
No52  打順 5  4  1  2  3  9  8  7  6   期待値 2.841 点
No53  打順 2  4  3  1  5  8  9  6  7   期待値 2.840 点
No54  打順 3  2  1  4  5  8  9  7  6   期待値 2.840 点
No55  打順 9  2  3  4  1  5  6  7  8   期待値 2.839 点
No56  打順 6  5  2  1  4  3  8  9  7   期待値 2.838 点
No57  打順 7  3  6  1  2  4  5  8  9   期待値 2.838 点
No58  打順 3  5  7  2  1  4  6  8  9   期待値 2.837 点
No59  打順 4  3  1  2  7  5  8  9  6   期待値 2.837 点
No60  打順 4  6  2  3  1  5  7  8  9   期待値 2.837 点
No61  打順 4  6  3  2  1  5  8  9  7   期待値 2.837 点
No62  打順 6  1  2  4  3  8  5  9  7   期待値 2.837 点
No63  打順 2  4  3  1  5  8  6  9  7   期待値 2.836 点
No64  打順 4  3  5  2  1  6  9  8  7   期待値 2.836 点
No65  打順 4  5  1  2  3  6  7  9  8   期待値 2.836 点
No66  打順 1  4  3  5  6  8  9  7  2   期待値 2.835 点
No67  打順 4  3  1  2  5  6  9  8  7   期待値 2.835 点
No68  打順 4  6  1  2  3  5  8  9  7   期待値 2.835 点
No69  打順 5  4  1  3  6  9  8  7  2   期待値 2.835 点
No70  打順 6  3  4  1  2  7  5  8  9   期待値 2.835 点
No71  打順 1  3  2  4  6  9  8  5  7   期待値 2.834 点
No72  打順 3  2  1  4  6  7  5  8  9   期待値 2.834 点
No73  打順 4  1  3  2  5  6  7  8  9   期待値 2.834 点
No74  打順 6  5  3  4  1  2  7  8  9   期待値 2.834 点
No75  打順 7  4  5  1  2  3  6  9  8   期待値 2.834 点
No76  打順 3  1  2  6  5  4  7  8  9   期待値 2.833 点
No77  打順 6  1  2  3  4  5  8  9  7   期待値 2.833 点
No78  打順 6  3  1  2  5  4  9  7  8   期待値 2.833 点
No79  打順 7  3  6  1  2  5  4  8  9   期待値 2.833 点
No80  打順 5  2  3  1  4  7  8  9  6   期待値 2.832 点
No81  打順 7  4  5  3  1  2  6  8  9   期待値 2.832 点
No82  打順 3  1  2  7  4  6  9  8  5   期待値 2.831 点
No83  打順 3  1  4  2  7  8  9  6  5   期待値 2.831 点
No84  打順 3  2  1  4  5  7  9  8  6   期待値 2.831 点
No85  打順 5  3  1  2  4  6  9  7  8   期待値 2.831 点
No86  打順 5  6  1  2  4  3  7  8  9   期待値 2.831 点
No87  打順 6  3  4  1  2  7  5  9  8   期待値 2.831 点
No88  打順 1  2  3  5  4  9  7  8  6   期待値 2.830 点
No89  打順 2  5  1  3  4  7  9  8  6   期待値 2.830 点
No90  打順 6  5  3  1  4  2  7  9  8   期待値 2.830 点
No91  打順 6  9  3  4  2  1  5  7  8   期待値 2.830 点
No92  打順 2  1  4  5  7  9  8  6  3   期待値 2.829 点
No93  打順 5  1  4  3  2  7  9  8  6   期待値 2.829 点
No94  打順 8  5  1  4  2  3  6  9  7   期待値 2.829 点
No95  打順 1  2  3  4  6  9  8  7  5   期待値 2.828 点
No96  打順 3  4  1  2  6  7  9  5  8   期待値 2.828 点
No97  打順 1  3  5  2  4  6  7  8  9   期待値 2.827 点
No98  打順 2  1  3  5  4  7  9  8  6   期待値 2.827 点
No99  打順 3  4  1  2  5  6  7  9  8   期待値 2.826 点
No100 打順 4  2  1  3  5  8  9  7  6   期待値 2.826 点

最低期待値 = 2.073 点
平均 = 2.44374 点 		 

プログラムの書き直し

 投稿者：GAI  投稿日：2008年12月16日(火)22時55分17秒 		返信・引用
  UBASICによる次のプログラムを十進BASICに書き直してもらいたいのですが、どなたかよろしくお願いいたします。

10 !euler function
20 input "n=";M
30 Mw=M:Phi=1
40 repeat
50   P=prmdiv(Mw)
60   Phi*=P-1:Mw\=P
70   while Mw@P=0:Phi*=P:Mw\=P:wend
80 until Mw=1
90 print Phi
100 end


オイラー関数（1 から n までの自然数のうち n と互いに素なものの個数）
を求める目的です。 		 

Re: プログラムの書き直し

 投稿者：SECOND  投稿日：2008年12月17日(水)05時50分56秒 		返信・引用 　編集済
  > No.158[元記事へ]

GAIさんへのお返事です。

!　関数 prmdiv() の本来は、素数で割っていくようです。

! euler function
!------------------
INPUT PROMPT "n=":M
LET Mw=M
LET Phi=1
DO
   LET P=prmdiv(Mw)
   LET Phi=Phi*(P-1)
   LET Mw=INT(Mw/P)
   DO WHILE MOD(Mw,P)=0
      LET Phi=Phi*P
      LET Mw=INT(Mw/P)
   LOOP
LOOP UNTIL Mw=1
PRINT Phi

FUNCTION prmdiv(Mw) !１＜の最小の約数
   FOR i=2 TO Mw
      IF MOD(Mw,i)=0 THEN EXIT FOR
   NEXT i
   LET prmdiv=i
END FUNCTION

END

＜プログラムの照合用に＞ 原文を uBASIC で、実行した結果。
run
n=2~400
   1   2   2   4   2   6   4   6   4  10   4  12   6   8   8  16   6  18   8  12
  10  22   8  20  12  18  12  28   8  30  16  20  16  24  12  36  18  24  16  40
  12  42  20  24  22  46  16  42  20  32  24  52  18  40  24  36  28  58  16  60
  30  36  32  48  20  66  32  44  24  70  24  72  36  40  36  60  24  78  32  54
  40  82  24  64  42  56  40  88  24  72  44  60  46  72  32  96  42  60  40 100
  32 102  48  48  52 106  36 108  40  72  48 112  36  88  56  72  58  96  32 110
  60  80  60 100  36 126  64  84  48 130  40 108  66  72  64 136  44 138  48  92
  70 120  48 112  72  84  72 148  40 150  72  96  60 120  48 156  78 104  64 132
  54 162  80  80  82 166  48 156  64 108  84 172  56 120  80 116  88 178  48 180
  72 120  88 144  60 160  92 108  72 190  64 192  96  96  84 196  60 198  80 132
100 168  64 160 102 132  96 180  48 210 104 140 106 168  72 180 108 144  80 192
  72 222  96 120 112 226  72 228  88 120 112 232  72 184 116 156  96 238  64 240
110 162 120 168  80 216 120 164 100 250  72 220 126 128 128 256  84 216  96 168
130 262  80 208 108 176 132 268  72 270 128 144 136 200  88 276 138 180  96 280
  92 282 140 144 120 240  96 272 112 192 144 292  84 232 144 180 148 264  80 252
150 200 144 240  96 306 120 204 120 310  96 312 156 144 156 316 104 280 128 212
132 288 108 240 162 216 160 276  80 330 164 216 166 264  96 336 156 224 128 300
108 294 168 176 172 346 112 348 120 216 160 352 116 280 176 192 178 358  96 342
180 220 144 288 120 366 176 240 144 312 120 372 160 200 184 336 108 378 144 252
190 382 128 240 192 252 192 388  96 352 168 260 196 312 120 396 198 216 160
OK
 		 

Re: プログラムの書き直し

 投稿者：荒田浩二  投稿日：2008年12月17日(水)10時56分47秒 		返信・引用
  > No.159[元記事へ]

SECONDさんへのお返事です。


> FUNCTION prmdiv(Mw) !１＜の最小の約数
>    FOR i=2 TO Mw
>       IF MOD(Mw,i)=0 THEN EXIT FOR
>    NEXT i
>    LET prmdiv=i
> END FUNCTION



関数定義を改良しました。
引数が大きく、最小の約数も大きいとき効果があります。

FUNCTION prmdiv(Mw) !１＜の最小の約数
   IF MOD(Mw,2)=0 THEN
      LET prmdiv=2
      EXIT FUNCTION
   ELSEIF MOD(Mw,3)=0 THEN
      LET prmdiv=3
      EXIT FUNCTION
   END IF
   FOR i=5 TO SQR(Mw) STEP 6
      IF MOD(Mw,i)=0 THEN
         LET prmdiv=i
         EXIT FUNCTION
      ELSEIF MOD(Mw,i+2)=0 THEN
         LET prmdiv=i+2
         EXIT FUNCTION
      END IF
   NEXT i
   LET prmdiv=Mw
END FUNCTION 		 

固有ベクトルの算法

 投稿者：SECOND  投稿日：2008年12月17日(水)12時42分29秒 		返信・引用 　編集済
  固有ベクトルを高速に算出する方法を、ご指導ください。
※近似値でもよいです。ＣＡＤなど、かなり速いですが、
　どんなアルゴリズムが、使われているのでしょうか。 		 

Re: 固有ベクトルの算法

 投稿者：山中和義  投稿日：2008年12月17日(水)13時23分36秒 		返信・引用
  > No.161[元記事へ]

SECONDさんへのお返事です。

> どなたか、固有ベクトルを高速に算出する方法を、ご指導ください。
> ＣＡＤなどは、速いですが、どんなアルゴリズムが、使われているのでしょうか。


・対称行列
　ヤコビ法

アルゴリズムの本に掲載されている。手元にコードなし。


・最大の固有値・固有ベクトルの算出
　べき乗法（パワー法）

アルゴリズムの本に掲載されている。
数値計算の専門書には、複素数への拡張がされている。

!べき乗法による行列の固有値と固有ベクトルを求める
!※固有値が０、重複する場合は適用できない。
!※実数の固有値のみ。虚数を含む解は得られない。

!Ax=λIx、λ:固有値、x:固有ベクトル

LET N=3 !N次正方行列


DATA 2,1,-1 !λ=3,2,1
DATA 0,3,0
DATA 0,2,1

!DATA 0,1,1 !λ=2,1,0
!DATA -4,4,2
!DATA 4,-3,-1

!DATA 1,0,0 !λ=1（３重根）
!DATA 0,1,1
!DATA 0,0,1

DIM A(N,N) !行列A
MAT READ A
MAT PRINT A;


LET cEps=1e-6 !誤差　※調整要、単精度

DIM u(N) !固有ベクトル

DIM AA(N,N) !作業用
MAT AA=A
FOR s=1 TO N !s番目
   CALL EigenPower(N,AA, lambda,u)
   PRINT "固有値=";lambda
   PRINT "固有ベクトル"
   MAT PRINT u;

   FOR i=1 TO N !残差行列を求めて、次へ
      FOR j=1 TO N
         LET AA(i,j)=AA(i,j)-lambda*u(i)*u(j)
      NEXT j
   NEXT i
NEXT s




DEF norm(v())=SQR(DOT(v,v)) !ノルム

SUB EigenPower(N,A(,), lambda,u()) !固有値（絶対値最大）、固有ベクトルを求める
   DIM u0(100),u2(100) !※最大100次

   MAT u=CON !初期値　※ノルムが１
   MAT u=(1/norm(u))*u

   LET cMax=100
   FOR i=1 TO cMax !最大回数まで繰り返す
      MAT u0=u !直前のu

      MAT u=A*u0
      WHEN EXCEPTION IN
         MAT u=(1/norm(u))*u !正規化する
      USE
         PRINT "０ベクトルになりました。"
         STOP
      END WHEN

      MAT u2=u-u0 !収束したか確認する
      IF norm(u2)<cEps THEN EXIT FOR
      MAT u2=u+u0
      IF norm(u2)<cEps THEN EXIT FOR
   NEXT i
   IF i>cMax THEN
      PRINT "収束しません。"
      STOP
   END IF

   MAT u2=A*u
   LET lambda=DOT(u2,u)/DOT(u,u) !固有値
END SUB


END
 

Re: 固有ベクトルの算法

 投稿者：SECOND  投稿日：2008年12月17日(水)14時10分15秒 		返信・引用 　編集済
  > No.162[元記事へ]

山中和義さんへのお返事です。

ありがとうございました。

なぜこんなものを、というのは、
信号ベクトルの自己相関マトリクスの固有ベクトルを基底として、写像した信号ベクトルが、
信号ベクトルの圧縮の限界（ＫＬＴ変換）になるのを実験しようというものです。
でも、リアルタイムに、１０ｘ１０くらいの行列　というのは、きついです。 		 

Re: 十進BASICのプログラムについて

 投稿者：ド素人  投稿日：2008年12月17日(水)15時02分48秒 		返信・引用
  > No.155[元記事へ]

山中和義さんへのお返事です。

丁寧にプログラムを掲載していただきありがとうございます。
ひとつ質問があるのですが、「１試合ごとの内訳は、PRINT文の注釈を削除すれば表示されます。」と書いてある部分は、具体的にはどの部分のことをさしているのでしょうか？１試合ごとの内訳を知りたいのでぜひ教えていただけないでしょうか？よろしくお願いします。 		 

Re: 十進BASICのプログラムについて

 投稿者：山中和義  投稿日：2008年12月17日(水)15時42分26秒 		返信・引用 　編集済
  > No.164[元記事へ]

ド素人さんへのお返事です。

> ひとつ質問があるのですが、「１試合ごとの内訳は、PRINT文の注釈を削除すれば表示されます。」と書いてある部分は、具体的にはどの部分のことをさしているのでしょうか？


!PRINT 〜　の形の部分です。十進BASICの注釈（コメント）は感嘆符（!マーク）です。

下記に削除したプログラムを掲載しておきます。

!打順考察のためのシミュレーション

DATA 0.2, 0.2, 0.3, 0.3, 0.3, 0.2, 0.2, 0.1, 0.1
!DATA 0.1, 0.2, 0.2, 0.3, 0.2, 0.1, 0.3, 0.2, 0.3
!DATA 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2
DIM D(9) !９人分の打率
MAT READ D

RANDOMIZE

LET N=10 !試合数　※調整要
FOR x=1 TO N
   PRINT !<----- ここ
   PRINT "***";x;"試合目 ***" !<----- ここ

   DIM SM(N) !総合得点
   LET P=1 !打順

   FOR w=1 TO 9 !９回まで

      LET B=0 !塁の状態
      LET S1=0 !得点
      LET O=0
      DO UNTIL O=3 !３アウトまで
         PRINT P;"番打者："; !<----- ここ
         IF RND<D(P) THEN !ヒットなら
            LET t=INT(RND*10)+1 !長打率など　※１〜10
            SELECT CASE t
            CASE 1,2,3,4
               LET v=1
            CASE 5,6,7
               LET v=2
            CASE 8,9
               LET v=3
            CASE ELSE
               LET v=4
            END SELECT
            PRINT v;"塁打", !１〜４ <----- ここ

            LET B=B*10+1 !v塁打で走者を送る
            LET S1=S1+INT(B/10^3)
            LET B=MOD(B,10^3)
            FOR i=0 TO v-2
               LET B=B*10
               LET S1=S1+INT(B/10^3)
               LET B=MOD(B,10^3)
            NEXT i
         ELSE
            LET O=O+1
            PRINT "アウト", !<----- ここ
         END IF
         PRINT USING "# %%%": S1,B !塁の状態 <----- ここ

         LET P=P+1 !次へ
         IF P>9 THEN LET P=1
      LOOP

      PRINT w;"回";S1;"点" !<----- ここ
      PRINT !<----- ここ
      LET SM(w)=SM(w)+S1
   NEXT w

NEXT x


PRINT
LET S=0 !得点の分布
FOR w=1 TO 9
   PRINT w;"回";SM(w)/N;"点"
   LET S=S+SM(w)
NEXT w
PRINT "総合得点=";S/N


END
 

Re: 十進BASICのプログラムについて

 投稿者：ド素人  投稿日：2008年12月17日(水)15時52分47秒 		返信・引用
  > No.155[元記事へ]

山中和義さんへのお返事です。

たびたびすみません。DATAの次の行に書いてある！DATAはどのような意味があるのでしょうか？ここにはどのようなデータを書き込めばいいのでしょうか？無くても問題はないのでしょうか？ 		 

Re: 十進BASICのプログラムについて

 投稿者：山中和義  投稿日：2008年12月17日(水)16時23分21秒 		返信・引用
  > No.166[元記事へ]

ド素人さんへのお返事です。

> DATAの次の行に書いてある！DATAはどのような意味があるのでしょうか？ここにはどのようなデータを書き込めばいいのでしょうか？無くても問題はないのでしょうか？


感嘆符から始まる行ですから、この行全体は注釈すなわち「実行されない文」となります。
したがって、あっても無くても問題になりません。


この注釈行を変更することで、別のパターンがすばやく確認できます。（メモも兼ねる）

例

DATA パターン１ <---- ここが実行される
!DATA パターン２
!DATA パターン３

を

!DATA パターン１
DATA パターン２  <---- ここが実行される
!DATA パターン３

と変更して、プログラムを実行する。 		 

放物線Ｙ＝Ｘ＾２の利用

 投稿者：GAI  投稿日：2008年12月17日(水)17時46分1秒 		返信・引用
  Y=X^2 の放物線の思わぬ利用で、２つの数のかけ算の結果を次の作図で求めることをやれることを知りました。
例：３×５＝１５
である計算が
放物線上に２点Ａ(-3,9)とＢ(5,25)を取り、Ａ，Ｂの２点を結ぶ直線がＹ軸と交わる点Ｐ
を作図で求める。
このＰ点のＹ座標が求める積の値を知らせる。
一般にＡ(-a,(-a)^2),Ｂ(b,b^2)を結ぶ直線がＹ軸と交わる点が積a×bの値を示す。

この現象をプログラムにして、学生に解らせて確認して見せるものを作って頂きたく存じます。 		 

Re: 放物線Ｙ＝Ｘ＾２の利用

 投稿者：山中和義  投稿日：2008年12月17日(水)20時25分11秒 		返信・引用
  > No.168[元記事へ]

GAIさんへのお返事です。

> この現象をプログラムにして、学生に解らせて確認して見せるものを作って頂きたく存じます。

放物線を描画できる範囲が原点近傍に限られますが、、、


放物線y=x^2と直線y=m*x+nの２つの交点A(a,?)とB(b,?)は、２次方程式x^2-m*x-n=0を解けばよい。
解と係数との関係から、a*b=-n、a+b=m。

a+bも計算できる!?　傾き!?

DEF f(x)=x^2 !関数y=x^2
DEF g(x,a,b)=(f(b)-f(a))/(b-a)*(x-a)+f(a) !点Aと点Bを通る直線

LET a=-2
LET b=4

SET bitmap SIZE 300,600
SET WINDOW -10,10,-20,20 !表示領域
DRAW grid !座標

FOR x=-10 TO 10 STEP 0.2 !放物線y=x^2を描く
   PLOT LINES: x,f(x);
NEXT x
PLOT LINES

SUB ten(x,y,s$)
   PLOT TEXT ,AT x+0.4,y: s$
   DRAW disk WITH SCALE(0.2)*SHIFT(x,y)
END SUB
CALL ten(-a,f(-a),"A")
CALL ten(b,f(b),"B")

FOR x=-10 TO 10 STEP 0.2 !直線を描く
   PLOT LINES: x,g(x,-a,b);
NEXT x
PLOT LINES

CALL ten(0,g(0,-a,b),"P") !y切片


PRINT g(0,-a,b), a*b !検算



DEF h(a,b)=(f(b)-f(a))/(b-a) !傾き
PRINT h(a,b), a+b


END
 

放物線で遊ぶ

 投稿者：GAI  投稿日：2008年12月18日(木)07時21分0秒 		返信・引用
  掲載してもらったプログラムを参考にさせて頂いて、私なりにやって見たかった現象を作ってみました。
感覚として、計算尺で計算しているような雰囲気が出ます。
１２３４５６７９×６３
などの計算をお楽しみください。



10 DEF f(x)=x^2 !関数y=x^2
20 DEF g(x,a,b)=(f(b)-f(a))/(b-a)*(x-a)+f(a) !点Aと点Bを通る直線
30 INPUT PROMPT "2数を選ぶ":x,y
40 LET x1=INT(LOG10(x))
50 LET y1=INT(LOG10(y))
60 LET x=x/10^x1
70 LET y=y/10^y1
80 LET a=x
90 LET b=y
100 IF a>b THEN LET t=a ELSE LET t=b
110 SET bitmap SIZE 300,600
120 SET WINDOW -(t+1),t+1,-2,(t+1)^2+5 !表示領域
130 DRAW grid !座標
140 FOR x=-10 TO 10 STEP 0.2 !放物線y=x^2を描く
150    PLOT LINES: x,f(x);
160 NEXT x
170 PLOT LINES
180 SUB ten(x,y,s$)
190    PLOT TEXT ,AT x+0.4,y: s$
200    DRAW disk WITH SCALE(0.2)*SHIFT(x,y)
210 END SUB
220 CALL ten(-a,f(-a),"A")
230 CALL ten(b,f(b),"B")
240 FOR x=-10 TO 10 STEP 0.2 !直線を描く
250    PLOT LINES: x,g(x,-a,b);
260 NEXT x
270 PLOT LINES
280 CALL ten(0,g(0,-a,b),"P") !y切片
290 PRINT "Y切片の値";g(0,-a,b);
300 PRINT "計算結果"; a*b*10^(x1+y1) !検算
310 DEF h(a,b)=(f(b)-f(a))/(b-a) !傾き
320 !PRINT h(a,b), a+b
330 END 		 

Re: プログラムの書き直し

 投稿者：山中和義  投稿日：2008年12月18日(木)15時43分28秒 		返信・引用
  > No.158[元記事へ]

UBASICの整数論関連の組込み関数を移植しました。

!RSA公開鍵暗号の計算

PRINT modpow(1371,1241,2279) !1371を暗号化する。公開鍵43*53=2279と1241

PRINT eul(2279) !=2184、43と53と2184は秘密
PRINT gcd(43,53) !互いに素
PRINT gcd(2184,1241) !互いに素

PRINT modinv(1241,2184) !秘密鍵1649

PRINT modpow(2003,1649,2279) !2003を複合化する


!ｎの１より大きな最小の約数
PRINT prmdiv(1234567) !127
PRINT prmdiv(23456789) !23456789
!PRINT prmdiv(11111111111111111) !2071723


!素数の生成
PRINT prm(100) !541
PRINT nxtprm(999) !prm(1000)=7919
!PRINT nxtprm(9999) !prm(10000)=104729


!オイラー関数（１からｎまでの自然数のうちｎと互いに素なものの個数）
FOR N=2 TO 100
   LET S=0
   FOR i=1 TO N-1
      IF GCD(N,i)=1 THEN LET S=S+1
   NEXT i
   PRINT N;S, eul(N)
NEXT N


FOR i=2 TO 100
   PRINT USING "#### #### #### ####": i,fnSigma(i),eul(i),moeb(i)
NEXT i


END



!整数論関連　※ubasicより

EXTERNAL FUNCTION prmdiv(n) !１より大きな最小の約数
IF MOD(n,2)=0 THEN !２の倍数
   LET prmdiv=2
ELSEIF MOD(n,3)=0 THEN !３の倍数
   LET prmdiv=3
ELSE
   FOR i=5 TO SQR(n) STEP 6
   !!!FOR i=5 TO INTSQR(n) STEP 6 !<----- ※有理数モード
      IF MOD(n,i)=0 THEN !5,11,17,23,29,…
         LET prmdiv=i
         EXIT FUNCTION
      ELSEIF MOD(n,i+2)=0 THEN !7,13,19,25,31,…
         LET prmdiv=i+2
         EXIT FUNCTION
      END IF
   NEXT i
   LET prmdiv=n !その数自身
END IF
END FUNCTION

EXTERNAL FUNCTION eul(n) !オイラー関数 φ(n)（１からｎまでの自然数のうちｎと互いに素なものの個数）
LET t=n
IF MOD(n,2)=0 THEN
   LET t=t/2
   DO
      LET n=n/2
   LOOP WHILE MOD(n,2)=0
END IF
LET d=3
DO WHILE n/d>=d
   IF MOD(n,d)=0 THEN
      LET t=t/d*(d-1)
      DO
         LET n=n/d
      LOOP WHILE MOD(n,d)=0
   END IF
   LET d=d+2
LOOP
IF n>1 THEN LET t=t/n*(n-1)
LET eul=t
END FUNCTION

EXTERNAL FUNCTION moeb(n) !メビウス関数 μ(n)
LET W=1
DO WHILE n>1
   LET P=prmdiv(n)
   IF MOD(n,P^2)=0 THEN
      LET W=0
      EXIT DO
   END IF
   LET W=-W
   LET n=INT(n/P)
LOOP
LET moeb=W
END FUNCTION

EXTERNAL FUNCTION modpow(a,b,n) !a^b≡x mod n のxを返す
IF b=0 THEN
   LET modpow=1
ELSE
   LET S=1
   DO WHILE b>0
      IF MOD(b,2)=1 THEN LET S=MOD(S*a,n) !ビットが１なら計算する
      LET b=INT(b/2) !べき乗bを２進展開する
      LET a=MOD(a*a,n)
   LOOP
END IF
LET modpow=S
END FUNCTION

EXTERNAL FUNCTION modinv(a,n) !nを法としたaの逆元　a*x (mod n)=1
LET M=n
LET Sa=1
LET Ta=0
DO WHILE M<>0
   LET Q=INT(a/M)
   LET U=a-Q*M
   LET Ua=Sa-Q*Ta
   LET a=M
   LET Sa=Ta
   LET M=U
   LET Ta=Ua
LOOP
IF a<>1 THEN
   LET modinv=0
ELSE
   IF Sa<0 THEN LET Sa=Sa+n
   LET modinv=Sa
END IF
END FUNCTION

EXTERNAL FUNCTION prm(n) !n番目の素数　※nは１以上
DIM prime(n) !素数列
LET prime(1)=2 !１番目は２
LET k=2 !k番目
LET x=1 !検証する自然数
DO WHILE k<=n !N番目まで
   LET x=x+2 !奇数が対象
   LET j=1 !見つかった素数の倍数かどうか確認する
   DO WHILE j<k AND MOD(x,prime(j))<>0 !倍数なら途中で終了
      LET j=j+1
   LOOP
   IF j=k THEN !新しく見つかった素数を記録する
      LET prime(k)=x
      LET k=k+1
   END IF
LOOP
LET prm=prime(n)
END FUNCTION

EXTERNAL FUNCTION nxtprm(n) !n+1番目の素数
LET nxtprm=prm(n+1)
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

EXTERNAL FUNCTION lcm(a,b) !最小公倍数
LET lcm=a*b/gcd(a,b)
END FUNCTION


!ユーザー定義

EXTERNAL FUNCTION fnSigma(n) !約数の和 σ(n)
LET S=1
DO WHILE n>1
   LET W=1
   LET P=prmdiv(n)
   DO
      LET W=W*P+1
      LET n=INT(n/P)
   LOOP WHILE MOD(n,P)=0
   LET S=S*W
LOOP
LET fnSigma=S
END FUNCTION
 

Re: プログラムの書き直し

 投稿者：GAI  投稿日：2008年12月18日(木)19時29分52秒 		返信・引用
  > No.171[元記事へ]

山中和義さんへのお返事です。

> UBASICの整数論関連の組込み関数を移植しました。

本（UBASICによるコンピュータ整数論：木田祐司・牧野潔夫著＜日本評論社＞）
で勉強していてる最中に、この中で使われている関数が十進basicでも使えたらなと思っている所に、山中さんから願ってもない移植のプログラムを提供して頂いたところでした。

整数論はやればやるだけ奥深さが感じられ、ガウスやオイラーなど名だたる天才が最も惹きつけられた魅力が潜んでいることがおぼろげながら窺い知れます。
当時、コンピュータという道具無しに直感（霊感？）を働かせて背後に潜む神秘さに心を奪われていった先人たちの感動を現代の魔法のマシーンを利用して凡人でも再経験して行きたいと思っています。
なにせ独学でやっていますので誤解や回り道をしているかもしれません。

整数論を誰にでも理解していけるようにコンピュータプログラムを組んでいく事はとても大切な分野ではないかと思う次第です。
この分野の書籍があまり無いように感じます。（私の不勉強かもしれませんが・・・）
整数論で使われるいろいろな関数をEXTERNAL FUNCTION として道具箱にいれておけば、いろいろな現象を再現できる可能性が出てきます。
こんな道具があったら便利だろうなと感じましたらお頼みしますのでよろしくお願いします。
また、この分野で驚くべき式や結論をご存知でしたらぜひともお教えください。 		 

Re: プログラムの書き直し

 投稿者：荒田浩二  投稿日：2008年12月19日(金)12時24分41秒 		返信・引用
  > No.171[元記事へ]

山中和義さんへのお返事です。


> !素数の生成
> PRINT prm(100) !541
> PRINT nxtprm(999) !prm(1000)=7919
> !PRINT nxtprm(9999) !prm(10000)=104729
>
> EXTERNAL FUNCTION prm(n) !n番目の素数　※nは１以上
> DIM prime(n) !素数列
> LET prime(1)=2 !１番目は２
> LET k=2 !k番目
> LET x=1 !検証する自然数
> DO WHILE k<=n !N番目まで
>    LET x=x+2 !奇数が対象
>    LET j=1 !見つかった素数の倍数かどうか確認する
>    DO WHILE j<k AND MOD(x,prime(j))<>0 !倍数なら途中で終了
>       LET j=j+1
>    LOOP
>    IF j=k THEN !新しく見つかった素数を記録する
>       LET prime(k)=x
>       LET k=k+1
>    END IF
> LOOP
> LET prm=prime(n)
> END FUNCTION
>
> EXTERNAL FUNCTION nxtprm(n) !n+1番目の素数
> LET nxtprm=prm(n+1)
> END FUNCTION


n番目の素数を返す関数を改良しました。
prm(10000)ならば5秒、prm(100000)ならば35秒ほどで求まります。
prm(5761455)=99999989(10^8以下最大素数) を求めるには2進モードで約37分です。

EXTERNAL FUNCTION prm(n) ! n番目の素数
DIM prime(n)
FOR i=1 TO MIN(n,10)
   READ prime(i)
NEXT i
DATA 2,3,5,7,11,13,17,19,23,29
FOR i=11 TO n
   LET m30=MOD(prime(i-1),30)
   IF m30=1 OR m30=23 THEN LET a=prime(i-1)+6 ELSE LET a=prime(i-1)-2*MOD(m30,3)+6
   DO
      LET sqra=SQR(a)
      FOR j=4 TO i-1
         IF MOD(a,prime(j))=0 THEN EXIT FOR
         IF prime(j)>=sqra THEN
            LET prime(i)=a
            EXIT DO
         END IF
      NEXT j
      LET m30=MOD(a,30)
      IF m30=1 OR m30=23 THEN LET a=a+6 ELSE LET a=a-2*MOD(m30,3)+6
   LOOP
NEXT i
LET prm=prime(n)
END FUNCTION 		 

Re: プログラムの書き直し

 投稿者：山中和義  投稿日：2008年12月19日(金)16時34分17秒 		返信・引用 　編集済
  > No.173[元記事へ]

荒田浩二さんへのお返事です。

>  n番目の素数を返す関数を改良しました。

助かります。素数を素早く扱うかがこの手のプログラムには必要ですね。

nxtprm(x)関数は、間違っていましたので差し替えておきます。
EXTERNAL FUNCTION nxtprm(x) !xより大きい素数の最小のもの
   DIM prime(x)

   FOR i=1 TO 10 !最初の10個
      READ prime(i)
      IF x<prime(i) THEN
         LET nxtprm=prime(i)
         EXIT FUNCTION
      END IF
   NEXT i
   DATA 2,3,5,7,11,13,17,19,23,29

   FOR i=11 TO INT(x) !11個目以降
      LET m30=MOD(prime(i-1),30)
      IF m30=1 OR m30=23 THEN LET a=prime(i-1)+6 ELSE LET a=prime(i-1)-2*MOD(m30,3)+6
      DO
         LET sqra=SQR(a)
         !!!LET sqra=INTSQR(a) !<----- ※有理数モード
         FOR j=4 TO i-1
            IF MOD(a,prime(j))=0 THEN EXIT FOR
            IF prime(j)>=sqra THEN
               LET prime(i)=a
               EXIT DO
            END IF
         NEXT j
         LET m30=MOD(a,30)
         IF m30=1 OR m30=23 THEN LET a=a+6 ELSE LET a=a-2*MOD(m30,3)+6
      LOOP

      IF x<prime(i) THEN
         LET nxtprm=prime(i)
         EXIT FUNCTION
      END IF
   NEXT i

   PRINT "見つかりません。"
   STOP
END FUNCTION



●prm(n)関数を使ったものを追加しておきます。（定義済みのサブルーチンは省略）
!素数の個数
!PRINT fnPrimePi(77777)


!原始根 genshi3
FOR LP=1 TO 100
   LET P=prm(LP) !最初の100個の素数に対して

   PRINT USING "##### ### |": P,fnGenshi(P);
   IF MOD(LP,5)=0 THEN PRINT
NEXT LP
PRINT


!原始根 genshi2
FOR LP=1 TO 100
   LET P=prm(LP) !最初の100個の素数に対して

   LET G=1
   IF P<>2 THEN
50       LET G=G+1
         LET W=1
         FOR i=1 TO P-2
            LET W=MOD(W*G,P)
            IF W=1 THEN GOTO 50
         NEXT i
      END IF

      PRINT USING "##### ### |": P,G;
      IF MOD(LP,5)=0 THEN PRINT
   NEXT LP
   PRINT


END


EXTERNAL FUNCTION fnPrimePi(X) !実数xに対しx以下の素数の個数
   LET S=1
   LET E=10000 !100,000以下の素数は10,000個未満だから　※
   DO WHILE E>S+1
      LET K=INT((S+E)/2) !２分探索
      IF prm(K)<=X THEN LET S=K ELSE LET E=K
   LOOP
   LET fnPrimePi=S
END FUNCTION

EXTERNAL FUNCTION fnGenshi(P) !原始根
   LET G=1
   LET N=P-1
   IF P<>2 THEN
180    LET G=G+1
       LET Nw=N
       DO
          LET Div=prmdiv(Nw)
          DO WHILE MOD(Nw,Div)=0
             LET Nw=INT(Nw/Div)
          LOOP
          IF modpow(G,INT(N/Div),P)=1 THEN GOTO 180
       LOOP UNTIL Nw=1
    END IF
    LET fnGenshi=G
 END FUNCTION
 

uBASIC からの、移植

 投稿者：SECOND  投稿日：2008年12月19日(金)17時30分43秒 		返信・引用 　編集済
  !
! uBASIC からの、移植。※原本は、ココにあります。(その他、多数同梱)
!  http://www.rkmath.rikkyo.ac.jp/~kida/ubgraph.lzh

!  アスキー・セーブ しなおしたもの。
!  http://homepage2.nifty.com/neutro/asm/ubgraph(ASC).lzh

! MAZE.UB
!---------------------------------
!　迷路を作る
!　Pascal version from
!　奥村晴彦　コンピュータアルゴリズム事典（技術評論社） 349-350
!　〔付〕迷路を解く  by 岩瀬順一

OPTION BASE 0
SET WINDOW 0,500, 500,0
!
LET Xmax=90
LET Ymax=90
LET MaxCan=INT(Xmax*Ymax/4) !　must Ymax<=Xmax
LET Bsize=4
LET Xoff=INT((500-Xmax*Bsize)/2)
LET Yoff=INT((500-Ymax*Bsize)/3) ! 20
DIM Map_(Xmax,Ymax)
DIM CanX_(MaxCan),CanY_(MaxCan),DirX_(MaxCan),DirY_(MaxCan)
RANDOMIZE
!
FOR I=0 TO 1
   FOR J=0 TO Ymax
      LET Map_(I,J)=1
      LET Map_(Xmax-I,J)=1
   NEXT J
NEXT I
FOR J=0 TO 1
   FOR I=0 TO Xmax
      LET Map_(I,J)=1
      LET Map_(I,Ymax-J)=1
   NEXT I
NEXT J
LET X=2
FOR Y=4 TO Ymax-2
   CALL DOT_(X,Y)
NEXT Y
LET X=Xmax-2
FOR Y=2 TO Ymax-4
   CALL DOT_(X,Y)
NEXT Y
LET Y=2
FOR X=2 TO Xmax-2
   CALL DOT_(X,Y)
NEXT X
LET Y=Ymax-2
FOR X=2 TO Xmax-2
   CALL DOT_(X,Y)
NEXT X
LET Ncan=0
FOR I=2 TO INT(Xmax/(2)) -2
   CALL InsCan_(I*2,2)
   CALL InsCan_(I*2,Ymax-2)
NEXT I
FOR J=2 TO INT(Ymax/(2)) -2
   CALL InsCan_(2,J*2)
   CALL InsCan_(Xmax-2,J*2)
NEXT J
LET Ndir=4
LET DirX_(1)=2
LET DirY_(1)=0
LET DirX_(2)=0
LET DirY_(2)=2
LET DirX_(3)=-2
LET DirY_(3)=0
LET DirX_(4)=0
LET DirY_(4)=-2
DO WHILE Ncan>0
   CALL Selcan_(I,J)
   DO
      LET Ndir=4
      DO
         CALL SelDir_(DI,DJ)
         LET Ok=1-Map_(I+DI,J+DJ)
      LOOP UNTIL Ok<>0 OR Ndir=0
      IF Ok<>0 THEN
         CALL DOT_(I+INT(DI/(2)),J+INT(DJ/(2)) )
         LET I=I+DI
         LET J=J+DJ
         CALL DOT_(I,J)
         CALL InsCan_(I,J)
      END IF
   LOOP UNTIL NOT Ok<>0
LOOP

SUB DOT_(X,Y)
   LET Map_(X,Y)=1
   ! SET AREA COLOR 5
   PLOT AREA: Bsize*X+Xoff,Bsize*Y+Yoff;Bsize*X+Xoff+Bsize-1,Bsize*Y+Yoff;Bsize*X+Xoff+Bsize-1,Bsize*Y+Yoff+Bsize-1;Bsize*X+Xoff,Bsize*Y+Yoff+Bsize-1
END SUB

SUB InsCan_(I,J)
   LET Ncan=Ncan+1
   LET CanX_(Ncan)=I
   LET CanY_(Ncan)=J
END SUB

SUB Selcan_(I,J)
   local R
   LET R=int(Ncan*rnd)+1
   LET I=CanX_(R)
   LET J=CanY_(R)
   LET CanX_(R)=CanX_(Ncan)
   LET CanY_(R)=CanY_(Ncan)
   LET Ncan=Ncan-1
END SUB

SUB SelDir_(I,J)
   local R
   LET R=int(Ndir*rnd)+1
   LET I=DirX_(R)
   LET J=DirY_(R)
   LET DirX_(R)=DirX_(Ndir)
   LET DirY_(R)=DirY_(Ndir)
   LET DirX_(Ndir)=I
   LET DirY_(Ndir)=J
   LET Ndir=Ndir-1
END SUB

!--------------------------------------------------
!　　　　　　この先は、岩瀬が書いた。
!　　　　　　方針：袋小路があったら、ぬりつぶす
!
PLOT TEXT,AT Xoff*1.2,20 :"何かキーを押してください。迷路を解きます。"
PLOT TEXT,AT Xoff*1.2,40 :"Push any key to solve the maze."
CHARACTER INPUT s$
SET AREA COLOR 0
PLOT AREA :Xoff,0; 500,0; 500,40; Xoff,40
!
LET Map_(2,3)=0
LET Map_(Xmax-2,Ymax-3)=0 !　出口、入口は０にする
FOR I=0 TO Xmax !　　　　　　迷路の外は１にする
   FOR J=0 TO 1
      LET Map_(I,J)=0
   NEXT J
   FOR J=Ymax-1 TO Ymax
      LET Map_(I,J)=0
   NEXT J
NEXT I
FOR J=0 TO Ymax
   FOR I=0 TO 1
      LET Map_(I,J)=0
   NEXT I
   FOR I=Xmax-1 TO Xmax
      LET Map_(I,J)=0
   NEXT I
NEXT J
!
!
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
!$$$$$$$$$ MAIN ROUTINE TO SOLVE THE MAZE $$$$$$$$$$$$$$$$$$$$$$$$$$$
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
!
FOR K=6 TO Ymax
   FOR J=3 TO K-3
      CALL Routine_
   NEXT J
NEXT K
FOR K=Ymax+1 TO Xmax
   FOR J=3 TO Ymax-3
      CALL Routine_
   NEXT J
NEXT K
FOR K=Xmax+1 TO Xmax+Ymax-6
   FOR J=K-Xmax+3 TO Ymax-3
      CALL Routine_
   NEXT J
NEXT K

SUB Routine_
   LET I=K-J
   IF fnCheck(I,J)< 3 THEN EXIT SUB
   LET Ii=I
   LET Jj=J
   DO
      CALL Fil_(Ii,Jj)
      IF Map_(Ii-1,Jj)=0 THEN
         LET Ii=Ii-1
      ELSEIF Map_(Ii,Jj+1)=0 THEN
         LET Jj=Jj+1
      ELSEIF Map_(Ii+1,Jj)=0 THEN
         LET Ii=Ii+1
      ELSEIF Map_(Ii,Jj-1)=0 THEN
         LET Jj=Jj-1
      END IF
   LOOP UNTIL fnCheck(Ii,Jj)<>3
END SUB

SUB Fil_(X,Y)
   LET Map_(X,Y)=1
   SET AREA COLOR 4 !3
   PLOT AREA: Bsize*X+Xoff,Bsize*Y+Yoff;Bsize*X+Xoff+Bsize-1,Bsize*Y+Yoff;Bsize*X+Xoff+Bsize-1,Bsize*Y+Yoff+Bsize-1;Bsize*X+Xoff,Bsize*Y+Yoff+Bsize-1
END SUB

FUNCTION fnCheck(I,J) !　袋小路の時３をかえす
   LET fnCheck=0
   IF Map_(I,J)=1 THEN EXIT FUNCTION
   LET fnCheck=Map_(I-1,J)+Map_(I,J+1)+Map_(I+1,J)+Map_(I,J-1)
END FUNCTION

END 		 

トランプ占いでの確率

 投稿者：GAI  投稿日：2008年12月20日(土)08時05分32秒 		返信・引用
  １．トランプ（５２枚）をよく切って、時計回りに１時の位置から文字盤のようにカードを裏にして１２枚並べ、中心に１３枚目のカードを置く。これを繰り返し全てのカードを配る。

２．１３枚目の一番下のカードを引く。
そのカードが５の時は５時の位置の一番上に表向きにして置き、５時の位置の一番下のカードを引く。
このカードの数字の示す位置に表向きに置き、その位置の一番下のカードを引く。

３．１３枚目の位置のＫが４枚でるまで２．を繰り返す。


このルールで１２組（1時から１２時の組）が全て表になってしまう確率をみてみたいのですが、（できたら０組〜１２組での確率分布も知りたい。）
この占いをコンピュータにさせて頂けませんか？ 		 

Re: トランプ占いでの確率

 投稿者：SECOND  投稿日：2008年12月20日(土)13時12分19秒 		返信・引用
  > No.176[元記事へ]

GAIさんへのお返事です。

昨近のＴＶで見られる、カード・マジックの中に、物理的には、有り得ないものが、
多々見られます、鳥肌立てて見ているよりは、遅れた頭をかかえる場合、なのか？？

露骨に不思議なマジック、超常現象なども、代数学上の記述、異次元間の写像、
即ち、行列、マトリクスで、解き明かされる日が、将来来るようにも、思います。
世界も、私たち自身も、ひょっとして、巨大なだけの数学モデルかも・・！？
私は、頭悪くて代数学を、殆んど理解できませんが、その未来に魅せられています。 		 

Re: トランプ占いでの確率

 投稿者：山中和義  投稿日：2008年12月20日(土)14時56分45秒 		返信・引用
  > No.176[元記事へ]

GAIさんへのお返事です。

> このルールで１２組（1時から１２時の組）が全て表になってしまう確率をみてみたいのですが、（できたら０組〜１２組での確率分布も知りたい。）


パーフェクト（すべてのカードがめくられた状態）になるには、
カードをめくっていった順を考えると、最後の52枚目にＫのカードがあればよい。
これが4通りで、残り51枚の並び順（めくった順）は51!通りだから、4*51!通りとなる。

また、52枚のカードを並べる順は、52!通り。

したがって、パーフェクトは、4*51!/52!=4/52=1/13となると思います。



めくった回数の期待値は、42回。分布は、１時から１２時は、3.2枚。１３時は4枚。 		 

Re: トランプ占いでの確率

 投稿者：荒田浩二  投稿日：2008年12月20日(土)20時21分44秒 		返信・引用 　編集済
  > No.176[元記事へ]

GAIさんへのお返事です。

10万回の試行で、4枚とも表になる組数はすべて同じ確率で出現すると出ました。


  組   確率  平均枚数
   0  .07669  25.06枚
   1  .07519  31.20枚
   2  .07792  35.14枚
   3  .07686  38.10枚
   4  .07674  40.48枚
   5  .07722  42.48枚
   6  .07848  44.25枚
   7  .07573  45.84枚
   8  .07778  47.28枚
   9  .07741  48.59枚
  10  .07723  49.81枚
  11  .07564  50.94枚
  12  .07711  52.00枚
              42.41枚


DECLARE EXTERNAL SUB sort
PUBLIC NUMERIC c
LET tt=TIME
LET s=4
LET n=13
LET c=s*n
DIM check(c),card(c),position(n,s),face(n),total(0 TO n-1),count(0 TO n-1)
LET test=100000 ! 100000で125秒
FOR t=1 TO test
   CALL prep
   CALL play
NEXT t
LET cc=0
PRINT " 組   確率  平均枚数"
FOR i=0 TO n-1
   PRINT USING " ##  .#####  ##.##枚" : i,total(i)/test,count(i)/total(i)
   LET cc=cc+count(i)
NEXT i
PRINT USING "             ##.##枚" : cc/test
PRINT INT(TIME-tt);"sec"

SUB prep
   FOR i=1 TO c
      LET check(i)=RND
   NEXT i
   CALL sort(check,card)
   !MAT PRINT card;
   FOR j=1 TO s
      FOR i=1 TO n
         LET position(i,j)=card((j-1)*n+i)
      NEXT i
   NEXT j
   !MAT PRINT position;
END SUB
SUB play
   MAT face=ZER
   LET cc=0
   CALL open_card(n)
   !MAT PRINT face;
   LET f=0
   FOR i=1 TO n-1
      IF face(i)=s THEN LET f=f+1
   NEXT i
   LET total(f)=total(f)+1
   LET count(f)=count(f)+cc
END SUB
SUB open_card(nn)
   LET cc=cc+1
   LET look=position(nn,1)
   FOR j=1 TO s-1
      LET position(nn,j)=position(nn,j+1)
   NEXT j
   LET p=MOD(look,n)+1
   !PRINT p;
   LET face(p)=face(p)+1
   IF face(n)=s THEN EXIT SUB
   CALL open_card(p)
END SUB
END

REM 十進BASIC添付"\BASICw32\Library\SORT2.LIB"より
! ixにはmと下限，上限を一致させた空の配列を指定する。
! mは参照されるのみ。
! ixにmの添字を大きさの順に並べて返す。
! つまり，m(ix(1))≦m(ix(2))≦m(ix(3))≦･･･となる。
EXTERNAL SUB sort(m(),ix())
FOR i=1 TO c
   LET ix(i)=i
NEXT i
CALL q_sort(m,ix,1,c)
END SUB
EXTERNAL SUB q_sort(m(),a(),l,r)
IF r<=l THEN
   EXIT SUB
ELSE
   LET i=l-1
   LET j=r
   LET pv=m(a(r))
   DO
      DO
         LET i=i+1
      LOOP UNTIL pv<=m(a(i))
      DO
         LET j=j-1
      LOOP UNTIL j<=i OR m(a(j))<=pv
      IF j<=i THEN EXIT DO
      LET t=a(i)
      LET a(i)=a(j)
      LET a(j)=t
   LOOP
   LET t=a(i)
   LET a(i)=a(r)
   LET a(r)=t
   CALL q_sort(m,a,l,i-1)
   CALL q_sort(m,a,i+1,r)
END IF
END SUB
 		 

Re: トランプ占いでの確率

 投稿者：SECOND  投稿日：2008年12月21日(日)07時58分9秒 		返信・引用 　編集済
  > No.178[元記事へ]

山中和義さんへのお返事です。

問題が、よくわからないので、かん違いかもしれませんが、
パーフェクトの、4*51! 通りの中で、
１３時の位置に、４枚のＫが全て集まる配置の、4!*48! 通りは、
スタート時点で、無限ループに落ちるため、除かなくてよろしいですか。

すみません、カン違いでした。 		 

ルールの詳細

 投稿者：GAI  投稿日：2008年12月21日(日)08時24分49秒 		返信・引用
  １．トランプ（５２枚）をよく切って、時計回りに１時の位置から文字盤のようにカードを裏にして１２枚並べ、中心に１３枚目のカードを置く。これを繰り返し全てのカードを配る。
　　　　　　　　　　　＊
　　　　　　　　　　＊　＊
　　　　　　　　　＊　　　＊
　　　　　　　　＊　　＊　　＊
　　　　　　　　　＊　　　＊
　　　　　　　　　　＊　＊
　　　　　　　　　　　＊


２．１３枚目（真ん中のパケット）の一番下のカードを引く。
そのカードが５の時は５時の位置の一番上に表向きにして置き、５時の位置の一番下のカードを引く。
このカードの数字がQなら１２時の示す位置に表向きに置き、１２時の位置の一番下のカードを引く。
これがKなら真ん中の山（時計の針の中心）の一番上に表向きで置く。
次に、この山（中心部分のパケット）の一番下のカードを引き出しそのカードの数字に従い次の作業をしていく。
＜これを続けていくと、各時刻の文字盤数に対応する表向きのカードが集まっていく。＞

３．１３枚目の位置（中心に置かれたパケット）に4枚のＫが表向きに置かれるまで２．を繰り返す。


一番下にKを仕込んでやってみましたが、最後まで行かず途中で終わってしまいました。 		 

Re: ルールの詳細

 投稿者：荒田浩二  投稿日：2008年12月21日(日)09時32分27秒 		返信・引用
  > No.181[元記事へ]

GAIさんへのお返事です。

次のように下からカードを配置してみてください。パーフェクトになるはずです。
私のあげたプログラムで3回目、18回目、20回目の例です。
パーフェクトは最後にＫを引くわけですから、Ｋを一番上に仕込めば達成する確率が上がります。
  
   1時   12 11  6 12
   2時    2  2  8  6
   3時    4  9  1  2
   4時    1  1  9 13
   5時   12 10 11  2
   6時    9  5 10  7
   7時    4 10  3  4
   8時   12  7 11 11
   9時    6  7  3  8
  10時    7  8  9  3
  11時    8 10  1  6
  12時    5 13 13 13
  13時    5  4  3  5

   1時    7  4  1  9
   2時    7  9  1  6
   3時    1  5  3  9
   4時    5 11  4  6
   5時   13  2  2  3
   6時    4  8 10 13
   7時   11  3 12 11
   8時   10  8  6  2
   9時    5  9  7  4
  10時    6 11  5  7
  11時    8  8 13 13
  12時    3 12 10  2
  13時    1 12 12 10

   1時   10  3  9  3
   2時    2  8  8 12
   3時    4  1  2 10
   4時    4  6  1 12
   5時   13 11  6  7
   6時   11  1  1 12
   7時    4  5  2 13
   8時    8  6  8  2
   9時   12  9  6  5
  10時    7  3 11 13
  11時   11 10  4  3
  12時    7 10  7  5
  13時   13  9  9  5
 		 

今日の運勢を最高に

 投稿者：GAI  投稿日：2008年12月21日(日)12時16分46秒 		返信・引用
  > No.182[元記事へ]

荒田浩二さんへのお返事です。


実際にトランプでやらないでも占えちゃうとはありがたいです。
確率が等分であるとは思ってもいませんでした。
パーフェクトが達成するためには１３回をめどにやればいいのか！
荒田さんのプログラムでtest=1とおいてパーフェクトになるまでやって今日の運勢を毎日
最高にしようっと！！

ところで
パーフェクト達成のためのパターンを可能なだけ集めたいのですがどのようにすればよろしいのでしょうか？
そこからどんな条件が必要なのか知りたいですが。 		 

時計のプログラミング

 投稿者：田村幸助  投稿日：2008年12月22日(月)11時09分20秒 		返信・引用
  十進BASICで時計を作りたいのですが、
プログラムを教えていただけませんか？
時計はアナログ時計です。 		 

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

 投稿者：山中和義  投稿日：2008年12月22日(月)11時45分27秒 		返信・引用
  > No.184[元記事へ]

田村幸助さんへのお返事です。

> 時計はアナログ時計です。

シンプルです。単位円上に文字盤を描いています。いろいろ改良してください。

秒について
他の手法（たとえば、TIME関数）で小数点以下（ミリ秒）を取得できますが、
正確な値は期待できませんので、秒針をなめらかに動かすことは難しいかと思います。

!アナログ時計

SET WINDOW -1.2,1.2,-1.2,1.2 !表示領域
SET TEXT JUSTIFY "center","half" !文字表示の書式

DO
   LET t$=TIME$ !時刻をhh:mm:ss形式で得る
   LET h=VAL(t$(1:2)) !数値へ
   LET m=VAL(t$(4:5))
   LET s=VAL(t$(7:8))

   SET DRAW mode hidden !ちらつみ防止（開始）
   CLEAR

   FOR i=1 TO 12 !文字盤
      LET th=PI/2-2*PI*i/12 !Ｙ軸から時計まわり
      PLOT TEXT ,AT COS(th),SIN(th): STR$(i) !円周上
   NEXT i

   LET th=PI/2-2*PI*(h + m/60)/12 !時針
   PLOT LINES: 0,0; 0.6*COS(th),0.6*SIN(th)

   LET th=PI/2-2*PI*m/60 !分針
   PLOT LINES: 0,0; 0.9*COS(th),0.9*SIN(th)

   LET th=PI/2-2*PI*s/60 !秒針
   PLOT LINES: 0,0; 0.8*COS(th),0.8*SIN(th)

   SET DRAW mode explicit !ちらつき防止（終了）
LOOP

END
 

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

 投稿者：荒田浩二  投稿日：2008年12月22日(月)18時34分45秒 		返信・引用 　編集済
  > No.185[元記事へ]

山中和義さんへのお返事です。


上書きせていただきました。
調べたら1分間に約8200回の描画をしていたので、秒の更新があったときに描画するようにしました。
文字盤部分もLOOPから出して描画時間を節約。
長針・短針を絵定義にし、PICTURE hand を書き換えることにより針のデザイン変更を容易にできるようにしました。


!アナログ時計(改)

SET WINDOW -1.2,1.2,-1.2,1.2 !表示領域
SET TEXT JUSTIFY "center","half" !文字表示の書式
SET TEXT HEIGHT 1.2/10
SET AREA COLOR 5 ! 水色
SET POINT STYLE 4 ! 。
DRAW disk WITH SCALE(1.1)
FOR i=1 TO 12 !文字盤
   LET th=PI/2-2*PI*i/12 !Ｙ軸から時計まわり
   PLOT TEXT ,AT COS(th),SIN(th): STR$(i) !円周上
   FOR j=1 TO 4
      LET th=PI/2-2*PI*(5*i+j)/60
      PLOT POINTS : 0.94*COS(th),0.94*SIN(th)
   NEXT j
NEXT i

SET LINE COLOR "RED"
LET t0=INT(TIME)
DRAW clock(t0)

DO
   IF TIME-t0>=1 THEN ! 秒の更新で描画
      LET t0=INT(TIME)
      DRAW clock(t0)
   END IF
LOOP

PICTURE clock(t0)
   LET h=INT(t0/3600) !数値へ
   LET m=INT((t0-3600*h)/60)
   LET s=MOD(t0,60)

   SET DRAW mode hidden !ちらつき防止（開始）
   SET AREA COLOR 0 ! 白
   DRAW disk WITH SCALE(0.9) !針描画部分のみクリア

   LET th=PI/2-2*PI*(h + m/60)/12 !時針
   DRAW hand(3) WITH SCALE(0.6,1)*ROTATE(th)

   LET th=PI/2-2*PI*m/60 !分針
   DRAW hand(2) WITH SCALE(0.86,1)*ROTATE(th)

   LET th=PI/2-2*PI*s/60 !秒針
   PLOT LINES: 0,0; 0.8*COS(th),0.8*SIN(th)

   SET DRAW mode explicit !ちらつき防止（終了）
END PICTURE

PICTURE hand(col) !針描画
   SET AREA COLOR col
   PLOT AREA : -0.05,-0.03;1,-0.03;1,0.03;-0.05,0.03
END PICTURE

END
 		 

液体万華鏡

 投稿者：SECOND  投稿日：2008年12月23日(火)01時01分5秒 		返信・引用 　編集済
  !
!　液体万華鏡
!
!　錯視が、生じ難いよう１回転毎に、逆回転させるようにした。
!　液面の変化に伴う容積変動を、±3.85% 以下まで押えた。

!-----------------
!※正確な液面には、なっていません。改造歓迎。

SET TEXT BACKGROUND "OPAQUE"
SET WINDOW -1/4,1/4, -1/4,1/4
DIM x(2),y(2)

!中心(1/2,1/sqr(3)/2)、半径 r の円周上の点(x0(θ),y0(θ))
DEF x0(θ)=r*COS(θ)+1/2
DEF y0(θ)=r*SIN(θ)+1/SQR(3)/2

!中心(1/2,1/sqr(3)/2)、半径 r の円周上の点(x0(θ),y0(θ))、に接する直線
DEF f(x)=TAN(θ+PI/2)*(x-x0(θ))+y0(θ)

!＿直線１とf(x)との交点(x1,y1)
!y=0 =TAN(θ+PI/2)*(x-x0(θ))+y0(θ)
DEF x1(θ)= -y0(θ)/TAN(θ+PI/2)+x0(θ)
LET y1=0

!／直線２とf(x)との交点(x2,y2)
!y=SQR(3)*x =TAN(θ+PI/2)*(x-x0(θ))+y0(θ)
DEF x2(θ)=(-y0(θ)+TAN(θ+PI/2)*x0(θ))/(TAN(θ+PI/2)-SQR(3))
DEF y2(θ)=SQR(3)*x2(θ)

!＼直線３とf(x)との交点(x3,y3)
!y=-SQR(3)*(x-1) =TAN(θ+PI/2)*(x-x0(θ))+y0(θ)
DEF x3(θ)=(SQR(3)-y0(θ)+TAN(θ+PI/2)*x0(θ))/(TAN(θ+PI/2)+SQR(3))
DEF y3(θ)=-SQR(3)*(x3(θ)-1)

SET AREA COLOR 5
LET s00=SQR(3)/4
LET φ=0.001
LET stp=PI/180
DO
   IF 2*PI<=ABS(φ) THEN LET stp=-stp !　(＋)左回転 (−)右回転
   LET φ=REMAINDER(φ, 2*PI) +stp
   !-----
   LET θ=φ+SIN(φ*51)*0.1+SIN(φ*49)*0.05 !　水面揺れ..有り
   !LET θ=φ !　水面揺れ..無し
   !-----
   LET r=0.19985-0.00355*COS(θ*6) !　液面補正、残誤差±3.85%
   LET x00=0
   LET y00=0
   LET i=1
   LET x(i)=x1(θ)
   LET y(i)=y1
   IF 0<=x(i) AND x(i)<=1 AND 0<=y(i) AND y(i)<=SQR(3)/2 THEN LET i=i+1
   LET x(i)=x2(θ)
   LET y(i)=y2(θ)
   IF 0<=x(i) AND x(i)<=1 AND 0<=y(i) AND y(i)<=SQR(3)/2 THEN LET i=i+1.01
   IF i< 3 THEN
      LET x(i)=x3(θ)
      LET y(i)=y3(θ)
      IF 2< i THEN
         LET x00=1/2
         LET y00=SQR(3)/2
      ELSE
         LET x00=1
         LET y00=0
      END IF
   END IF
   LET ss2=ABS((x(1)-x00)*(y(2)-y00)-(y(1)-y00)*(x(2)-x00))
   SET DRAW mode hidden
   CLEAR
   DRAW D4(3) WITH SHIFT(-1/2,-1/SQR(3)/2)*ROTATE(φ-PI/2)
   DRAW center WITH SHIFT(-1/2,-1/SQR(3)/2)*ROTATE(-φ-PI/2)*SCALE(-1/8,1/8)
   PLOT TEXT,AT 0.13,0.23:"右クリックで終了"
   SET DRAW mode explicit
   WAIT DELAY 0.05
   MOUSE POLL mx,my,mlb,mrb
LOOP UNTIL mrb>=1

PICTURE center
   SET LINE COLOR 2
   SET LINE width 2
   PLOT LINES:0,0;1,0;1/2,SQR(3)/2;0,0
   SET LINE width 1
   SET LINE COLOR 1
END PICTURE

!------
PICTURE D4(k)
   IF 0< k THEN
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*SHIFT(1/4,SQR(3)/4) !　上
      DRAW D4(k-1) WITH SCALE(1/2,-1/2)*SHIFT(1/4,SQR(3)/4) !　中
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*ROTATE(-PI*2/3)*SHIFT(1/4,SQR(3)/4) !左
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*ROTATE(PI*2/3)*SHIFT(1,0) !　右
   ELSE
      DRAW Set01
   END IF
END PICTURE

!------ 種の三角図
PICTURE Set01
   IF s00< ss2 THEN
      IF x00=0 THEN PLOT AREA:x(1),y(1);x(2),y(2);1/2,SQR(3)/2;1,0
      IF x00=1 THEN PLOT AREA:x(1),y(1);x(2),y(2);1/2,SQR(3)/2;0,0
      IF x00=1/2 THEN PLOT AREA:x(1),y(1);x(2),y(2);1,0;0,0
   ELSE
      PLOT AREA:x(1),y(1);x(2),y(2);x00,y00
   END IF
   PLOT LINES:x(1),y(1);x(2),y(2)
   PLOT LINES:0,0;1,0;1/2,SQR(3)/2;0,0
END PICTURE

END 		 

Re: 今日の運勢を最高に

 投稿者：山中和義  投稿日：2008年12月23日(火)10時35分56秒 		返信・引用 　編集済
  > No.183[元記事へ]

GAIさんへのお返事です。

> パーフェクト達成のためのパターンを可能なだけ集めたいのですがどのようにすればよろしいのでしょうか？
> そこからどんな条件が必要なのか知りたいですが。


めくられるカードには、次のような単方向リスト（リンク）が構成されていればよいと思います。

●「ｎ枚をめくる」カード束のつくり方
４枚のＫを含むｎ枚（n=4〜52）のカードを用意する。（５２−ｎ枚は除いておく）
パーフェクトなら５２枚となる。

（step.1）表向きに、上からＫ□■◇・・・○◆の順の束とする。□などの部分は何でもよい。
　　　　最初のＫは４枚から１つを選ぶ。□■◇・・・○◆には残り３枚のＫが含まれる。

（step.2）次の手順で、逆配置の時計のようにカードを置く。
　　　　　　　12
　　　　　　１　11
　　　　　２　　　10
　　　　３　　13　　９
　　　　　４　　　８
　　　　　　５　７
　　　　　　　６

　　　　上から１番目のカード（Ｋ）を、２番目のカード（□）の指す位置に置く。
　　　　上から２番目のカード（□）を、３番目のカード（■）の指す位置に置く。
　　　　上から３番目のカード（■）を、４番目のカード（◇）の指す位置に置く。

　　　　　：
　　　　　：
　　　　　：

　　　　上からｎ−１番目のカード（○）を、ｎ番目のカード（◆）の指す位置に置く。
　　　　上からｎ番目のカード（◆）を、１３番目の位置に置く。

　　　　テーブルの裏側から見た配置になっている。


（step.3）テーブルの表から見た配置にするため、カードを束ごと裏返しながら左右の位置を入れ替える。
　　　　１２、１３，６時の位置は裏返すのみとなる。

（step.4）組が４枚ずつになるように、除いておいた５２−ｎ枚のカードを、（無作為に）裏向きで上に重ねていく。
　　　　パーフェクトの場合はこの操作はない。

　　　　めくる前の状態になる。

（step.5）１３時位置から１２時、１１時、・・・のように（通常の）反時計まわりに１枚ずつそのままの状態で上に重ねながら回収する。



●めくられる枚数ごとの確率
「残るカード、Ｋ、めくられていくカード（３枚のＫを含む）」の並び順として考える。
右端が最初にめくられるカード（１３時の位置の底のカード）になる。
OPTION ARITHMETIC RATIONAL

LET t=fact(52)


LET s=0
FOR i=4 TO 52
   LET b=perm(48,52-i) * 4 * fact(i-1) !残るカード、Ｋ、めくられていくカード（３枚のＫを含む）
   PRINT i;"枚　確率=";b/t
   LET s=s+b/t
NEXT i


PRINT "確率=";s !検算

END


作為の「種」を蒔くことで、花を満開にすることができます。（咲き方も同様） 		 

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

 投稿者：田村幸助  投稿日：2008年12月23日(火)19時50分37秒 		返信・引用
  > No.186[元記事へ]

山中さん荒田さん
ありがとうございました。 		 

剰余の計算

 投稿者：GAI  投稿日：2008年12月24日(水)12時02分1秒 		返信・引用
  どんな大きな（１０桁ほどは欲しい）x,n,aに対しても、次の剰余が求まるプログラム
を作って頂きたいです。
x^n mod a 		 

Re: 剰余の計算

 投稿者：山中和義  投稿日：2008年12月24日(水)12時52分41秒 		返信・引用 　編集済
  > No.190[元記事へ]

GAIさんへのお返事です。

> どんな大きな（１０桁ほどは欲しい）x,n,aに対しても、次の剰余が求まるプログラム
> を作って頂きたいです。
> x^n mod a


・提供済みUBASIC関数のmodpow(1234,56,789)


・PRINT MOD(1234^56,789) !1234^56 mod 789
　多桁の整数なら有理数モードで実行します。
　x^nが大きいと時間がかかります。


nが負や実数なら検討しないといけません。 		 

Re: 剰余の計算

 投稿者：荒田浩二  投稿日：2008年12月25日(木)00時05分19秒 		返信・引用
  > No.190[元記事へ]

GAIさんへのお返事です。

> どんな大きな（１０桁ほどは欲しい）x,n,aに対しても、次の剰余が求まるプログラム
> を作って頂きたいです。
> x^n mod a

  (x mod a) = r とすれば、
  (x^n mod a) = (r^n mod a) といえるので、
   x>a のときは数値が大きくなりすぎず効果があります。

  [注意] 十進BASICのヘルプによると、有理数モードでは
  「べき指数は-2147483647〜2147483647の範囲の整数に限定」
  されるそうです。

! mod(x^n,a) 有利数モードで実行
LET x=1234
LET n=56
LET a=789
PRINT "x=";x
PRINT "n=";n
PRINT "a=";a
PRINT
PRINT "x^n=";x^n
PRINT "mod(x^n,a)=";MOD(x^n,a)
PRINT
LET r=MOD(x,a)
PRINT "r=mod(x,a)=";MOD(x,a)
PRINT "r^n=";r^n
PRINT "mod(r^n,a)=";MOD(r^n,a)
END
 		 

液体万華鏡のコマーシャル

 投稿者：SECOND  投稿日：2008年12月25日(木)01時57分10秒 		返信・引用
  > No.187[元記事へ]

　錯視が、生じ難いよう１回転毎に、逆回転させるようにした。
　液面の変化に伴う容積変動を、±3.85% 以下まで押えた。
　液体の入っている真中の三角にコントラストを付けた。※改造歓迎 		 

Re: 剰余の計算

 投稿者：荒田浩二  投稿日：2008年12月25日(木)02時09分38秒 		返信・引用
  > No.190[元記事へ]

GAIさんへのお返事です。

> どんな大きな（１０桁ほどは欲しい）x,n,aに対しても、次の剰余が求まるプログラム
> を作って頂きたいです。
> x^n mod a

  下のプログラムなら、計算中の最大値はr^2になります。
  rが8桁以下なら10進モードや2進モードで実行できます。
  rが8桁を超える場合は1000桁モードになります。

  x,n,aがともに10桁の下の例では、1000桁モードで約40分かかりました。

! mod(x^n,a)
LET x=9876543201
LET n=1234567890
LET a=6789012345

LET r=MOD(x,a)
LET k=r
FOR i=2 TO n
   LET k=MOD(k*r,a)
NEXT i
PRINT k
END
 		 

Re: 剰余の計算

 投稿者：SECOND  投稿日：2008年12月25日(木)04時29分36秒 		返信・引用
  > No.190[元記事へ]

GAIさんへのお返事です。

山中氏の、EXTERNAL FUNCTION modpow(a,b,n) !a^b mod n ですが、
１３桁まで、UBASIC の実行結果と一致します。（十進15桁defaultのまま）
１４桁は、一致しない。
   10   print modpow(9999999999990,9999999999991,9999999999992)
   20   print modpow(9999999999991,9999999999992,9999999999993)
   30   print modpow(9999999999992,9999999999993,9999999999994)
   40   print modpow(9999999999993,9999999999994,9999999999995)
   50   print modpow(1999999999999,2999999999999,3999999999999)
   60   print modpow(2999999999999,3999999999999,4999999999999)
   70   print modpow(3999999999999,4999999999999,5999999999999)
   80   print modpow(4999999999999,5999999999999,6999999999999)
run
4328812006896
6296396057422
709006245058
6925339067979
2162020581010
1769850372477
5139725946770
6768106064755
OK 		 

Re: 剰余の計算

 投稿者：白石　和夫  投稿日：2008年12月25日(木)09時11分50秒 		返信・引用 　編集済
  > No.190[元記事へ]

「基本のアルゴリズム」のページを見てください。
http://hp.vector.co.jp/authors/VA008683/F_Algor.htm

このプログラムは，a^n mod k を計算します。
kの値が8桁を超えるときは有理数モードで実行してください。

100 INPUT k
110 INPUT a,n
120 LET p=1
130 LET b=MOD(a,k)
140 DO UNTIL n=0
150    IF MOD(n,2)=1 THEN LET p=MOD(p*b,k)
160    LET b=MOD(b*b,k)
170    LET n=INT(n/2)
180 LOOP
190 PRINT p
200 END 		 

Re: 剰余の計算

 投稿者：荒田浩二  投稿日：2008年12月25日(木)11時23分39秒 		返信・引用 　編集済
  > No.190[元記事へ]

GAIさんへのお返事です。

  x^nでべき指数をn=s*t*uと分解すれば、剰余計算の回数がs+t+uに減らせるのでnを素因数分解しました。
nが素数でなければ高速です。1000桁モードでも数秒です。

[投稿しようと掲示板を開いたら白石先生の投稿がありました。白石先生のプログラムではnが素数であるかに無関係で高速です。まあ、せっかく作ったので投稿します。]

追加編集[SECONDさんの投稿でさかのぼって確認しましたが、山中和義さんがすでに白石先生と同様の投稿をされていました。]

DECLARE EXTERNAL SUB prime_factor
PUBLIC NUMERIC prn(2000000),pf(100),f
DECLARE FUNCTION modn
LET x=9876543201
LET n=1234567890
LET a=6789012345
LET r=MOD(x,a)
CALL prime_factor(n) ! 素因数分解
LET k=r
FOR i=1 TO f
   LET k=modn(k,pf(i),a)
NEXT i
PRINT k
!
FUNCTION modn(r,n,a) ! mod(r^n,a)
   LET kk=r
   FOR ii=2 TO n
      LET kk=MOD(kk*r,a)
   NEXT ii
   LET modn=kk
END FUNCTION
END

REM ** 素因数分解 **
EXTERNAL SUB prime_factor(n)
DECLARE EXTERNAL SUB prime
LET f=0 ! 素因数の個数
LET q=n ! qは、商
LET m=1 ! 検証用変数
FOR i=1 TO 10
   READ prn(i)
NEXT i
DATA 2,3,5,7,11,13,17,19,23,29
LET i=1
DO WHILE MOD(q,prn(i))=0 ! 因数判定ルーチン
   LET f=f+1
   LET pf(f)=prn(i) ! pf(f)はnのf番目の素因数
   LET q=q/prn(i)
   LET m=m*prn(i)
LOOP
LET i=2
DO WHILE prn(i)<=SQR(q)
   DO WHILE MOD(q,prn(i))=0 ! 因数判定ルーチン
      LET f=f+1
      LET pf(f)=prn(i) ! pf(f)はnのf番目の素因数
      LET q=q/prn(i)
      LET m=m*prn(i)
   LOOP
   IF q=1 THEN EXIT DO
   LET i=i+1
   IF i>10 THEN CALL prime(i) ! i番目の素数
LOOP
IF q<>1 THEN
   LET f=f+1
   LET pf(f)=q
   LET m=m*q
END IF
IF m<>n THEN PRINT "error !!"
END SUB
!
REM ** 素数列生成(k番目の素数) **
EXTERNAL SUB prime(k)
LET m30=MOD(prn(k-1),30)
IF m30=1 OR m30=23 THEN LET a=prn(k-1)+6 ELSE LET a=prn(k-1)-2*MOD(m30,3)+6
DO
   LET sqra=SQR(a)
   FOR j=4 TO k-1
      IF MOD(a,prn(j))=0 THEN EXIT FOR
      IF prn(j)>=sqra THEN
         LET  prn(k)=a
         EXIT SUB
      END IF
   NEXT j
   LET m30=MOD(a,30)
   IF m30=1 OR m30=23 THEN LET a=a+6 ELSE LET a=a-2*MOD(m30,3)+6
LOOP
END SUB
 		 

剰余計算の調査より

 投稿者：GAI  投稿日：2008年12月25日(木)15時23分30秒 		返信・引用
  数学に詳しい方は以下のことは明白なことであるでしょうが、私にとっては大発見でした。
以前
トランプのシャッフルに興味があったとき、次のことを調べていました。
カード（2n枚）でインのリフルシャッフルをしたとき、
＜いま、カードが ２ｎ枚
ａ1、ａ2、・・・、ａｎ、ｂ1、ｂ2、・・・、ｂｎ
あるとき、その順序を並べ替えて、
ｂ1、ａ1、ｂ2、ａ2、・・・・・・・・、ｂｎ、ａｎ
となるとき、
２ｎ 枚のカードが「インでリフルシャッフル」されたということにする。＞

これについて調べていくと（２〜１００枚で調査）

枚数 同順復元回数 逆順復元回数 　 　枚数 同順復元回数 逆順復元回数
２   ２           １           　 　５２ ５２         ２６
４   ４           ２           　 　５４ ２０
６   ３     　 　                  　５６ １８           ９
８   ６           ３           　 　５８ ５８         ２９
１０ １０         ５           　 　６０ ６０         ３０
１２ １２         ６           　 　６２   ６
１４   ４ 　                    　 　６４ １２           ６
１６   ８         ４           　 　６６ ６６         ３３
１８ １８         ９           　 　６８ ２２
２０   ６ 　                    　 　７０ ３５
２２ １１                   　 　 　７２   ９
２４ ２０       １０           　 　７４ ２０
２６ １８         ９           　 　７６ ３０
２８ ２８       １４           　 　７８ ３９
３０   ５ 　                    　 　８０ ５４         ２７
３２ １０         ５           　　 ８２ ８２         ４１
３４ １２ 　                    　 　８４   ８
３６ ３６       １８           　 　８６ ２８
３８ １２ 　                   　 　８８ １１
４０ ２０       １０           　 　９０ １２
４２ １４         ７           　 　９２ １０
４４ １２ 　 　                   　９４ ３６
４６ ２３ 　 　                    　９６ ４８         ２４
４８ ２１ 　 　                    　９８ ３０         １５
５０ 　８ 　 　                  　１００1００  　     ５０

なる調査結果を得ていました。

このことから、トランプ（５２枚）で
アウトのリフルシャッフル（元のトップとボトムを常に再びリフル後のトップとボトムにする。）をすれば、５２枚のアウトシャッフル＝５０枚のインシャッフルに同じなので、８回
で元に戻ることが起きることになる。

ところでここに出てくる数字がランダムに並んでいくことに不思議さを感じていました。
今度、作成して頂いたa^n(mod k)を計算して表を作成して、眺めていてある関係があることに気づきました。

この同順復元回数が
a=2,k=カードの枚数＋１で計算させたとき、余りの値が１を最初にとる時のｎに対応した。
＜例＞
カード５２枚なら
　２＾ｎ≡１（MOD53)
なる最小のｎが同順復元回数になっていた。
また
　２＾ｎ≡５２　（MOD53)
なる最小ｎが逆順復元回数を知らせる。

トランプシャッフルと剰余が思わぬところで繋がったことにさらに不思議さが深まりました 		 

Re: 剰余計算の調査より

 投稿者：山中和義  投稿日：2008年12月25日(木)16時50分57秒 		返信・引用 　編集済
  > No.198[元記事へ]

GAIさんへのお返事です。

> カード５２枚なら
> 　２＾ｎ≡１（MOD53)
> なる最小のｎが同順復元回数になっていた。
> また
> 　２＾ｎ≡５２　（MOD53)
> なる最小ｎが逆順復元回数を知らせる。



１回のシャッフルでカードkが現れる位置をf(k)は（カードkはf(k)番目にある）
　f(k)=MOD(2*k,n+1)
と表せる。

m回シャッフルを繰り返すと
f(f(f(…(f(k)))))=2*(2*(2*…(2*k mod n+1) mod n+1) mod n+1) mod n+1=2^m*k mod n+1


一覧表をつくるプログラム
!リフルシャッフル

!n枚のカードを1,2,3,…,n-1,nに並べる。
!１回のシャッフルでカードkが現れる位置をf(k)と表す。（カードkはf(k)番目にある）
DEF f(k)=MOD(2*k,n+1)

FOR n=2 TO 100 STEP 2 !偶数
   PRINT USING "### 枚：":n;

   LET x=1 !カードxに着目
   LET iter=1000
   FOR m=1 TO iter !m回のシャッフル　※
      LET x=f(x) !2^m*k (mod n+1)
      !!!PRINT m;x
      IF x=n THEN PRINT USING "### 回目で逆順、":m; !逆順
      IF x=1 THEN EXIT FOR !もとに戻る
   NEXT m
   IF m>iter THEN
      PRINT USING "### 回では元に戻りません。":m
   ELSE
      PRINT USING "### 回目に元に戻る":m
   END IF

NEXT n

END


UBASICのmodinv関数を使った場合（サブルーチンは省略）
FOR n=2 TO 100 STEP 2 !偶数
   PRINT USING "### 枚：":n;

   LET iter=1000
   FOR m=1 TO iter
      LET x=modinv(2^m,n+1) !１枚目のカードの元の位置を得る
      IF x=n THEN PRINT USING "### 回目で逆順、":m; !逆順
      IF x=1 THEN EXIT FOR !もとに戻る
   NEXT m
   IF m>iter THEN
      PRINT USING "### 回では元に戻りません。":m
   ELSE
      PRINT USING "### 回目に元に戻る":m
   END IF

NEXT n
END
 

Re: プログラムの書き直し

 投稿者：SECOND  投稿日：2008年12月25日(木)20時28分59秒 		返信・引用
  > No.171[元記事へ]

山中和義さんへのお返事です。

b=0 のときの値が変です。EXTERNAL FUNCTION modpow(a,b,n) !a^b≡x mod n のxを返す 		 

Re: プログラムの書き直し

 投稿者：山中和義  投稿日：2008年12月25日(木)21時19分17秒 		返信・引用
  > No.200[元記事へ]

SECONDさんへのお返事です。

> b=0 のときの値が変です。EXTERNAL FUNCTION modpow(a,b,n) !a^b≡x mod n のxを返す

b=0での場合分けは必要なしですね。（原形ではmodpow=1ではなくて、S=1でした。）


EXTERNAL FUNCTION modpow(a,b,n) !a^b≡x mod n のxを返す
   LET S=1
   DO WHILE b>0
      IF MOD(b,2)=1 THEN LET S=MOD(S*a,n) !ビットが１なら計算する
      LET b=INT(b/2) !べき乗bを２進展開する
      LET a=MOD(a*a,n)
   LOOP
   LET modpow=S
END FUNCTION 		 

Re: 剰余計算の調査より

 投稿者：山中和義  投稿日：2008年12月26日(金)15時25分9秒 		返信・引用
  > No.198[元記事へ]

GAIさんへのお返事です。


以前、山を使ったシャッフルがあったと思います。

「あるシャッフル方法の規則性」 > No.109 [元記事へ]


この場合は、

　LET p=3 !山の数
　DEF f(k)=MOD(p*(n-k+1),n+1)

　ただし、n=m*p（nはpの倍数）。

となるので、modpow関数またはmodinv関数を使うなら（サブルーチンは省略）
!山を使ったシャッフル
LET p=3 !山の数

FOR n=p TO 100 STEP p !pの倍数
   PRINT USING "### 枚：":n;

   LET iter=1000
   FOR m=1 TO iter
   !!!LET x=modinv((n*p)^m,n+1) !１枚目のカードの元の位置（カード番号）を得る
      LET x=modpow(n*p,m,n+1) !１番のカードの位置を得る
      IF x=n THEN PRINT USING "### 回目で逆順、":m; !逆順
      IF x=1 THEN EXIT FOR !もとに戻る
   NEXT m
   IF m>iter THEN
      PRINT USING "##### 回では元に戻りません。":m
   ELSE
      PRINT USING "### 回目に元に戻る":m
   END IF

NEXT n

END

で回数が求まると思います。 		 

おーーーーー

 投稿者：GAI  投稿日：2008年12月26日(金)18時30分43秒 		返信・引用
  > No.202[元記事へ]

山中和義さんへのお返事です。

ホントだ！！！
以前の山分けシャッフルもmodinvやmodpow関数を使うことで解明できるんですね。
数式だけだと近寄り難い印象がありますが、こんなにも役立つ機能を有しているなんてすばらしい。
整数論の本をあらためて読みたくなりました。
数字とはまったく不思議な振る舞いをするもんだ。（数字にしてみれば、当然の行動なんでしょうが・・・）
これは人間対コンピュータの関係に似ているのかもしれない。
コンピュータは指示された通りの行動をしているのに、思うように動かなせないこのもどかしさに似ています。 		 

仕様でしょうか。

 投稿者：SECOND  投稿日：2008年12月27日(土)00時15分51秒 		返信・引用
  !
!文字が、鏡像になりません、仕様でしょうか。
!
SET TEXT JUSTIFY "center","half"
SET WINDOW -2, 2, -2, 2
SET COLOR MIX(15) 0.5,0.5,0.5
DRAW grid

DRAW test WITH SCALE( 1, 1)
DRAW test WITH SCALE(-1, 1)
DRAW test WITH SCALE( 1,-1)

PICTURE test
   PLOT LINES: 0,0; 1,0; 0.7,0.8; 0,0
   PLOT POINTS: 0.2,0.1
   PLOT TEXT,AT 0.6,0.4 :"1234"
END PICTURE

END 		 

時計、時計、時計

 投稿者：SECOND  投稿日：2008年12月27日(土)01時50分5秒 		返信・引用
  !１つ覚えに過ぎるか？取りあえずミラーの中に入れてみた。plot text を避けて、
!plot label を使用したので、文字への効果は、ありません。

!　時計、時計、時計
!-------------------
LET N=2
LET NN=2^N
SET TEXT font "Century",11
SET TEXT JUSTIFY "center","half"
SET TEXT BACKGROUND "OPAQUE"
SET WINDOW -250/NN,250/NN,250/NN,-250/NN

LET φ=0
LET stp=-PI/180*6
DO
   LET t=INT(TIME)
   IF t0<>t THEN
      LET t0=t
      IF 2*PI<=ABS(φ) THEN LET stp=-stp
      LET φ=REMAINDER(φ, 2*PI) +stp
      !-----
      SET DRAW mode hidden
      CLEAR
      DRAW D4(N) WITH SHIFT(-300/2,-300/2/SQR(3))*ROTATE(φ*(-1)^N)*SCALE(1,(-1)^N)
      DRAW center WITH SHIFT(-300/2/NN,-300/2/NN/SQR(3))*ROTATE(φ)
      PLOT TEXT,AT 180/NN,-240/NN:"Right Click to Stop"
      SET DRAW mode explicit
   ELSE
      WAIT DELAY 0.05 !　省電力効果
   END IF
   MOUSE POLL mx,my,mlb,mrb
LOOP UNTIL mrb>=1 !　右クリックで停止

PICTURE center
   SET LINE COLOR 2
   SET LINE width 2
   PLOT LINES:0,0;300/NN,0;300/2/NN,300/2/NN*SQR(3);0,0
   SET LINE width 1
   SET LINE COLOR 1
END PICTURE

!------
PICTURE D4(k)
   IF 0< k THEN
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*SHIFT(300/4,SQR(3)*300/4) !　内側の上
      DRAW D4(k-1) WITH SCALE(1/2,-1/2)*SHIFT(300/4,SQR(3)*300/4) !　内側の中
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*ROTATE(-PI*2/3)*SHIFT(300/4,SQR(3)*300/4) !内側の左
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*ROTATE(PI*2/3)*SHIFT(300,0) !　内側の右
   ELSE
      DRAW 時計図 WITH ROTATE(-φ)*SHIFT(300/2,300/2/SQR(3))
      PLOT LINES:0,0;300,0;300/2,SQR(3)*300/2;0,0 !　外側の基準三角形（直接の描画は無し。)
   END IF
END PICTURE

!------
PICTURE 時計図
   SET AREA COLOR 1
   FOR i=1 TO 60
      LET a=PI/30*(i-15)
      IF MOD(i,5)=0 THEN
         PLOT label,AT 60*COS(a)+1, 60*SIN(a) :STR$(i/5) !数字
         DRAW disk WITH SCALE(1)*SHIFT(72*COS(a),72*SIN(a)) !５分目盛り
      ELSE
         DRAW disk WITH SCALE(.5)*SHIFT(72*COS(a),72*SIN(a)) !１分目盛り
      END IF
   NEXT i
   !---　00:00 からｔ秒 の針回転 Gear
   DRAW hand(1) WITH SCALE(2.5, 0.75)*ROTATE(t*PI/21600) !　時針
   DRAW hand(1) WITH ROTATE(t*PI/1800) !　分針
   DRAW hand(1) WITH SCALE(0, 1.1)*ROTATE(t*PI/30) !　秒針
   !---　中心の飾り
   DRAW disk WITH SHIFT(0,0)*SCALE(4)
END PICTURE

PICTURE hand(c) !　３針共用
   SET AREA COLOR c
   PLOT AREA: -1,15; 1,15; 1,-60; -1,-60
END PICTURE

END 		 

疑問

 投稿者：GAI  投稿日：2008年12月27日(土)13時38分59秒 		返信・引用
  > No.205[元記事へ]

SECONDさんへのお返事です。

万華鏡に万華鏡を入れ込むことはできるのでしょうか？
中に水や時計が入れられるなら、中に見ている万華鏡の映像を入れてみて見たい。 		 

Re: 疑問

 投稿者：SECOND  投稿日：2008年12月27日(土)14時18分26秒 		返信・引用 　編集済
  > No.206[元記事へ]

GAIさんへのお返事です。

> 万華鏡に万華鏡を入れ込むことはできるのでしょうか？
> 中に水や時計が入れられるなら、中に見ている万華鏡の映像を入れてみて見たい。

実は、そのご返事をする前に、
以前に、投稿したものですが、下のプログラムを走らせて見て下さい。

!-----------------------------------------------------
!シルピンスキーのガスケットと並べて動かしてみる。

OPTION ARITHMETIC NATIVE
DIM px(11),py(11)

MAT READ px
DATA 0.20, 0.40, 0.60, 0.80, 0.70, 0.60, 0.50, 0.40, 0.30, 0.20, 0.40
MAT READ py
DATA 0.11, 0.11, 0.11, 0.11, 0.29, 0.47, 0.65, 0.47, 0.29, 0.11, 0.11

!----------
FOR N=0 TO 4
   FOR s=9 TO 1 STEP -1
      SET DRAW mode hidden
      CLEAR
      SET WINDOW -0.4,1.6, -1.1,0.9
      PLOT TEXT,AT 0.6,0.8:"ミラー縮小４分岐"
      PLOT TEXT,AT 0.8,0.7, USING "N= %%":N
      DRAW D4(N)
      SET WINDOW -1.0,1.0, -0.05,1.95
      PLOT TEXT,AT 0.6,0.8:"中を抜いたもの"
      PLOT TEXT,AT 0.8,0.7, USING "N= %%":N
      DRAW D42(N)
      SET WINDOW 0.0,4.0, -0.1,3.9
      PLOT TEXT,AT 0.1,1.8:"シルピンスキーのガスケット"
      PLOT TEXT,AT 1.2,1.6, USING "N= %%":N
      DRAW D3(N)
      SET DRAW mode explicit
      WAIT DELAY 0.2
   NEXT s
NEXT N

!------ ミラー縮小４分岐
PICTURE D4(k)
   IF 0<k THEN
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*SHIFT(1/4,SQR(3)/4) !　上
      DRAW D4(k-1) WITH SCALE(1/2,-1/2)*SHIFT(1/4,SQR(3)/4) !　中
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*ROTATE(-PI*2/3)*SHIFT(1/4,SQR(3)/4) !　左
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*ROTATE(PI*2/3)*SHIFT(1,0) !　右
   ELSE
      DRAW Set01
   END IF
END PICTURE

!------ ミラー縮小４分岐（中）を外すと、シルピンスキーのガスケットもどきになる。
PICTURE D42(k)
   IF 0<k THEN
      DRAW D42(k-1) WITH SCALE(1/2,1/2)*SHIFT(1/4,SQR(3)/4) !　上
      ! これを外す　DRAW D42(k-1) WITH SCALE(1/2,-1/2)*SHIFT(1/4,SQR(3)/4) !　中
      DRAW D42(k-1) WITH SCALE(1/2,1/2)*ROTATE(-PI*2/3)*SHIFT(1/4,SQR(3)/4) !　左
      DRAW D42(k-1) WITH SCALE(1/2,1/2)*ROTATE(PI*2/3)*SHIFT(1,0) !　右
   ELSE
      DRAW Set01
   END IF
END PICTURE

!------ シルピンスキーのガスケット
PICTURE D3(k)
   IF 0<k THEN
   !---リンク・BASICで描く自己相似図形から拝借
      DRAW D3(k-1) WITH SCALE(1/2)
      DRAW D3(k-1) WITH SHIFT(-2,0)*SCALE(1/2)*SHIFT(2,0)
      DRAW D3(k-1) WITH SHIFT(-1,-SQR(3))*SCALE(1/2)*SHIFT(1,SQR(3))
   ELSE
      DRAW Set01
   END IF
END PICTURE

!------ 親集合の三角図１枚
PICTURE Set01
   PLOT LINES: 0,0; 1,0 ;0.5,SQR(3)/2 ;0,0
   SET AREA COLOR 2
   DRAW disk WITH SCALE(0.1)*SHIFT(px(s),py(s)) ! 飾り１
   SET AREA COLOR 3
   DRAW disk WITH SCALE(0.1)*SHIFT(px(s+1),py(s+1)) ! 飾り２
   SET AREA COLOR 4
   DRAW disk WITH SCALE(0.1)*SHIFT(px(s+2),py(s+2)) ! 飾り３
END PICTURE

END 		 

シャッフルについて調べていたら

 投稿者：SECOND  投稿日：2008年12月29日(月)07時01分26秒 		返信・引用
  !シャッフルについて調べていたら、このページに
!http://www004.upp.so-net.ne.jp/s_honma/number/shuffle.htm#別表
!ＧＡＩ さんの調査された表と、その下の方に、Ｃ言語の検証プログラムが
!ありましたので、十進BASIC でも動くように書き直してみました。
!勝手に加筆して、結果に、おかしな数字が、出たりしていないでしょうか。

!#include <stdio.h>
!#include <string.h>
!int buf[1000], bufw[1000];
!int n;

!void shuffle(void)
!{
!　int i;
!　memcpy(bufw, buf, sizeof(buf[0]) * n);
!　for(i = 0; i < n; ++i)
!　　buf[i] = bufw[i / 2 + (i + 1) % 2 * n / 2];
!}

!int main(void)
!{
!　int i, c, cc;
!　for(n = 2; n <= 1000; n += 2){
!　　for(i = 0; i < n; ++i)
!　　　buf[i] = i;
!　　cc = c = 0;
!　　do{
!　　　++c;
!　　　shuffle();
!　　　for(i = 0; i < n; ++i)
!　　　　if(buf[i] != n - 1 - i)
!　　　　　break;
!　　　if(i >= n && cc == 0)
!　　　　cc = c;
!　　　for(i = 0; i < n; ++i)
!　　　　if(buf[i] != i)
!　　　　　break;
!　　}while(i < n);
!　　printf("%3d %3d %3d\n", n, c, cc);
!　}
!　return 0;
!}

!----------------------------
!十進BASIC に移植。
! i=0~n-1 は、見づらいので i=1~n　その他 無断加筆、ご容赦 ）

LET maxim=13 !　最大枚数 2~1000
DIM buf(1000), bufw(1000)

SUB in_riffle_shuffle !インのリフル。奇数枚は、後半を１枚多め
   MAT bufw=buf
   FOR i=1 TO n
      LET buf(i)= bufw(CEIL(i/2)+MOD(i,2)*INT(n/2)) !1234→3142, 12345→31425
   NEXT i
END SUB

SUB out_riffle_shuffle !アウトのリフル。奇数枚は、前半を１枚多め
   MAT bufw=buf
   FOR i=1 TO n
      LET buf(i)= bufw(CEIL(i/2)+MOD(i+1,2)*CEIL(n/2)) !1234→1324, 12345→13243
   NEXT i
END SUB

FOR n=2 TO maxim !STEP 2 !　Step を外せば奇数も計算。
!-----
   MAT buf=ZER(n) !　配列サイズ調整、追加
   !-----
   FOR i=1 TO n
      LET buf(i)= i
   NEXT i
   LET cc=0
   LET c=0
   !-----
   IF maxim<15 THEN MAT PRINT USING REPEAT$(" ###",n) :buf !　表示、追加
   !-----
   DO
      LET c=c+1
      CALL in_riffle_shuffle ! 1234→3142, 12345→31425
      !CALL out_riffle_shuffle ! 1234→1324, 12345→13243
      !-----
      IF maxim<15 THEN MAT PRINT USING REPEAT$(" ###",n) :buf !　表示、追加
      !-----
      FOR i=1 TO n
         IF buf(i)<> n+1-i THEN EXIT FOR
      NEXT i
      IF i>n AND cc=0 THEN LET cc=c
      FOR i=1 TO n
         IF buf(i)<>i THEN EXIT FOR
      NEXT i
   LOOP UNTIL i>n
   PRINT USING "枚数=###　同順=###　逆順=###（復元回数）": n, c, cc
   IF maxim<15 THEN PRINT !　表示、追加
NEXT n

END 		 

お正月マジック

 投稿者：GAI  投稿日：2008年12月29日(月)12時31分20秒 		返信・引用
  正月は一家団欒、親戚なども集まり子供たちも寄って来ます。
そこでトランプマジックをひとつ紹介。
誰かに５２枚の中から勝手に５枚のカードを引かせる。
これをアシスタントに渡してもらう。（アシスタントの役目はあとで説明）
アシスタントはカードを一枚ずつ表向きにテーブルへ出して並べていく。
４枚並んだところで、待ったをかける。
ここであなた（マジシャン）は十分な演技を行なう。
マジシャンは残った一枚のカードのマークと数字を予言する。
最後の一枚を表向きに並べてもらう。（予言が的中する。）

＜アシスタントの役目＞
５枚のカードの中には必ず同じマークが存在する。
最初に表にして並べるカードはこのマークのカードの一つにする。（これで最後に残るカードのマークが判明する。）
次に３つのカードを並べるが、並べる順番を数字で
A>K>Q>J>10>9>8>7>6>5>4>3>2
の順序（ポーカーでの強弱に同じにする。）と決めておき、最初に置いたカードの数字と最後まで手元に残すカード（同じマーク）の数字の差（キーナンバー）に従って並べ方を工夫してやる。
ここで最初のカードと最後のカードの数字の配列差は必ず６以内に納まる。
これは数字を円周上の配列として考えておくとする。(時計回りにカウントする。）
　　　　　　　　K
　　　　　　　Q　A
　　　　     J    2
           10      3
            9     4
             8   5
              7 6

<最初に出すカードの数＞　　　＜最後まで残すカードの数＞　　＜キーナンバー＞
　　　　　A　　　　　　　　　　　　　　  2　　　　　　　　　　　 1
          2                              4                       2
          3                              6                       3
          4                              8                       4
          5                             10                       5
          6                              Q                       6
          7                              K                       6
・・・・・・・・・・・・・
・・・・・・・・・・・・・
　　　　　 K                              A                       1

＜キーナンバーに対する３枚のカードの配列法則＞
３枚のカードの数字を見比べて、3つでの強、中、弱を見る。
（もし同数であればマークで♠＞♡＞♢＞♣　の順で強、弱を決める。）
（キーナンバー）　　　（３枚の配列順序）
　　　1：　　　　　　　弱　・　中　・　強
　　 ２：　　　　　　　弱　・　強　・　中
　　 ３：　　　　　　　中　・　弱　・　強
　　 ４：　　　　　　　中　・　強　・　弱
　 　５：　　　　　　　強　・　弱　・　中
　　 ６：　　　　　　　強　・　中　・　弱

＜例１＞
（客が引いた５枚のカード）：♠J,♠2,♢5,♣J,♣2

(アシスタントが並べるカード順）：♣J,♢5,♠J,♠2
                                *♣2 を最初に並べるとJまでは＋９となるのでＪとする。

（マジシャンの判断）：1番目のカードマークより　クラブの
　　　　　　　　　　　中・強・弱　で並んでいるから　Ｊ＋４より　数字は　２

＜例２＞
（客が引いた５枚のカード）：♠J,♠4,♢2,♣J,♣2

(アシスタントが並べるカード順）：♠J,♣J,♢2,♣2

（マジシャンの判断）：1番目のカードマークより　スペードの
　　　　　　　　　　　強・中・弱　で並んでいるので　Ｊ＋６　より数字は　４

これであなたは超能力者 		 

UBASICのビット演算関数の実装

 投稿者：山中和義  投稿日：2008年12月29日(月)19時42分22秒 		返信・引用
  
!真理値表
LET a=3 !0011のパターン
LET b=5 !0101のパターン

PRINT " b NOT" !否定
FOR i=0 TO 1
   PRINT bit(i,b); 1-bit(i,b) !b'=1-b
NEXT i
PRINT " a  b IMP" !論理包含
FOR i=0 TO 3
   PRINT bit(i,a); bit(i,b); bit(i,bitor(bitreverse(i,a),b)) !a' or b
NEXT i
PRINT " a  b EQV" !同値
FOR i=0 TO 3
   PRINT bit(i,a); bit(i,b); 1-bit(i,bitxor(a,b)) !(a xor b)'
NEXT i



!２の補数：定義より
LET n=16 !ｎビット符号付整数 -2^(n-1)〜2^(n-1)-1
LET m=2^n

LET a=3
LET aa=m-a !a+a'=m
FOR i=N-1 TO 0 STEP -1 !上の位から
   PRINT bit(i,aa);
NEXT i
PRINT


!２の補数：反転して１をたす
LET a=3
FOR i=N-1 TO 0 STEP -1 !上の位から
   LET a=bitreverse(i,a)
NEXT i
LET a=a+1
PRINT a !ｎビット符号なし整数 0〜2^n-1

!２の補数：反転して１をたす　※別解
LET a=3
FOR i=0 TO N-1 !下の位から
   IF bit(i,a)=1 THEN EXIT FOR !１が見つかるまで
   LET a=bitreset(i,a) !０にする
NEXT i
FOR k=i+1 TO N-1 !続き
   LET a=bitreverse(k,a) !０を１にする
NEXT k
PRINT a



!加算 a+b
LET a=123
LET b=45
DO WHILE bitand(a,b)>0
   LET t=bitxor(a,b)
   LET b=sft(bitand(a,b),1)
   LET a=t
LOOP
PRINT bitxor(a,b)


END


!ビット演算関連　※UBASICより

EXTERNAL FUNCTION bit(n,x) !n番目のビット値　※n,xは整数
IF n<>INT(n) OR x<>INT(x) THEN !整数以外なら
   PRINT "パラメータが不適当です。"
   STOP
ELSE
   LET bit=MOD(INT(x/2^n),2)
END IF
END FUNCTION

EXTERNAL FUNCTION bitset(n,x) !n番目のビットを１にする　※n,xは非負整数
IF n<0 OR n<>INT(n) OR x<0 OR x<>INT(x) THEN !非負整数以外なら
   PRINT "パラメータが不適当です。"
   STOP
ELSE
   LET d=2^n !n桁
   LET bitset=(INT(x/d/2)*2+1)*d+MOD(x,d) !大きい桁＋１＋小さい桁
END IF
END FUNCTION

EXTERNAL FUNCTION bitreset(n,x) !n番目のビットを０にする　※n,xは非負整数
IF n<0 OR n<>INT(n) OR x<0 OR x<>INT(x) THEN !非負整数以外なら
   PRINT "パラメータが不適当です。"
   STOP
ELSE
   LET d=2^n !n桁
   LET bitreset=INT(x/d/2)*2*d+MOD(x,d) !大きい桁＋１＋小さい桁
END IF
END FUNCTION

EXTERNAL FUNCTION bitreverse(n,x) !n番目のビットを反転する　※n,xは非負整数
IF n<0 OR n<>INT(n) OR x<0 OR x<>INT(x) THEN !非負整数以外なら
   PRINT "パラメータが不適当です。"
   STOP
ELSE
   LET d=2^n !n桁
   LET a=INT(x/d)
   LET bitreverse=(INT(a/2)*4-a+1)*d+MOD(x,d) !大きい桁＋NOT＋小さい桁
END IF
END FUNCTION

EXTERNAL FUNCTION bitand(a,b) !ビットごとの論理積　※a,bは非負整数
IF a<0 OR a<>INT(a) OR b<0 OR b<>INT(b) THEN !非負整数以外なら
   PRINT "パラメータが不適当です。"
   STOP
ELSE
   LET c=0 !値
   LET d=1
   DO UNTIL a=0 OR b=0 !最下位の桁から、桁数が小さい方まで
      LET aa=INT(a/2)
      LET bb=INT(b/2)
      LET c=c + MIN((a-aa*2),(b-bb*2)) * d !and(x,y)=MIN(x,y)

      LET a=aa !次へ
      LET b=bb
      LET d=d*2
   LOOP
   LET bitand=c
END IF
END FUNCTION

EXTERNAL FUNCTION bitor(a,b) !ビットごとの論理和　※a,bは非負整数
IF a<0 OR a<>INT(a) OR b<0 OR b<>INT(b) THEN !非負整数以外なら
   PRINT "パラメータが不適当です。"
   STOP
ELSE
   LET c=0
   LET d=1
   DO UNTIL a=0 AND b=0 !桁数が大きい方
      LET aa=INT(a/2)
      LET bb=INT(b/2)
      LET c=c+MAX((a-aa*2),(b-bb*2)) * d !or(x,y)=MAX(x,y)
      LET a=aa !次へ
      LET b=bb
      LET d=d*2
   LOOP
   LET bitor=c
END IF
END FUNCTION

EXTERNAL FUNCTION bitxor(a,b) !ビットごとの排他的論理和　※a,bは非負整数
IF a<0 OR a<>INT(a) OR b<0 OR b<>INT(b) THEN !非負整数以外なら
   PRINT "パラメータが不適当です。"
   STOP
ELSE
   LET c=0
   LET d=1
   DO UNTIL a=0 AND b=0 !桁数が大きい方
      LET aa=INT(a/2)
      LET bb=INT(b/2)
      LET c=c + MOD((a-aa*2)+(b-bb*2),2) * d !xor(x,y)=MOD(x+y,2)
      LET a=aa !次へ
      LET b=bb
      LET d=d*2
   LOOP
   LET bitxor=c
END IF
END FUNCTION

EXTERNAL FUNCTION bitcount(x) !１であるビットの個数　※xは非負整数
IF x<0 OR x<>INT(x) THEN !非負整数以外なら
   PRINT "パラメータが不適当です。"
   STOP
ELSE
   LET c=0 !値
   DO UNTIL x=0 !最下位の桁から
      LET xx=INT(x/2) !商
      LET c=c + (x-xx*2) !余り

      LET x=xx !次へ
   LOOP
   LET bitcount=c
END IF
END FUNCTION

EXTERNAL FUNCTION sft(x,n) !nビットのシフトする　※nは整数
IF n<>INT(n) THEN !整数以外なら
   PRINT "パラメータが不適当です。"
   STOP
ELSE
   IF n<0 THEN LET d=1/2 ELSE LET d=2
   FOR i=1 TO ABS(n)
      LET x=x*d
   NEXT i
   LET sft=x
END IF
END FUNCTION
 

数値積分式

 投稿者：しばっち  投稿日：2008年12月30日(火)09時36分6秒 		返信・引用
  ニュートン・コーツ則 数値積分式
有理数モードでお試しください

OPTION BASE 0
PUBLIC NUMERIC MAXLEVEL
LET  MAXLEVEL=10 !'次数
DIM X(1),Y(MAXLEVEL),L(MAXLEVEL)
LET DISPMODE=0 !' 0 or else
LET INTEGRAL=1 !' INTEGRAL >= 1
LET SWITCH=0   !' 0...閉じた公式  else...開いた公式
IF DISPMODE<>0 THEN
   IF INTEGRAL > 1 THEN
      PRINT "DIM A(";STR$(INTEGRAL);"),B(";STR$(INTEGRAL);"),N(";STR$(INTEGRAL);")"
      PRINT "FOR I=1 TO";INTEGRAL
      LET A$="(" & CHR$(34) & " & STR$(I) & " & CHR$(34) & ")=" & CHR$(34) & ":"
      LET B$="(I)"
   ELSE
      LET A$="=" & CHR$(34) & ":"
      LET B$=""
   END IF
   LET C$="! INPUT  PROMPT " & CHR$(34)
   PRINT C$;"下限  ";A$;"A";B$
   PRINT C$;"上限  ";A$;"B";B$
   PRINT C$;"分割数";A$;"N";B$
   PRINT "READ A";B$;",B";B$;",N";B$
   IF INTEGRAL > 1 THEN PRINT "NEXT"
   FOR I=1 TO INTEGRAL
      PRINT "DATA 0,1,10"
   NEXT I
   FOR I=2 TO MAXLEVEL
      PRINT "PRINT INTEGRAL";STR$(I);"(";
      IF INTEGRAL=1 THEN
         PRINT "A,B,N)"
      ELSE
         FOR J=1 TO INTEGRAL
            PRINT "A(";STR$(J);"),B(";STR$(J);"),";
         NEXT J
         FOR J=1 TO INTEGRAL
            PRINT "N(";STR$(J);")";
            IF J < INTEGRAL THEN PRINT ",";
         NEXT J
         PRINT ")"
      END IF
   NEXT I
   PRINT "END"
   PRINT
   PRINT "EXTERNAL  FUNCTION FUNC(";
   FOR I=1 TO INTEGRAL
      PRINT "X";STR$(I);
      IF I < INTEGRAL THEN PRINT ",";
   NEXT I
   PRINT ")"
   PRINT "LET S=1";
   FOR I=1 TO INTEGRAL
      PRINT "-X";STR$(I);"*X";STR$(I);
   NEXT I
   PRINT
   PRINT "IF S > 0 THEN"
   PRINT "LET FUNC=SQR(S)"
   PRINT "ELSE"
   PRINT "LET FUNC=0"
   PRINT "END IF"
   PRINT "END FUNCTION"
   PRINT
END IF
LET  X(1)=1
FOR N=1 TO MAXLEVEL-1
   FOR I=0 TO N
      CALL CLR(Y)
      LET  P=1
      LET  Y(0)=1
      FOR J=0 TO N
         IF I<>J THEN
            LET  X(0)=-J
            CALL MUL(Y,X)
            LET P=P*(I-J)
         END IF
      NEXT  J
      CALL INTEGRAL(Y)
      IF SWITCH=0 THEN
         LET L(I)=HORNER(Y,N)/P
      ELSE
         LET L(I)=(HORNER(Y,N+1)-HORNER(Y,-1))/P
      END IF
   NEXT I
   IF DISPMODE<>0 THEN
      PRINT "EXTERNAL  FUNCTION INTEGRAL";STR$(N+1);"(";
      IF INTEGRAL > 1 THEN
         FOR J=1 TO INTEGRAL
            PRINT "A";STR$(J);",B";STR$(J);",";
         NEXT J
         FOR J=1 TO INTEGRAL
            PRINT "N";STR$(J);
            IF J < INTEGRAL THEN PRINT ",";
         NEXT J
      ELSE
         PRINT "A,B,N";
      END IF
      PRINT ")"
      IF SWITCH=0 THEN LET A$=STR$(N) ELSE LET A$=STR$(N+2)
      IF INTEGRAL=1 THEN
         PRINT "LET H=(B-A)/N/";A$
         PRINT "LET S=0"
         PRINT "FOR K=0 TO N-1"
         PRINT "LET S=S";
         FOR I=0 TO N
            IF SWITCH=0 THEN LET B$=STR$(I) ELSE LET B$=STR$(I+1)
            IF L(I) < 0 THEN PRINT "-"; ELSE PRINT "+";
            PRINT STR$(ABS(L(I)));"*H*FUNC(A+H*(";A$;"*K+";B$;"))";
         NEXT I
         PRINT
         PRINT "NEXT"
      ELSE
         IF SWITCH=0 THEN
            PRINT "DIM R(0 TO ";STR$(N);")"
         ELSE
            PRINT "DIM R(";STR$(N+1);")"
         END IF
         FOR I=0 TO N
            IF SWITCH=0 THEN LET B$=STR$(I) ELSE LET B$=STR$(I+1)
            PRINT "R(";B$;")=";
            IF L(I) < 0 THEN  PRINT "-";
            PRINT STR$(ABS(L(I)))
         NEXT I
         FOR J=1 TO INTEGRAL
            PRINT "LET H";STR$(J);"=(B";STR$(J);"-A";STR$(J);")/N";STR$(J);"/";A$
         NEXT J
         PRINT "LET S=0"
         FOR J=INTEGRAL TO 1 STEP -1
            PRINT "FOR K";STR$(J);"=0 TO N";STR$(J);"-1"
         NEXT J
         FOR J=1 TO INTEGRAL
            IF SWITCH=0 THEN
               PRINT "FOR J";STR$(J);"=0 TO";N
            ELSE
               PRINT "FOR J";STR$(J);"=1 TO";N+1
            END IF
         NEXT J
         PRINT "LET S=S+";
         FOR J=1 TO INTEGRAL
            PRINT "R(J";STR$(J);")*";
         NEXT J
         FOR I=1 TO INTEGRAL
            PRINT "H";STR$(I);"*";
         NEXT I
         PRINT "FUNC(";
         FOR I=1 TO INTEGRAL
            PRINT "A";STR$(I);"+H";STR$(I);"*(";A$;"*K";STR$(I);"+J";STR$(I);")";
            IF I < INTEGRAL THEN PRINT ",";
         NEXT I
         PRINT ")"
         FOR I=1 TO INTEGRAL*2
            PRINT "NEXT"
         NEXT I
      END IF
      PRINT "LET INTEGRAL";STR$(N+1);"=S"
      PRINT "END FUNCTION"
   ELSE
      PRINT "∫(x";STR$(N);",x0)f(x)dx=";
      FOR I=0 TO N
         IF L(I) < 0 THEN
            PRINT "-";
         ELSE
            IF I > 0 THEN PRINT "+";
         END IF
         PRINT STR$(ABS(L(I)));"*h*f(x";STR$(I);")";
      NEXT I
      PRINT
   END IF
   PRINT
NEXT N
END

EXTERNAL  SUB MUL(A(),B())
OPTION BASE 0
DIM C(MAXLEVEL)
FOR I=0 TO MAXLEVEL-1
   FOR J=0 TO 1
      LET  C(I+J)=C(I+J)+A(I)*B(J)
   NEXT J
NEXT I
CALL COPY(A,C)
END SUB

EXTERNAL  FUNCTION HORNER(A(),XX)
FOR N=MAXLEVEL TO 0 STEP -1
   IF A(N)<>0 THEN EXIT FOR
NEXT N
LET Y=A(N)
FOR I=N-1 TO 0 STEP -1
   LET  Y=Y*XX+A(I)
NEXT I
LET  HORNER=Y
END FUNCTION

EXTERNAL  SUB COPY(X(),Y())
FOR I=0 TO MAXLEVEL
   LET  X(I)=Y(I)
NEXT I
END SUB

EXTERNAL  SUB CLR(X())
FOR I=0 TO MAXLEVEL
   LET X(I)=0
NEXT I
END SUB

EXTERNAL  SUB INTEGRAL(A())
OPTION BASE 0
DIM B(MAXLEVEL)
FOR I=MAXLEVEL-1 TO 0 STEP -1
   LET  B(I+1)=A(I)/(I+1)
NEXT I
CALL COPY(A,B)
END SUB 		 

ルジャンドル則係数計算

 投稿者：しばっち  投稿日：2008年12月30日(火)09時40分5秒 		返信・引用
  有限区間積分
/1
| f(x)dx
/-1

ガウス・ルジャンドル則の係数(分点、重み)を算出する。
1000桁モードを使用し、ルジャンドル多項式をニュートン法 + 組立除法で解く


OPTION BASE 0
OPTION ARITHMETIC DECIMAL_HIGH
PUBLIC NUMERIC MAXLEVEL,EPS
LET MAXLEVEL=10 !'次数
DIM X(MAXLEVEL),W(MAXLEVEL)
LET KETA=16 !'求める桁数
LET EPS=10^(-KETA)
LET DISPMODE=0 !' 0 or else
LET INTEGRAL=1 !' INTEGRAL >= 1
IF DISPMODE<>0 THEN
   CALL LEGENDREPARA(MAXLEVEL,X,W)
   PRINT "DIM X(";STR$(MAXLEVEL);"),W(";STR$(MAXLEVEL);")"
   FOR I=1 TO INTEGRAL
      PRINT "! INPUT  PROMPT ";CHR$(34);"下限 ";STR$(I);"=";CHR$(34);":A";STR$(I)
      PRINT "! INPUT  PROMPT ";CHR$(34);"上限 ";STR$(I);"=";CHR$(34);":B";STR$(I)
   NEXT I
   FOR I=1 TO INTEGRAL
      PRINT "LET A";STR$(I);"=0"
      PRINT "LET B";STR$(I);"=1"
   NEXT I
   FOR J=1 TO INTEGRAL
      PRINT "LET U";STR$(J);"=(B";STR$(J);"+A";STR$(J);")/2"
      PRINT "LET V";STR$(J);"=(B";STR$(J);"-A";STR$(J);")/2"
   NEXT J
   PRINT "FOR I=1 TO";MAXLEVEL
   PRINT "READ X(I),W(I)"
   PRINT "NEXT"
   PRINT "LET S=0"
   FOR J=1 TO INTEGRAL
      PRINT "FOR K";STR$(J);"=1 TO";MAXLEVEL
   NEXT J
   PRINT "LET  S=S+";
   FOR J=1 TO INTEGRAL
      PRINT "W(K";STR$(J);")*";
   NEXT J
   PRINT "FUNC(";
   FOR I=1 TO INTEGRAL
      PRINT "U";STR$(I);"+V";STR$(I);"*X(K";STR$(I);")";
      IF I < INTEGRAL THEN PRINT ",";
   NEXT I
   PRINT ")";
   FOR J=1 TO INTEGRAL
      PRINT "*V";STR$(J);
   NEXT J
   PRINT
   FOR J=1 TO INTEGRAL
      PRINT "NEXT"
   NEXT J
   PRINT "PRINT S"
   FOR I=1 TO MAXLEVEL
      PRINT "DATA ";
      PRINT USING "#." & REPEAT$("#",KETA):X(I);
      PRINT ",";
      PRINT USING "#." & REPEAT$("#",KETA) & "^^^^":W(I)
   NEXT I
   PRINT "END"
   PRINT
   PRINT "EXTERNAL  FUNCTION FUNC(";
   FOR I=1 TO INTEGRAL
      PRINT "X";STR$(I);
      IF I < INTEGRAL THEN PRINT ",";
   NEXT I
   PRINT ")"
   PRINT "LET S=1";
   FOR I=1 TO INTEGRAL
      PRINT "-X";STR$(I);"*X";STR$(I);
   NEXT I
   PRINT
   PRINT "IF S > 0 THEN"
   PRINT "LET FUNC=SQR(S)"
   PRINT "ELSE"
   PRINT "LET FUNC=0"
   PRINT "END IF"
   PRINT "END FUNCTION"
ELSE
   FOR N=2 TO MAXLEVEL
      PRINT TAB(8+KETA/2);"分点";TAB(8+KETA*1.5);"   重み"
      CALL LEGENDREPARA(N,X,W)
      FOR I=1 TO N
         PRINT "No.";I;":";
         PRINT USING "#." & REPEAT$("#",KETA):X(I);
         PRINT "  ";
         PRINT USING "#." & REPEAT$("#",KETA) & "^^^^":W(I)
      NEXT I
   NEXT N
END IF
END

EXTERNAL  SUB LEGENDREPARA(N,A(),W())
OPTION ARITHMETIC DECIMAL_HIGH
OPTION BASE 0
DIM P(MAXLEVEL),D(MAXLEVEL)
CALL  LEGENDREPOLY(N,P)
FOR I=0 TO N
   LET P(I)=P(I)/P(N)
NEXT I
FOR I=1 TO N
   CALL DERIVATIVE(P,D) !'微分
   LET XX=-1 !'初期値
   DO
      LET X=XX
      LET XX=X-HORNER(N,P,X)/HORNER(N,D,X) !'ニュートン法
   LOOP UNTIL ABS(HORNER(N,P,XX)) < EPS AND ABS(X-XX) < EPS
   LET A(I)=XX !'分点
   LET W(I)=WEIGHT(N,XX) !'重み
   CALL DIV(P,XX) !'組立除法
NEXT I
END SUB

EXTERNAL  SUB LEGENDREPOLY(KK,NEWP()) !'ルジャンドル多項式(係数)
OPTION ARITHMETIC DECIMAL_HIGH
OPTION BASE 0
DIM P(KK+1),OLDP(KK),PP(KK)
LET  OLDP(0)=1
LET  P(1)=1
FOR I=0 TO KK
   LET NEWP(I)=0
NEXT I
FOR K=2 TO KK
   FOR J=1 TO K
      LET  NEWP(J)=NEWP(J)+(2*K-1)/K*P(J-1)
      LET  NEWP(J-1)=NEWP(J-1)-(K-1)/K*OLDP(J-1)
   NEXT J
   IF K < KK THEN
      FOR I=0 TO K
         LET  OLDP(I)=P(I)
         LET  P(I)=NEWP(I)
         LET  NEWP(I)=0
      NEXT I
   END IF
NEXT K
END SUB

EXTERNAL  FUNCTION LEGENDRE(K,X) !'ルジャンドル多項式(値)
OPTION ARITHMETIC DECIMAL_HIGH
OPTION BASE 0
DIM PP(K+1)
LET  PP(0)=1
LET  PP(1)=X
FOR N=1 TO K-1
   LET  PP(N+1)=((2*N+1)*X*PP(N)-N*PP(N-1))/(N+1)
NEXT N
LET  LEGENDRE=PP(K)
END FUNCTION

EXTERNAL  FUNCTION WEIGHT(N,X) !'重み
OPTION ARITHMETIC DECIMAL_HIGH
LET WEIGHT=2*(1-X^2)/(N*LEGENDRE(N-1,X))^2
END FUNCTION

EXTERNAL  FUNCTION HORNER(N,A(),X)
OPTION ARITHMETIC DECIMAL_HIGH
LET  Y=A(N)
FOR I=N-1 TO 0 STEP -1
   LET  Y=Y*X+A(I)
NEXT I
LET  HORNER=Y
END FUNCTION

EXTERNAL  SUB DERIVATIVE(A(),B()) !'微分
OPTION ARITHMETIC DECIMAL_HIGH
FOR I=MAXLEVEL TO 1 STEP -1
   LET  B(I-1)=I*A(I)
NEXT I
LET B(MAXLEVEL)=0
END SUB

EXTERNAL  SUB DIV(A(),P) !'組立除法
!'A(N)*X^N+A(N-1)*X^(N-1)+...+A(2)*X^2+A(1)*X+A(0)=(X-P)(C(N-1)*X^(N-1)+...+C(2)*X^2+C(1)*X+C(0))
OPTION BASE 0
OPTION ARITHMETIC DECIMAL_HIGH
DIM C(MAXLEVEL)
FOR I=MAXLEVEL TO 1 STEP -1
   LET  C(I-1)=A(I)+C(I)*P
NEXT I
CALL COPY(A,C)
END SUB

EXTERNAL  SUB COPY(X(),Y())
OPTION ARITHMETIC DECIMAL_HIGH
FOR I=0 TO MAXLEVEL
   LET  X(I)=Y(I)
NEXT I
END SUB
---------------------------------------------------
ルジャンドル多項式表示
有理数モードでお試しください

OPTION BASE 0
PUBLIC NUMERIC MAXLEVEL
LET  MAXLEVEL=20 !'次数
DIM P(MAXLEVEL)
PRINT "P(0)=1"
PRINT "P(1)=X"
FOR K=2 TO MAXLEVEL
   CALL LEGENDREPOLY(K,P) !'上記参照(OPTION ARITHMETIC DECIMAL_HIGHを外す)
   PRINT "P(";STR$(K);")=";
   CALL DISPLAY(P)
NEXT K
END

EXTERNAL  SUB DISPLAY(A())
FOR N=MAXLEVEL TO 0 STEP -1
   IF A(N)<>0 THEN EXIT FOR
NEXT N
IF N > 1 THEN
   IF A(N) < 0 THEN PRINT "-";
   IF ABS(A(N))<>1 THEN
      PRINT STR$(ABS(A(N)));"*X^";STR$(N);
   ELSE
      PRINT "X^";STR$(N);
   END IF
END IF
FOR I=N-1 TO 2 STEP -1
   IF A(I)<>0 THEN
      IF A(I) < 0 THEN PRINT "-"; ELSE PRINT "+";
      IF ABS(A(I))<>1 THEN
         PRINT STR$(ABS(A(I)));"*X^";STR$(I);
      ELSEIF ABS(A(I))=1 THEN
         PRINT "X^";STR$(I);
      END IF
   END IF
NEXT I
IF A(1)<>0 THEN
   IF N > 1 THEN
      IF A(1) < 0 THEN PRINT "-"; ELSE PRINT "+";
   END IF
   IF ABS(A(1))<>1 THEN
      PRINT STR$(ABS(A(1)));"*X";
   ELSEIF ABS(A(1))=1 THEN
      PRINT "X";
   END IF
END IF
IF A(0)<>0 THEN
   IF A(0) < 0 THEN PRINT "-"; ELSE PRINT "+";
   PRINT STR$(ABS(A(0)));
END IF
PRINT
END SUB 		 

ラゲール則係数計算

 投稿者：しばっち  投稿日：2008年12月30日(火)09時41分16秒 		返信・引用
  半無限区間積分
/∞
| f(x)dx
/0

ガウス・ラゲール則の係数(分点、重み)を算出する。
1000桁モードを使用し、ラゲール多項式をニュートン法 + 組立除法で解く


OPTION BASE 0
OPTION ARITHMETIC DECIMAL_HIGH
PUBLIC NUMERIC MAXLEVEL,EPS
LET MAXLEVEL=10
DIM X(MAXLEVEL),W(MAXLEVEL)
LET KETA=16
LET EPS=10^(-KETA)
LET DISPMODE=0 !' 0 or else
LET INTEGRAL=1 !' INTEGRAL >= 1
IF DISPMODE<>0 THEN
   CALL LAGUERREPARA(MAXLEVEL,X,W)
   PRINT "DIM X(";STR$(MAXLEVEL);"),W(";STR$(MAXLEVEL);")"
   PRINT "FOR I=1 TO";MAXLEVEL
   PRINT "READ X(I),W(I)"
   PRINT "NEXT"
   FOR I=1 TO INTEGRAL
      PRINT "INPUT  PROMPT ";CHR$(34);"GAMMA(";
      FOR J=1 TO INTEGRAL
         PRINT "X";STR$(J);
         IF J < INTEGRAL THEN PRINT ",";
      NEXT J
      PRINT ") X";STR$(I);"=";CHR$(34);":U";STR$(I)
   NEXT I
   PRINT "LET S=0"
   FOR I=1 TO INTEGRAL
      PRINT "FOR I";STR$(I);"=1 TO";MAXLEVEL
   NEXT I
   PRINT "LET  S=S+";
   FOR I=1 TO INTEGRAL
      PRINT "W(I";STR$(I);")*";
   NEXT I
   PRINT "FUNC(";
   FOR I=1 TO INTEGRAL
      PRINT "X(I";STR$(I);"),";
   NEXT I
   FOR I=1 TO INTEGRAL
      PRINT "U";STR$(I);
      IF I < INTEGRAL THEN PRINT ",";
   NEXT I
   PRINT ")*EXP(";
   FOR I=1 TO INTEGRAL
      PRINT "X(I";STR$(I);")";
      IF I < INTEGRAL THEN PRINT "+";
   NEXT I
   PRINT ")"
   FOR I=1 TO INTEGRAL
      PRINT "NEXT"
   NEXT I
   PRINT "PRINT S"
   FOR I=1 TO MAXLEVEL
      PRINT "DATA ";
      PRINT USING "##." & REPEAT$("#",KETA):X(I);
      PRINT ",";
      PRINT USING "#." & REPEAT$("#",KETA) & "^^^^":W(I)
   NEXT I
   PRINT "END"
   PRINT
   PRINT "EXTERNAL  FUNCTION FUNC(";
   FOR I=1 TO INTEGRAL
      PRINT "X";STR$(I);",";
   NEXT I
   FOR I=1 TO INTEGRAL
      PRINT "U";STR$(I);
      IF I < INTEGRAL THEN PRINT ",";
   NEXT I
   PRINT ")"
   PRINT "FUNC=";
   FOR I=1 TO INTEGRAL
      PRINT "EXP(-X";STR$(I);")*X";STR$(I);"^(U";STR$(I);"-1)";
      IF I < INTEGRAL THEN PRINT "*";
   NEXT I
   PRINT
   PRINT "END FUNCTION"
ELSE
   FOR N=2 TO MAXLEVEL
      CALL LAGUERREPARA(N,X,W)
      PRINT TAB(8+KETA/2);"分点";TAB(8+KETA*1.5);"   重み"
      FOR I=1 TO N
         PRINT "No.";I;":";
         PRINT USING "##." & REPEAT$("#",KETA):X(I);
         PRINT "  ";
         PRINT USING "#." & REPEAT$("#",KETA) & "^^^^":W(I)
      NEXT I
   NEXT N
END IF
END

EXTERNAL  SUB LAGUERREPARA(N,A(),W())
OPTION ARITHMETIC DECIMAL_HIGH
OPTION BASE 0
DIM LA(MAXLEVEL+1),D(MAXLEVEL)
CALL LAGUERREPOLY(N,LA)
FOR I=0 TO N
   LET LA(I)=LA(I)/LA(N)
NEXT I
FOR I=1 TO N
   CALL DERIVATIVE(LA,D)
   LET XX=0
   DO
      LET X=XX
      LET XX=X-HORNER(N,LA,X)/HORNER(N,D,X)
   LOOP UNTIL ABS(HORNER(N,LA,XX)) < EPS AND ABS(X-XX) < EPS
   LET A(I)=XX
   LET W(I)=WEIGHT(N,XX)
   CALL DIV(LA,XX)
NEXT I
END SUB

EXTERNAL  SUB LAGUERREPOLY(N,NEWP()) !'ラゲール多項式(係数)
OPTION ARITHMETIC DECIMAL_HIGH
OPTION BASE 0
DIM P(N+1),OLDP(N)
LET OLDP(0)=1
LET P(1)=-1
LET P(0)=1
FOR I=0 TO N
   LET NEWP(I)=0
NEXT I
FOR K=2 TO N
   FOR J=0 TO K
      LET  NEWP(J)=NEWP(J)+(2*K-1)*P(J)-(K-1)^2*OLDP(J)
      LET  NEWP(J+1)=NEWP(J+1)-P(J)
   NEXT J
   IF K < N THEN
      FOR I=0 TO K
         LET  OLDP(I)=P(I)
         LET  P(I)=NEWP(I)
         LET  NEWP(I)=0
      NEXT I
   END IF
NEXT K
END SUB

EXTERNAL  FUNCTION LAGUERRE(NN,X) !'ラゲール多項式(値)
OPTION ARITHMETIC DECIMAL_HIGH
OPTION BASE 0
DIM L(NN+1)
LET  L(0)=1
LET  L(1)=1-X
FOR N=1 TO NN-1
   LET  L(N+1)=(2*N+1-X)*L(N)-N*N*L(N-1)
NEXT N
LET LAGUERRE=L(NN)
END FUNCTION

EXTERNAL  FUNCTION WEIGHT(N,X)
OPTION ARITHMETIC DECIMAL_HIGH
LET WEIGHT=FAC(N)^2/(X*LAGUERREDIFF(N,X)^2)
END FUNCTION

EXTERNAL  FUNCTION LAGUERREDIFF(N,X)
OPTION ARITHMETIC DECIMAL_HIGH
LET LAGUERREDIFF=(LAGUERRE(N+1,X)-(N+1-X)*LAGUERRE(N,X))/X
END FUNCTION

EXTERNAL  FUNCTION FAC(X)
OPTION ARITHMETIC DECIMAL_HIGH
LET S=1
FOR I=2 TO X
   LET S=S*I
NEXT I
LET FAC=S
END FUNCTION

EXTERNAL  SUB DERIVATIVE(A(),B())
OPTION ARITHMETIC DECIMAL_HIGH
FOR I=MAXLEVEL TO 1 STEP -1
   LET  B(I-1)=I*A(I)
NEXT I
LET B(MAXLEVEL)=0
END SUB

EXTERNAL  FUNCTION HORNER(N,A(),X)
OPTION ARITHMETIC DECIMAL_HIGH
LET  Y=A(N)
FOR I=N-1 TO 0 STEP -1
   LET  Y=Y*X+A(I)
NEXT I
LET  HORNER=Y
END FUNCTION

EXTERNAL  SUB DIV(A(),P)
OPTION BASE 0
OPTION ARITHMETIC DECIMAL_HIGH
DIM C(MAXLEVEL)
FOR I=MAXLEVEL TO 1 STEP -1
   LET  C(I-1)=A(I)+C(I)*P
NEXT I
CALL COPY(A,C)
END SUB

EXTERNAL  SUB COPY(X(),Y())
OPTION ARITHMETIC DECIMAL_HIGH
FOR I=0 TO MAXLEVEL
   LET  X(I)=Y(I)
NEXT I
END SUB 		 

エルミート則係数計算

 投稿者：しばっち  投稿日：2008年12月30日(火)09時42分28秒 		返信・引用
  無限区間積分
/∞
| f(x)dx
/-∞

ガウス・エルミート則の係数(分点、重み)を算出する。
1000桁モードを使用し、エルミート多項式をニュートン法 + 組立除法で解く


OPTION BASE 0
OPTION ARITHMETIC DECIMAL_HIGH
PUBLIC NUMERIC MAXLEVEL,EPS
LET MAXLEVEL=10
DIM X(MAXLEVEL),W(MAXLEVEL)
LET KETA=16
LET EPS=10^(-KETA)
LET DISPMODE=0 !' 0 or else
LET INTEGRAL=1 !' INTEGRAL >= 1
IF DISPMODE<>0 THEN
   CALL HERMITEPARA(MAXLEVEL,X,W)
   PRINT "DIM X(";STR$(MAXLEVEL);"),W(";STR$(MAXLEVEL);")"
   PRINT "FOR I=1 TO";MAXLEVEL
   PRINT "READ X(I),W(I)"
   PRINT "NEXT"
   PRINT "LET S=0"
   FOR I=1 TO INTEGRAL
      PRINT "FOR I";STR$(I);"=1 TO";MAXLEVEL
   NEXT I
   PRINT "LET  S=S+";
   FOR I=1 TO INTEGRAL
      PRINT "W(I";STR$(I);")*";
   NEXT I
   PRINT "FUNC(";
   FOR I=1 TO INTEGRAL
      PRINT "X(I";STR$(I);")";
      IF I < INTEGRAL THEN PRINT ",";
   NEXT I
   PRINT ")*EXP(";
   FOR I=1 TO INTEGRAL
      PRINT "X(I";STR$(I);")^2";
      IF I < INTEGRAL THEN PRINT "+";
   NEXT I
   PRINT ")"
   FOR I=1 TO INTEGRAL
      PRINT "NEXT"
   NEXT I
   PRINT "PRINT S,PI^";STR$(INTEGRAL/2)
   FOR I=1 TO MAXLEVEL
      PRINT "DATA ";
      PRINT USING "##." & REPEAT$("#",KETA):X(I);
      PRINT ",";
      PRINT USING "#." & REPEAT$("#",KETA) & "^^^^":W(I)
   NEXT I
   PRINT "END"
   PRINT
   PRINT "EXTERNAL  FUNCTION FUNC(";
   FOR I=1 TO INTEGRAL
      PRINT "X";STR$(I);
      IF I < INTEGRAL THEN PRINT ",";
   NEXT I
   PRINT ")"
   PRINT "LET FUNC=EXP(";
   FOR I=1 TO INTEGRAL
      PRINT "-X";STR$(I);"^2";
   NEXT I
   PRINT ")"
   PRINT "END FUNCTION"
ELSE
   FOR N=2 TO MAXLEVEL
      CALL HERMITEPARA(N,X,W)
      PRINT TAB(8+KETA/2);"分点";TAB(8+KETA*1.5);"   重み"
      FOR I=1 TO N
         PRINT "No.";I;":";
         PRINT USING "##." & REPEAT$("#",KETA):X(I);
         PRINT "  ";
         PRINT USING "#." & REPEAT$("#",KETA) & "^^^^":W(I)
      NEXT I
   NEXT N
END IF
END

EXTERNAL  SUB HERMITEPARA(N,A(),W())
OPTION ARITHMETIC DECIMAL_HIGH
OPTION BASE 0
DIM H(MAXLEVEL),D(MAXLEVEL)
CALL  HERMITEPOLY(N,H)
FOR I=0 TO N
   LET H(I)=H(I)/H(N)
NEXT I
FOR I=1 TO N
   CALL DERIVATIVE(H,D)
   LET XX=-15
   DO
      LET X=XX
      LET XX=X-HORNER(N,H,X)/HORNER(N,D,X)
   LOOP UNTIL ABS(HORNER(N,H,XX)) < EPS AND ABS(X-XX) < EPS
   LET A(I)=XX
   LET W(I)=WEIGHT(N,XX)
   CALL DIV(H,XX)
NEXT I
END SUB

EXTERNAL  SUB HERMITEPOLY(N,NEWP()) !'エルミート多項式(係数)
OPTION ARITHMETIC DECIMAL_HIGH
OPTION BASE 0
DIM P(N+1),OLDP(N)
LET  OLDP(0)=1
LET  P(1)=2
FOR I=0 TO N
   LET NEWP(I)=0
NEXT I
FOR K=2 TO N
   FOR J=1 TO K
      LET  NEWP(J)=NEWP(J)+2*P(J-1)
      LET  NEWP(J-1)=NEWP(J-1)-2*(K-1)*OLDP(J-1)
   NEXT J
   IF K < N THEN
      FOR I=0 TO K
         LET  OLDP(I)=P(I)
         LET  P(I)=NEWP(I)
         LET  NEWP(I)=0
      NEXT I
   END IF
NEXT K
END SUB

EXTERNAL  FUNCTION HERMITE(NN,X) !'エルミート多項式(値)
OPTION ARITHMETIC DECIMAL_HIGH
OPTION BASE 0
DIM H(NN+1)
LET  H(0)=1
LET  H(1)=2*X
FOR N=1 TO NN-1
   LET  H(N+1)=2*X*H(N)-2*N*H(N-1)
NEXT N
LET HERMITE=H(NN)
END FUNCTION

EXTERNAL  FUNCTION WEIGHT(N,X) !'重み
OPTION ARITHMETIC DECIMAL_HIGH
LET WEIGHT=2^(N+1)*FAC(N)*SQR(PI)/HERMITE(N+1,X)^2
END FUNCTION

EXTERNAL  FUNCTION FAC(X)
OPTION ARITHMETIC DECIMAL_HIGH
LET S=1
FOR I=2 TO X
   LET S=S*I
NEXT I
LET FAC=S
END FUNCTION

EXTERNAL  FUNCTION HORNER(N,A(),X)
OPTION ARITHMETIC DECIMAL_HIGH
LET  Y=A(N)
FOR I=N-1 TO 0 STEP -1
   LET  Y=Y*X+A(I)
NEXT I
LET  HORNER=Y
END FUNCTION

EXTERNAL  SUB DERIVATIVE(A(),B())
OPTION ARITHMETIC DECIMAL_HIGH
FOR I=MAXLEVEL TO 1 STEP -1
   LET  B(I-1)=I*A(I)
NEXT I
LET B(MAXLEVEL)=0
END SUB

EXTERNAL  SUB DIV(A(),P)
OPTION BASE 0
OPTION ARITHMETIC DECIMAL_HIGH
DIM C(MAXLEVEL)
FOR I=MAXLEVEL TO 1 STEP -1
   LET  C(I-1)=A(I)+C(I)*P
NEXT I
CALL COPY(A,C)
END SUB

EXTERNAL  SUB COPY(X(),Y())
OPTION ARITHMETIC DECIMAL_HIGH
FOR I=0 TO MAXLEVEL
   LET  X(I)=Y(I)
NEXT I
END SUB 		 

不等間隔数値積分

 投稿者：しばっち  投稿日：2008年12月30日(火)09時43分55秒 		返信・引用
  不等間隔 数値積分

/x(n)
| f(x)dx
/x(1)
積分区間 x(1)〜x(n)

PUBLIC NUMERIC MAXLEVEL
OPTION BASE 0
LET MAXLEVEL=10 !'最大次数 (MAXLEVEL > N)
LET N=5 !'データ数
DIM X(N),Y(N),A(MAXLEVEL),B(MAXLEVEL)
FOR I=1 TO N
   READ X(I),Y(I) !'y=x^2
NEXT I
CALL LARGRANGE(N,X,Y,A) !'ラグランジュ多項式
CALL INTEGRAL(A,B) !'積分
PRINT HORNER(N,B,X(N))-HORNER(N,B,X(1));X(N)^3/3-X(1)^3/3
!'CALL DERIVATIVE(A,B) !'微分
!'INPUT  PROMPT "f'(x) x=":XX
!'PRINT HORNER(N,B,XX);2*XX
DATA 0,0 !'離散値データ X値は等間隔でなくてもいい
DATA 1,1
DATA 3,9
DATA 4,16
DATA 6,36
END

EXTERNAL  SUB LARGRANGE(N,X(),Y(),A())
OPTION BASE 0
DIM U(MAXLEVEL),V(MAXLEVEL)
CALL CLR(A)
LET U(1)=1
FOR I = 1 TO N
   LET  R = Y(I)
   CALL CLR(V)
   LET V(0)=1
   FOR J = 1 TO N
      IF I <> J THEN
         LET U(0)=-X(J)
         CALL MUL(V,U)
         LET  R = R / (X(I)-X(J))
      END IF
   NEXT J
   CALL SHORTMUL(V,R)
   CALL ADD(A,V)
NEXT I
END SUB

EXTERNAL  FUNCTION HORNER(N,A(),XX)
LET  Y=A(N)
FOR I=N-1 TO 0 STEP -1
   LET  Y=Y*XX+A(I)
NEXT I
LET  HORNER=Y
END FUNCTION

EXTERNAL  SUB MUL(A(),B())
OPTION BASE 0
DIM C(MAXLEVEL)
FOR I=0 TO MAXLEVEL-1
   FOR J=0 TO 1
      LET  C(I+J)=C(I+J)+A(I)*B(J)
   NEXT   J
NEXT   I
CALL COPY(A,C)
END SUB

EXTERNAL  SUB INTEGRAL(A(),B())
FOR I=MAXLEVEL-1 TO 0 STEP -1
   LET  B(I+1)=A(I)/(I+1)
NEXT I
LET B(0)=0
END SUB

EXTERNAL  SUB ADD(A(),B())
FOR I=0 TO MAXLEVEL
   LET  A(I)=A(I)+B(I)
NEXT I
END SUB

EXTERNAL  SUB COPY(X(),Y())
FOR I=0 TO MAXLEVEL
   LET  X(I)=Y(I)
NEXT I
END SUB

EXTERNAL  SUB CLR(X())
FOR I=0 TO MAXLEVEL
   LET  X(I)=0
NEXT I
END SUB

EXTERNAL  SUB SHORTMUL(A(),X)
FOR I=0 TO MAXLEVEL
   LET A(I)=A(I)*X
NEXT I
END SUB

EXTERNAL  SUB DERIVATIVE(A(),B())
FOR I=MAXLEVEL TO 1 STEP -1
   LET  B(I-1)=I*A(I)
NEXT I
LET B(MAXLEVEL)=0
END SUB

--------------------------------------------------------------
不等間隔 数値積分 その2

/x(m)
| f(x)dx
/x(1)
積分区間 x(1)〜x(m)

LET N=5 !'データ数  条件...MOD(N-1,M-1)=0
LET M=3 !'小区間 間隔数
DIM X(N),Y(N),XX(M),YY(M)
FOR I=1 TO N
   READ X(I),Y(I) !'y=x^2
NEXT I
LET S=0
FOR I=1 TO N-M+1 STEP M-1 !'小区間に分割する X(1)〜X(3),X(3)〜X(5),X(5)〜X(7),...
   FOR K=0 TO M-1
      LET XX(K+1)=X(I+K)
      LET YY(K+1)=Y(I+K)
   NEXT K
   LET S=S+INTEGRAL(XX,YY,M) !'全区間分を足し合わせる
   !'LET SS=SS+INTEGRAL2(XX,YY,M) !'下記参照
NEXT I
PRINT S;(X(N)^3-X(1)^3)/3 !' ;SS
!'INPUT  PROMPT "f'(x) x=":XX
!'PRINT DERIVATIVE(N,X,Y,XX);2*XX !'下記参照
DATA 0,0 !'離散値データ X値は等間隔でなくてもいい
DATA 1,1
DATA 3,9
DATA 4,16
DATA 6,36
END

EXTERNAL  FUNCTION INTEGRAL(X(),Y(),M)
DECLARE EXTERNAL FUNCTION COMB
DIM H(M),XX(M),TEMP(M)
FOR I=1 TO M
   LET H(I)=1
   LET K=0
   FOR J=1 TO M
      IF I<>J THEN
         LET H(I)=H(I)/(X(I)-X(J))
         LET K=K+1
         LET XX(K)=X(J)
      END IF
   NEXT J
   LET SIGN=1
   FOR J=M TO 1 STEP -1
      LET SM=SM+SIGN*X(M)^J/J*COMB(XX,M,M-J,TEMP,1)*H(I)*Y(I)
      LET S1=S1+SIGN*X(1)^J/J*COMB(XX,M,M-J,TEMP,1)*H(I)*Y(I)
      LET SIGN=-SIGN
   NEXT J
NEXT I
LET INTEGRAL=SM-S1
END FUNCTION

EXTERNAL FUNCTION COMB(X(),N,R,A(),K)
IF R=0 THEN
   LET S=1
   FOR I=1 TO N
      IF A(I)=1 THEN LET S=S*X(I)
   NEXT I
   LET COMB=S
ELSE
   FOR I=K TO N-R+1
      LET A(I)=1
      LET SS=SS+COMB(X,N,R-1,A,I+1)
      LET A(I)=0
   NEXT I
   LET COMB=SS
END IF
END FUNCTION

--------------------------------------------------------------
不等間隔 数値積分 その3(上記参照)

未定係数法

EXTERNAL  FUNCTION INTEGRAL2(X(),Y(),N)
DIM A(N,N),B(N)
FOR I=1 TO N
   FOR J=1 TO N
      LET A(I,J)=X(J)^(I-1)
   NEXT J
   LET B(I)=(X(N)^I-X(1)^I)/I
NEXT I
MAT A=INV(A)
MAT B=A*B
FOR I=1 TO N
   LET S=S+B(I)*Y(I)
NEXT I
LET INTEGRAL2=S
END FUNCTION

--------------------------------------------------------------
不等間隔 数値微分(上記参照)

EXTERNAL  FUNCTION DERIVATIVE(N,X(),Y(),XX)
DIM A(N,N),B(N)
FOR I=1 TO N
   FOR J=1 TO N
      LET A(I,J)=X(J)^I
   NEXT J
   LET B(I)=I*XX^(I-1)
   !'LET B(I)=I*(I-1)*XX^(I-2) !'2階微分
NEXT I
MAT A=INV(A)
MAT B=A*B
FOR I=1 TO N
   LET S=S+B(I)*Y(I)
NEXT I
LET DERIVATIVE=S
END FUNCTION

--------------------------------------------------------------
不等間隔 数値微分(定義のみ)

EXTERNAL  FUNCTION DIFF(N,X(),Y(),XX)
DIM A(N)
FOR I=1 TO N
   LET  L=1
   LET  KK=0
   FOR J=1 TO N
      IF J<>I THEN
         LET  KK=KK+1
         LET  L=L*(X(I)-X(J))
         LET  A(KK)=X(J)
      END IF
   NEXT  J
   LET  S1=0
   FOR J=1 TO N-1
      LET  S=1
      FOR K=1 TO N-1
         IF K<>J THEN LET S=S*(XX-A(K))
      NEXT K
      LET  S1=S1+S
   NEXT J
   LET  SS=SS+S1*Y(I)/L
NEXT I
LET  DIFF=SS
END FUNCTION 		 

多重積分

 投稿者：しばっち  投稿日：2008年12月30日(火)09時45分18秒 		返信・引用
  再帰呼出しによる多重積分 シンプソン則

PUBLIC NUMERIC LEVEL
INPUT  PROMPT "多重積分 LEVEL=":LEVEL
DIM A(LEVEL),B(LEVEL),N(LEVEL),AA(LEVEL)
FOR I=1 TO LEVEL
   !'INPUT  PROMPT "下限  =":A(I)
   !'INPUT  PROMPT "上限  =":B(I)
   !'INPUT  PROMPT "分割数=":N(I)
   READ A(I),B(I),N(I)
NEXT I
DATA 0,1,10
DATA 0,1,10
DATA 0,1,10
DATA 0,1,10
PRINT SIMPSONRECURSIVE(LEVEL,AA,A,B,N)
END

EXTERNAL  FUNCTION SIMPSONRECURSIVE(LEV,AA(),A(),B(),N())
IF LEV=0 THEN
   LET  SIMPSONRECURSIVE=FUNC(AA)
ELSE
   LET  H=(B(LEV)-A(LEV))/N(LEV)/2
   FOR K=0 TO N(LEV)-1
      LET  AA(LEV)=A(LEV)+H*K*2
      LET  S=S+1/3*H*SIMPSONRECURSIVE(LEV-1,AA,A,B,N)
      LET  AA(LEV)=A(LEV)+H*(2*K+1)
      LET  S=S+4/3*H*SIMPSONRECURSIVE(LEV-1,AA,A,B,N)
      LET  AA(LEV)=A(LEV)+H*(2*K+2)
      LET  S=S+1/3*H*SIMPSONRECURSIVE(LEV-1,AA,A,B,N)
   NEXT K
   LET SIMPSONRECURSIVE=S
END IF
END FUNCTION

EXTERNAL  FUNCTION FUNC(X())
LET S=1
FOR I=1 TO LEVEL
   LET S=S-X(I)*X(I)
NEXT I
IF S > 0 THEN
   LET FUNC=SQR(S)
ELSE
   LET FUNC=0
END IF
END FUNCTION

--------------------------------------------------------------
再帰呼出しによる多重積分 ガウス・ルジャンドル則

PUBLIC NUMERIC W(10),X(10),LEVEL
INPUT  PROMPT "多重積分 LEVEL=":LEVEL
DIM A(LEVEL),B(LEVEL),XX(LEVEL),WW(LEVEL)
FOR I=1 TO LEVEL
   READ A(I),B(I)
NEXT I
DATA 0,1
DATA 0,1
DATA 0,1
DATA 0,1
RESTORE 10
FOR I=1 TO 10
   READ X(I),W(I)
NEXT I
PRINT LEGENDRERECURSIVE(LEVEL,XX,WW,A,B,10)
10 DATA -.9739065285171717,6.6671344308688138E-02 !'10点 ルジャンドル則
   DATA -.8650633666889845,1.4945134915058059E-01
   DATA -.6794095682990244,2.1908636251598204E-01
   DATA -.4333953941292472,2.6926671930999636E-01
   DATA -.1488743389816312,2.9552422471475287E-01
   DATA  .1488743389816312,2.9552422471475287E-01
   DATA  .4333953941292472,2.6926671930999636E-01
   DATA  .6794095682990244,2.1908636251598204E-01
   DATA  .8650633666889845,1.4945134915058059E-01
   DATA  .9739065285171717,6.6671344308688138E-02
END

EXTERNAL  FUNCTION LEGENDRERECURSIVE(LEV,XX(),WW(),A(),B(),N)
   IF LEV=0 THEN
      LET LEGENDRERECURSIVE=FUNC(XX)
   ELSE
      FOR I=1 TO N
         LET XX(LEV)=X(I)*(B(LEV)-A(LEV))/2+(A(LEV)+B(LEV))/2
         LET WW(LEV)=W(I)*(B(LEV)-A(LEV))/2
         LET S=S+LEGENDRERECURSIVE(LEV-1,XX,WW,A,B,N)*WW(LEV)
      NEXT I
      LET LEGENDRERECURSIVE=S
   END IF
END FUNCTION

EXTERNAL  FUNCTION FUNC(X())
LET S=1
FOR I=1 TO LEVEL
   LET S=S-X(I)*X(I)
NEXT I
IF S > 0 THEN
   LET FUNC=SQR(S)
ELSE
   LET FUNC=0
END IF
END FUNCTION

--------------------------------------------------------------
再帰呼出しによる多重積分 チェビシェフ則

PUBLIC NUMERIC LEVEL
INPUT  PROMPT "多重積分 LEVEL=":LEVEL
DIM A(LEVEL),B(LEVEL),N(LEVEL),X(LEVEL),W(LEVEL)
FOR I=1 TO LEVEL
   !'INPUT  PROMPT "下限  =":A(I)
   !'INPUT  PROMPT "上限  =":B(I)
   !'INPUT  PROMPT "分割数=":N(I)
   READ A(I),B(I),N(I)
NEXT I
DATA 0,1,10
DATA 0,1,10
DATA 0,1,10
DATA 0,1,10
PRINT TCHEBYCHEFFRECURSIVE(LEVEL,X,W,A,B,N)
END

EXTERNAL  FUNCTION TCHEBYCHEFFRECURSIVE(LEV,XX(),WW(),A(),B(),N())
IF LEV=0 THEN
   LET TCHEBYCHEFFRECURSIVE=FUNC(XX)
ELSE
   FOR I=0 TO N(LEV)-1
      LET XX(LEV)=COS((2*I+1)/2/N(LEV)*PI)*(B(LEV)-A(LEV))/2+(A(LEV)+B(LEV))/2
      LET WW(LEV)=SQR((B(LEV)-XX(LEV))*(XX(LEV)-A(LEV)))
      LET S=S+TCHEBYCHEFFRECURSIVE(LEV-1,XX,WW,A,B,N)*WW(LEV)
   NEXT I
   LET TCHEBYCHEFFRECURSIVE=S*PI/N(LEV)
END IF
END FUNCTION

EXTERNAL  FUNCTION FUNC(X())
LET S=1
FOR I=1 TO LEVEL
   LET S=S-X(I)*X(I)
NEXT I
IF S > 0 THEN
   LET FUNC=SQR(S)
ELSE
   LET FUNC=0
END IF
END FUNCTION

--------------------------------------------------------------
再帰呼出しによる多重積分 二重指数関数法(DE法)

[a,b]    q(t)=(b-a)/2*TANH(π/2*SINH(t))+(a+b)/2 q'(t)=π/2*(B-A)/2*COSH(X)*SECH(π/2*SINH(X))^2
[0,∞]   q(t)=EXP(π/2*SINH(t)) q'(t)=π/2*COSH(t)*EXP(π/2*SINH(t))
[-∞,∞] q(t)=SINH(π/2*SINH(t)) q'(t)=π/2*COSH(t)*COSH(π/2*SINH(t))

無限区間多重積分

PUBLIC NUMERIC LEVEL
INPUT  PROMPT "多重積分 LEVEL=":LEVEL
DIM X(LEVEL)
PRINT DE(LEVEL,X,1/16);PI^(LEVEL/2)
END

EXTERNAL  FUNCTION DE(LEV,X(),H)
IF LEV=0 THEN
   LET DE=FUNC(X)
ELSE
   FOR K=-4 TO 4 STEP H !'(要)調整 K=-6〜6,H=1/1000 程度
      LET X(LEV)=Q(K)
      LET  S=S+H*DE(LEV-1,X,H)*QQ(K)
   NEXT   K
   LET DE=S
END IF
END FUNCTION

EXTERNAL  FUNCTION Q(X)
LET Q=SINH(PI/2*SINH(X))
END FUNCTION

EXTERNAL  FUNCTION QQ(X)
LET QQ=PI/2*COSH(X)*COSH(PI/2*SINH(X))
END FUNCTION

EXTERNAL  FUNCTION FUNC(X())
LET S=0
FOR I=1 TO LEVEL
   LET S=S-X(I)*X(I)
NEXT I
LET  FUNC=EXP(S)
END FUNCTION 		 

モンテカルロ積分

 投稿者：しばっち  投稿日：2008年12月30日(火)09時46分32秒 		返信・引用
  多重積分モンテカルロ

RANDOMIZE
PUBLIC NUMERIC LEVEL
INPUT  PROMPT "多重積分 LEVEL=":LEVEL
DIM A(LEVEL),B(LEVEL),N(LEVEL),AA(LEVEL)
FOR I=1 TO LEVEL
!'INPUT  PROMPT "下限  =":A(I)
!'INPUT  PROMPT "上限  =":B(I)
!'INPUT  PROMPT "分割数=":N(I)
   READ A(I),B(I),N(I)
NEXT I
PRINT MONTE(LEVEL,A,B,10000)
!'PRINT MONTE2(LEVEL,A,B,10000,2000)
!'PRINT MONTESIMPSON(LEVEL,A,B,10000)
!'PRINT MONTERECURSIVE(LEVEL,AA,A,B,N)
DATA 0,1,50
DATA 0,1,50
DATA 0,1,50
DATA 0,1,50
END

EXTERNAL  FUNCTION MONTE(LEV,A(),B(),N)
RANDOMIZE
DIM AA(LEV)
LET H=1
FOR I=1 TO LEV
   LET H=H*(B(I)-A(I))
NEXT I
FOR K=1 TO N
   FOR I=1 TO LEV
      LET  AA(I)=A(I)+(B(I)-A(I))*RND
   NEXT I
   LET S=S+FUNC(AA)
NEXT  K
LET MONTE=H*S/N
END FUNCTION

EXTERNAL  FUNCTION MONTE2(LEV,A(),B(),N,NN)
RANDOMIZE
DIM AA(LEV)
LET HMAX=-MAXNUM
LET HMIN=MAXNUM
LET HH=1
FOR I=1 TO LEV
   LET HH=HH*(B(I)-A(I))
NEXT I
FOR K=1 TO NN
   FOR J=1 TO LEV
      LET  AA(J)=A(J)+(B(J)-A(J))*RND
   NEXT J
   LET H=FUNC(AA)
   LET HMIN=MIN(HMIN,MIN(H,0))
   LET HMAX=MAX(H,HMAX)
NEXT K
LET H=HMAX-HMIN
FOR K=1 TO N
   FOR J=1 TO LEV
      LET  AA(J)=A(J)+(B(J)-A(J))*RND
   NEXT J
   LET Z=H*RND+HMIN
   IF FUNC(AA) > 0 THEN
      IF Z > 0 AND Z < FUNC(AA) THEN LET M1=M1+1
   ELSE
      IF Z < 0 AND Z > FUNC(AA) THEN LET M2=M2+1
   END IF
NEXT K
LET MONTE2=HH*(M1-M2)/N*H
END FUNCTION

EXTERNAL  FUNCTION MONTERECURSIVE(LEV,AA(),A(),B(),N()) !'再帰式モンテカルロ
IF LEV=0 THEN
   LET  MONTERECURSIVE=FUNC(AA)
ELSE
   LET  H=B(LEV)-A(LEV)
   FOR K=1 TO N(LEV)
      LET  AA(LEV)=A(LEV)+H*RND
      LET S=S+MONTERECURSIVE(LEV-1,AA,A,B,N)
   NEXT K
   LET MONTERECURSIVE=H*S/N(LEV)
END IF
END FUNCTION

EXTERNAL  FUNCTION MONTESIMPSON(LEV,A(),B(),N)  !'モンテカルロ＋シンプソン則
RANDOMIZE
DIM AA(LEV),T(LEV),HH(LEV)
LET H=1
FOR I=1 TO LEV
   LET H=H*(B(I)-A(I))
   LET HH(I)=(B(I)-A(I))/N/2
NEXT I
FOR K=1 TO N
   FOR I=1 TO LEV
      LET T(I)=(B(I)-A(I))*RND+A(I)
      LET AA(I)=A(I)+T(I)
   NEXT I
   LET S=S+1/3*H*FUNC(AA)
   FOR I=1 TO LEVEL
      LET AA(I)=A(I)+HH(I)+T(I)
   NEXT I
   LET S=S+4/3*H*FUNC(AA)
   FOR I=1 TO LEVEL
      LET AA(I)=A(I)+2*HH(I)+T(I)
   NEXT I
   LET S=S+1/3*H*FUNC(AA)
NEXT  K
LET MONTESIMPSON=S/N/2
END FUNCTION

EXTERNAL  FUNCTION FUNC(X())
LET S=1
FOR I=1 TO LEVEL
   LET S=S-X(I)*X(I)
NEXT I
IF S > 0 THEN
   LET FUNC=SQR(S)
ELSE
   LET FUNC=0
END IF
END FUNCTION

-----------------------------------------------
無限区間 多重積分モンテカルロ

PUBLIC NUMERIC LEVEL
INPUT  PROMPT "多重積分 LEVEL=":LEVEL
DIM X(LEVEL)
PRINT MONTEDE(LEVEL,X,10000);PI^(LEVEL/2)
END

EXTERNAL  FUNCTION MONTEDE(LEV,X(),N) !'モンテカルロ + DE法
RANDOMIZE
LET M=4 !'(要) 調整
LET H=2*M/N
FOR J=1 TO N
   LET V=1
   FOR I=1 TO LEV
      LET K=RND*M*2-M
      LET X(I)=Q(K)
      LET V=V*QQ(K)
   NEXT I
   LET S=S+H^LEV*FUNC(X)*V
NEXT J
LET MONTEDE=S*N^(LEV-1)
END FUNCTION

EXTERNAL  FUNCTION FUNC(X())
FOR I=1 TO LEVEL
   LET S=S-X(I)*X(I)
NEXT I
LET  FUNC=EXP(S)
END FUNCTION

EXTERNAL  FUNCTION Q(X)
LET Q=SINH(PI/2*SINH(X))
END FUNCTION

EXTERNAL  FUNCTION QQ(X)
LET QQ=PI/2*COSH(X)*COSH(PI/2*SINH(X))
END FUNCTION 		 

おまけ

 投稿者：しばっち  投稿日：2008年12月30日(火)09時47分40秒 		返信・引用
           /1 /1   /1
多重積分 |  | ...| sqr(1-x*x-y*y-...)dxdy...の検証用です
         /0 /0   /0

半径を1/2(R=.5)で実行してください

!' S(n+2)=V(n)*2*π*r S(n)...n次元球の表面積
!' V(n)=S(n)*r/n      V(n)...n次元球の体積
!' V(n)=π^(n/2)/GAMMA(n/2+1)*r^n
LET MAXLEVEL=20
DIM S(MAXLEVEL+2),V(MAXLEVEL+2)
INPUT  PROMPT "半径=":R !' 検証時 R=.5
LET S(2)=2*PI*R
LET V(2)=PI*R^2
LET S(3)=4*PI*R^2
LET V(3)=4/3*PI*R^3
FOR N=2 TO MAXLEVEL
   LET S(N+2)=V(N)*2*PI*R
   LET V(N+2)=S(N+2)*R/(N+2)
   PRINT N;"次元球の体積";V(N)   !';TAB(40);"表面積";S(N)
NEXT N
END


--- おまけ ---

有理数モードでお試しください

LET MAXLEVEL=20
DIM S(MAXLEVEL+2,3),V(MAXLEVEL+2,3)
LET S(2,1)=2
LET S(2,2)=1
LET S(2,3)=1
LET S(3,1)=4
LET S(3,2)=1
LET S(3,3)=2
LET V(2,1)=1
LET V(2,2)=1
LET V(2,3)=2
LET V(3,1)=4/3
LET V(3,2)=1
LET V(3,3)=3
FOR N=2 TO MAXLEVEL
   LET S(N+2,1)=V(N,1)*2
   LET S(N+2,2)=V(N,2)+1
   LET S(N+2,3)=V(N,3)+1
   LET V(N+2,1)=S(N+2,1)/(N+2)
   LET V(N+2,2)=S(N+2,2)
   LET V(N+2,3)=S(N+2,3)+1
   PRINT STR$(N);"次元球の体積   ";
   IF V(N,1)<>1 THEN LET A$=STR$(V(N,1)) & "*" ELSE LET A$=""
   IF V(N,2)=1 THEN LET P$="π" ELSE LET P$="π^" & STR$(V(N,2))
   IF V(N,3)=1 THEN LET R$="*r" ELSE LET R$="*r^" & STR$(V(N,3))
   PRINT A$;P$;R$
   PRINT STR$(N);"次元球の表面積 ";
   IF S(N,1)<>1 THEN LET A$=STR$(S(N,1)) & "*" ELSE LET A$=""
   IF S(N,2)=1 THEN LET P$="π" ELSE LET P$="π^" & STR$(S(N,2))
   IF S(N,3)=1 THEN LET R$="*r" ELSE LET R$="*r^" & STR$(S(N,3))
   PRINT A$;P$;R$
   PRINT
NEXT N
END


--- おまけ 2---

!'ｎ次元球の体積
!'V(n)=1/(1*3*5*7*..*N)*2^((N+1)/2)*π^((N-1)/2)*R^N ...MOD(N,2)=1
!'V(n)=1/(2*4*6*8*..*N)*2^(N/2)    *π^(N/2)    *R^N ...MOD(N,2)=0
LET MAXLEVEL=20
FOR N=2 TO MAXLEVEL
   LET S=1
   FOR I=N TO 2 STEP -2
      LET  S=S/I
   NEXT I
   PRINT N;"次元球の体積   ";STR$(S*2^((N+MOD(N,2))/2));"*π^";STR$((N-MOD(N,2))/2);"*r^";STR$(N)
   PRINT N;"次元球の表面積 ";STR$(N*S*2^((N+MOD(N,2))/2));"*π^";STR$((N-MOD(N,2))/2);"*r^";STR$(N-1)
   PRINT
NEXT N
END

※ 便宜上「球」「体積」「表面積」として表示しています。
※ 2次元において、球とは「円」、体積とは「面積」、表面積とは「円周」のことです。
※ 4次元以上においても、これらの表示が正しいかどうか定かではありません。
※ n次元物体の「表面積」とは、n-1次元物体のことです。 		 

PLOT TEXT

 投稿者：白石　和夫  投稿日：2008年12月30日(火)10時05分24秒 		返信・引用
  > No.204[元記事へ]

現バージョンでは，PLOT TEXT文は表向き相似変換にのみ対応しています。
詳細と，対策は
http://hp.vector.co.jp/authors/VA008683/G_COMMANDS.htm
にあります。 		 

Re: PLOT TEXT

 投稿者：SECOND  投稿日：2008年12月30日(火)14時22分40秒 		返信・引用
  > No.221[元記事へ]

白石 先生へ

当時も、ASK PIXEL ARRAY文と、MAT PLOT CELLS文で、時計文字盤の全体を
包んで やってみたのですが著しい速度低下で、だめでした。
文字のみの１２領域に分けて、余計な画素を送らないようにすればどうか、
もう一度試してみます。他に、何か代替する方法がありましたら、ご教示ください。 		 

７セグメント数字表示のデジタル時計

 投稿者：山中和義  投稿日：2008年12月31日(水)09時21分11秒 		返信・引用
  以前作った論理回路サブルーチンの一部を使って電子工作ふ〜（チップの組み立て）の記述です。
!７セグメント数字表示のデジタル時計（Clock）

LET w=400 !画面の大きさ
LET h=120
SET bitmap SIZE w+1,h+1 !ドット単位にする
SET WINDOW 0,w,h,0 !クライアント座標（左上が原点）


LET S0=-1
DO
   LET t$=TIME$ !時刻をhh:mm:ss形式で得る

   LET S=VAL(t$(7:8)) !秒
   IF S<>S0 THEN !更新されたら
      LET S0=S

      LET H=VAL(t$(1:2)) !時
      LET M=VAL(t$(4:5)) !分

      CALL clock_display(INT(H/10),MOD(H,10),INT(M/10),MOD(M,10),INT(S/10),MOD(S,10))
   END IF
LOOP



!電子部品（配置と配線）

!         ↓BCD(h10,h1,m10,m1,s10,s1)
!  ┌─ データラッチ
!  │     ↓BCD
!  │   デコーダ
!  │     ↓abcdefg
!  └→ 88:88:88
!         │
!         GND
SUB clock_display(h10,h1,m10,m1,s10,s1) !表示部
   SET DRAW mode hidden !ちらつき防止(開始)
   CLEAR

   DRAW LED(1,GND) WITH SCALE(20)*SHIFT(155,40) !コロン
   DRAW LED(1,GND) WITH SCALE(20)*SHIFT(155,80)

   !ダイナミック点灯表示
   DRAW DRIVER7segment(h10) WITH SCALE(20)*SHIFT(50,60) !時
   DRAW DRIVER7segment(h1) WITH SCALE(20)*SHIFT(110,60)

   DRAW DRIVER7segment(m10) WITH SCALE(20)*SHIFT(200,60) !分
   DRAW DRIVER7segment(m1) WITH SCALE(20)*SHIFT(260,60)

   DRAW DRIVER7segment(s10) WITH SCALE(15)*SHIFT(320,70) !秒
   DRAW DRIVER7segment(s1) WITH SCALE(15)*SHIFT(370,70)

   SET DRAW mode explicit !ちらつき防止(終了)
END SUB

PICTURE DRIVER7segment(BCD) !７セグメント数字表示にする
   CALL DECODE7segment(BCD, Za,Zb,Zc,Zd,Ze,Zf,Zg)
   DRAW LED7segmentKwithoutDP(Za,Zb,Zc,Zd,Ze,Zf,Zg)
END PICTURE


!電子部品（上位）

SUB DECODE7segment(n, Za,Zb,Zc,Zd,Ze,Zf,Zg) !７セグメント数字表示デコーダ
   IF n=0 THEN
      LET ptn$="1111110" !abcdedfgのオン・オフ状態
   ELSEIF n=1 THEN
      LET ptn$="0110000"
   ELSEIF n=2 THEN
      LET ptn$="1101101"
   ELSEIF n=3 THEN
      LET ptn$="1111001"
   ELSEIF n=4 THEN
      LET ptn$="0110011"
   ELSEIF n=5 THEN
      LET ptn$="1011011"
   ELSEIF n=6 THEN
      LET ptn$="1011111"
   ELSEIF n=7 THEN
      LET ptn$="1110000"
   ELSEIF n=8 THEN
      LET ptn$="1111111"
   ELSEIF n=9 THEN
      LET ptn$="1111011"
   ELSE
      PRINT "不正な値です。"; n
   END IF

   LET Za=VAL(ptn$(1:1))
   LET Zb=VAL(ptn$(2:2))
   LET Zc=VAL(ptn$(3:3))
   LET Zd=VAL(ptn$(4:4))
   LET Ze=VAL(ptn$(5:5))
   LET Zf=VAL(ptn$(6:6))
   LET Zg=VAL(ptn$(7:7))
END SUB

!    --a-      配置位置
!  f|    |b
!    --g-
!  e|    |c
!    --d-
PICTURE LED7segmentKwithoutDP(a,b,c,d,e,f,g) !７セグメント数字表示器  ※カソード・コモン
   DRAW bar(a,GND) WITH SHIFT(0,-2) !※左上が原点
   DRAW bar(b,GND) WITH ROTATE(PI/2)*SHIFT(1,-1)
   DRAW bar(c,GND) WITH ROTATE(PI/2)*SHIFT(1,1)
   DRAW bar(d,GND) WITH SHIFT(0,2)
   DRAW bar(e,GND) WITH ROTATE(PI/2)*SHIFT(-1,1)
   DRAW bar(f,GND) WITH ROTATE(PI/2)*SHIFT(-1,-1)
   DRAW bar(g,GND) WITH SHIFT(0,0)
END PICTURE


!電子部品（下位）

PICTURE bar(a,k) !発光ダイオードを表示する
   IF a=1 AND k=0 THEN
      PLOT AREA: -1,-0.3; 1,-0.3; 1,0.3; -1,0.3 !点灯　※塗り潰し
   ELSE
      PLOT LINES: -1,-0.2; 1,-0.2; 1,0.2; -1,0.2; -1,-0.2 !消灯　※枠
   END IF
END PICTURE

PICTURE LED(a,k) !発光ダイオードを表示する
   IF a=1 AND k=0 THEN
      DRAW disk WITH SCALE(0.4) !点灯
   ELSE
      DRAW circle WITH SCALE(0.4) !消灯
   END IF
END PICTURE

END
 

Re: ７セグメント数字表示のデジタル時計

 投稿者：SECOND  投稿日：2009年 1月 1日(木)03時00分30秒 		返信・引用
  > No.223[元記事へ]

!　山中さんの７セグ数字で、気が付いた。ありがとうございます。
!　plot_lines の、vector_fontで、PLOT TEXT を、カバーできた。
!　やや長文と、やせた字形は難点ながら、時計の数字も、鏡像になった。
!
!-------------------
LET N=2
LET NN=2^N
SET WINDOW -250/NN,250/NN,250/NN,-250/NN
SET TEXT COLOR 4
SET TEXT BACKGROUND "OPAQUE"
LET φ=0
LET stp=-PI/180*6
DO
   LET t=INT(TIME)
   IF t0<>t THEN
      LET t0=t
      IF 2*PI<=ABS(φ) THEN LET stp=-stp
      LET φ=REMAINDER(φ, 2*PI) +stp
      !-----
      SET DRAW mode hidden
      CLEAR
      DRAW D4(N) WITH SHIFT(-300/2,-300/2/SQR(3))*ROTATE(φ*(-1)^N)*SCALE(1,(-1)^N)
      DRAW center WITH SHIFT(-300/2/NN,-300/2/NN/SQR(3))*ROTATE(φ)
      PLOT TEXT,AT 137/NN,-234/NN:"右クリックで停止"
      SET DRAW mode explicit
   ELSE
      WAIT DELAY 0.05 !　省電力効果
   END IF
   MOUSE POLL mx,my,mlb,mrb
LOOP UNTIL mrb>=1 !　右クリックで停止

PICTURE center
   SET LINE COLOR 2
   SET LINE width 2
   PLOT LINES:0,0;300/NN,0;300/2/NN,300/2/NN*SQR(3);0,0
   SET LINE width 1
   SET LINE COLOR 1
END PICTURE

!------
PICTURE D4(k)
   IF 0< k THEN
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*SHIFT(300/4,SQR(3)*300/4) !　内側の上
      DRAW D4(k-1) WITH SCALE(1/2,-1/2)*SHIFT(300/4,SQR(3)*300/4) !　内側の中
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*ROTATE(-PI*2/3)*SHIFT(300/4,SQR(3)*300/4) !内側の左
      DRAW D4(k-1) WITH SCALE(1/2,1/2)*ROTATE(PI*2/3)*SHIFT(300,0) !　内側の右
   ELSE
      DRAW 時計図 WITH ROTATE(-φ)*SHIFT(300/2,300/2/SQR(3))
      PLOT LINES:0,0;300,0;300/2,SQR(3)*300/2;0,0 !　外側の基準三角形（直接の描画は無し。)
   END IF
END PICTURE

!------
PICTURE 時計図
   SET AREA COLOR 1
   FOR i=1 TO 60
      LET a=PI/30*(i-15)
      IF MOD(i,5)=0 THEN
         CALL linefont(i/5, 60*COS(a), 60*SIN(a)) !数字
         DRAW disk WITH SCALE(1)*SHIFT(72*COS(a),72*SIN(a)) !５分目盛り
      ELSE
         DRAW disk WITH SCALE(.5)*SHIFT(72*COS(a),72*SIN(a)) !１分目盛り
      END IF
   NEXT i
   !---　00:00 からｔ秒 の針回転 Gear
   DRAW hand(1) WITH SCALE(2.5, 0.75)*ROTATE(t*PI/21600) !　時針
   DRAW hand(1) WITH ROTATE(t*PI/1800) !　分針
   DRAW hand(2) WITH SCALE(0, 1.1)*ROTATE(t*PI/30) !　秒針
   !---　中心の飾り
   DRAW disk WITH SHIFT(0,0)*SCALE(4)
END PICTURE

PICTURE hand(c) !　３針共用
   SET AREA COLOR c
   PLOT AREA: -1,15; 1,15; 1,-60; -1,-60
END PICTURE

!-------------------------------------
SUB linefont(i,x,y) !　plot text の代替
   SELECT CASE i
   CASE 1
      PLOT LINES:x+2.6,y-5;x+2.6,y+5 ! 1
   CASE 2
      PLOT LINES:x-2.6,y-5;x+2.6,y-5;x+2.6,y;x-2.6,y;x-2.6,y+5;x+2.6,y+5 ! 2
   CASE 3
      PLOT LINES:x-2.6,y-5;x+2.6,y-5;x+2.6,y+5;x-2.6,y+5 ! 3a
      PLOT LINES:x-2.6,y;x+2.6,y ! 3b
   CASE 4
      PLOT LINES:x-2.6,y-5;x-2.6,y;x+2.6,y ! 4a
      PLOT LINES:x+2.6,y-5;x+2.6,y+5 ! 4b
   CASE 5
      PLOT LINES:x+2.6,y-5;x-2.6,y-5;x-2.6,y;x+2.6,y;x+2.6,y+5;x-2.6,y+5 ! 5
   CASE 6
      PLOT LINES:x+2.6,y-5;x-2.6,y-5;x-2.6,y+5;x+2.6,y+5;x+2.6,y;x-2.6,y ! 6
   CASE 7
      PLOT LINES:x-2.6,y-5;x+2.6,y-5;x+2.6,y+5 ! 7
   CASE 8
      PLOT LINES:x-2.6,y;x-2.6,y-5;x+2.6,y-5;x+2.6,y+5;x-2.6,y+5;x-2.6,y;x+2.6,y ! 8
   CASE 9
      PLOT LINES:x+2.6,y;x-2.6,y;x-2.6,y-5;x+2.6,y-5;x+2.6,y+5;x-2.6,y+5 ! 9
   CASE 10
      LET x=x-7
      PLOT LINES:x+2.6,y-5;x+2.6,y+5 ! 1
      LET x=x+11
      PLOT LINES:x-2.6,y+5;x-2.6,y-5;x+2.6,y-5;x+2.6,y+5;x-2.6,y+5 ! 0
   CASE 11
      LET x=x-5
      PLOT LINES:x+2.6,y-5;x+2.6,y+5 ! 1
      LET x=x+9
      PLOT LINES:x+2.6,y-5;x+2.6,y+5 ! 1
   CASE 12
      LET x=x-7
      PLOT LINES:x+2.6,y-5;x+2.6,y+5 ! 1
      LET x=x+11
      PLOT LINES:x-2.6,y-5;x+2.6,y-5;x+2.6,y;x-2.6,y;x-2.6,y+5;x+2.6,y+5 ! 2
   CASE ELSE
   END SELECT
END SUB

END 		 

Re: ７セグメント数字表示のデジタル時計

 投稿者：荒田浩二  投稿日：2009年 1月 2日(金)21時16分48秒 		返信・引用 　編集済
  > No.224[元記事へ]

SECONDさんへのお返事です。

文字の鏡像を描画できるようにしました。MAT PLOT CELLSではその領域のすべての画素を描画し時間がかかるので、文字線のある画素のみ読込み、MAT PLOT POINTSで描画するようにしました。

SECONDさんのプログラムの３行目のSET WINDOW文の後ろにつぎのプログロムを挿入してみてください。既存のSUB linefontは廃してください。
Century体は日本語に対応してないので"右クリックで停止"を"Right Click to Stop"にもどしてください。

MAT PLOT文は3次元の配列には適応してないので、あまりスマートではないですがなんとか1秒以内に描画できると思います。遅れる場合は文字サイズ(th=13)を小さくしてみて下さい。

!
ASK TEXT HEIGHT ath
ASK TEXT JUSTIFY atjx$,atjy$
SET POINT STYLE 1
SET TEXT JUSTIFY "CENTER","HALF"
LET th=13
SET TEXT HEIGHT th
SET TEXT FONT "Century" ,0
ASK TEXT WIDTH("WW") tw
ASK PIXEL SIZE (0,0;1.2*th,1.2*tw) px,py
LET p=ABS(px*py)
DIM f0(p,2),f1(p,2),f2(p,2),f3(p,2),f4(p,2),f5(p,2),f6(p,2),f7(p,2),f8(p,2),f9(p,2),f10(p,2),f11(p,2),f12(p,2)
LET pitchx=WORLDX(PIXELX(0)+1)
LET pitchy=WORLDY(PIXELY(0)+1)
FOR i=1 TO 12
   PLOT TEXT ,AT 0,0 : STR$(i)
   MAT f0=ZER
   LET k=0
   FOR x=-0.6*tw TO 0.6*tw STEP pitchx
      FOR y=0.6*th TO -0.6*th STEP pitchy
         ASK PIXEL VALUE (x,y) pc
         IF pc=1 THEN ! 中間色(灰色)を読み込むなら条件を pc<>0
            LET k=k+1
            LET f0(k,1)=x
            LET f0(k,2)=y
         END IF
      NEXT y
   NEXT x
   CALL font_read
   CLEAR
NEXT i
SET TEXT HEIGHT ath
SET TEXT JUSTIFY atjx$,atjy$
!
SUB font_read
   MAT f12=ZER(k,2)
   FOR j=1 TO k
      LET f12(j,1)=f0(j,1)
      LET f12(j,2)=f0(j,2)
   NEXT j
   SELECT CASE i
   CASE 1
      MAT f1=f12
   CASE 2
      MAT f2=f12
   CASE 3
      MAT f3=f12
   CASE 4
      MAT f4=f12
   CASE 5
      MAT f5=f12
   CASE 6
      MAT f6=f12
   CASE 7
      MAT f7=f12
   CASE 8
      MAT f8=f12
   CASE 9
      MAT f9=f12
   CASE 10
      MAT f10=f12
   CASE 11
      MAT f11=f12
   CASE ELSE
   END SELECT
END SUB
SUB linefont(fi,x,y)
   SELECT CASE fi
   CASE 1
      DRAW  numplot(f1) WITH SHIFT(x,y)
   CASE 2
      DRAW  numplot(f2) WITH SHIFT(x,y)
   CASE 3
      DRAW  numplot(f3) WITH SHIFT(x,y)
   CASE 4
      DRAW  numplot(f4) WITH SHIFT(x,y)
   CASE 5
      DRAW  numplot(f5) WITH SHIFT(x,y)
   CASE 6
      DRAW  numplot(f6) WITH SHIFT(x,y)
   CASE 7
      DRAW  numplot(f7) WITH SHIFT(x,y)
   CASE 8
      DRAW  numplot(f8) WITH SHIFT(x,y)
   CASE 9
      DRAW  numplot(f9) WITH SHIFT(x,y)
   CASE 10
      DRAW  numplot(f10) WITH SHIFT(x,y)
   CASE 11
      DRAW  numplot(f11) WITH SHIFT(x,y)
   CASE 12
      DRAW  numplot(f12) WITH SHIFT(x,y)
   END SELECT
END SUB
PICTURE numplot(fm(,))
   MAT PLOT POINTS : fm
END PICTURE
!
 		 

Re: ７セグメント数字表示のデジタル時計

 投稿者：SECOND  投稿日：2009年 1月 2日(金)21時36分40秒 		返信・引用 　編集済
  > No.225[元記事へ]

荒田浩二さんへのお返事です。

ありがとうございます。
ただ私のパソコンは、Pentium-3, 500MHz なので、やや速度不足で、２秒飛びが増えて、
使用できませんでした。ごめんなさい。でも、MAT PLOT CELLS に比べ格段に高速です。 		 

“独自の拡張”

 投稿者：SECOND  投稿日：2009年 1月 2日(金)21時47分5秒 		返信・引用
 


十進BASIC の“独自の拡張”だけを、help から書き出してみた。

これをみると、DRAW GRID や、複素数など、重要な計算機能まで該当
しており、純粋な Full Basic でなくて、良かったと思います。


----------------------------------------------
OPTION ARITHMETIC DECIMAL_HIGH　 10進1000桁(超越関数は17桁(末尾偶数))
OPTION ARITHMETIC COMPLEX　　　　複素数
OPTION ARITHMETIC RATIONAL　　　 有理数(無理関数は10進17桁(末尾偶数))
----------------------------------------------
RANDOMIZE 5489 ( 引数に0〜4294967295)
----------------------------------------------
FACT(x)　　 xの階乗
PERM(n,r)　 順列の数
COMB(n,r)　 二項係数（組合せの数）
ROUND(x)　　xの小数点以下を丸めた値。
----------------------------------------------
BLEN(a$)　　　　　バイトを単位とするa$の文字列長。
SUBSTR$(a$,m,n)　 a$のm文字目からn文字目までの部分文字列
MID$(a$,m,n)　　　a$のm文字目からのn文字
LEFT$(a$,n)　　　 a$のはじめのn文字
RIGHT$(a$,n)　　　a$の末尾のn文字
----------------------------------------------
GetKeyState(n)　　キーの状態を調べる
----------------------------------------------
MAT A=CROSS(B,C)　　B,Cの外積(ベクトル積)
--------------------------------------------
MAT REDIM　　　　　配列の添字の上下限を再定義
----------------------------------------------
DIM A(N),B(2*N)　　添字の上下限指定に変数を含む数値式
----------------------------------------------
色名　"WHITE","BLACK","BLUE","GREEN","RED","CYAN","MAGENTA","YELLOW","GRAY","SILVER",
　　　"白","黒","青","緑","赤","黄"
----------------------------------------------
SET LINE WIDTH 数値式　　　　　　　　　　　　　　線の太さ
PLOT BEZIER: x1, y1 ; x2, y2 ; x3, y3; x4, y4　　ベジェ曲線を描く。
SET BEAM MODE "IMMORTAL"　 PLOT LINES以外の実行で描点の状態を変えない。
SET BEAM MODE "RIGOROUS"　 描点の状態をJISの規定通りにoffにする。
----------------------------------------------
PLOT LABEL ,AT x,y : 文字列式
PLOT LABEL ,AT x,y ,USING 書式指定 : 式, 式 , …, 式
SET TEXT FONT FontName$ ，size
ASK TEXT WIDTH(文字列式) 数値変数　　　文字列の問題座標系における横幅
SET TEXT BACKGROUND "TRANSPARENT"
SET TEXT BACKGROUND "OPAQUE"
----------------------------------------------
DRAW GRID　　　　 ｘ軸方向 間隔１，ｙ軸方向 間隔１の格子を描く。
DRAW GRID(p,q)　　ｘ軸方向 間隔p，ｙ軸方向 間隔qの格子を描く。
DRAW AXES　　　　 目盛り間隔がｘ軸方向１，ｙ軸方向１のｘ軸とｙ軸を描く。
DRAW AXES(p,q)　　目盛り間隔がｘ軸方向p，ｙ軸方向qのｘ軸とｙ軸を描く。
DRAW GRID0
DRAW AXES0
SET AXIS COLOR　　軸の色　　廃止予定
----------------------------------------------
DRAW circle　　　原点を中心とする半径1の円を描く。
DRAW disk　　　　原点を中心とする半径1の円とその内部を現在のarea colorで塗りつぶす。
----------------------------------------------
MOUSE POLL x,y,left,right　マウスの位置をx,y　left,rightにマウスボタンの状態
----------------------------------------------
PIXELX(x) 　問題座標xに対応するピクセルx座標
PIXELY(y) 　問題座標yに対応するピクセルy座標
WORLDX(x) 　ピクセルx座標を問題座標に変換
WORLDY(y) 　ピクセルy座標を問題座標に変換
PROBLEMX(x) WORLDX(x)と同義
PROBLEMY(y) WORLDY(y)と同義
----------------------------------------------
SET BITMAP SIZE width, height　描画領域の画素数
----------------------------------------------
FLOOD x,y　点(x,y)を始点として点(x,y)と同色でつながる領域を現在のarea colorで塗りつぶす。
PAINT x,y　点(x,y)を始点としてline colorの点を境界とする領域を現在のarea colorで塗りつぶす。
----------------------------------------------
GLOAD ファイル名　　指定された名前の画像ファイルを読み込む。
GSAVE ファイル名　　指定された名前で画像を保存する。
----------------------------------------------
SET COLOR MODE "NATIVE"　 色指定：下位8ビットが赤，中位8ビットが緑，上位8ビットが青
SET COLOR MODE "REGULAR"　パレットを用いる通常モード
COLORINDEX(r,g,b)　　　　 色指標を得る関数
----------------------------------------------
SET DRAW MODE HIDDEN　　 内部にあるビットマップメモリにのみ描画するモード
SET DRAW MODE EXPLICIT　 画面とビットマップメモリの双方に描画するモード（標準の状態）
SET DRAW MODE NOTXOR　　 画面の色と指定された色のNOTXORの色で描く
SET DRAW MODE OVERWRITE　指定された色で描く（標準の状態）
----------------------------------------------
WAIT DELAY 数値式　　指定された秒数だけ休止
PAUSE　　　　　　　　Enterキーを待つ。
PAUSE 文字列式　　　 文字列式の値を表示してEnterキーを待つ。
----------------------------------------------
EXECUTE ファイル名
EXECUTE ファイル名 WITH (式，式，･･･，式)
EXECUTE NOWAIT ファイル名
EXECUTE NOWAIT ファイル名 WITH (式，式，･･･，式)
PLAY 文字列式　　　　　関連付けを利用して文字列式が表すファイルをplayする。
PLAY NOWAIT 文字列式 　指定されたプログラムの実行が終わるのを待たずに次の行に進む。
ASSOC PRINT 文字列式　　関連付けを利用して文字列式が表すファイルをprintする。
----------------------------------------------
SWAP x,y　　　　　　　変数x,yの値を交換する。
BEEP　　　 　　　　　　警告音を発する。
BEEP 数値式1, 数値式2　　(NT/2000/XP) 数値式1は振動数(Hz)，数値式2は継続時間(ms)
PLAYSOUND 文字列式　　　　　サウンドファイルを再生する。
PLAYSOUND 文字列式 ,ASYNC　　再生が終わるのを待たずに次の行に進む。
----------------------------------------------
SET #経路番号 : ENDOFLINE CHR$(13)&CHR$(10)
SET #経路番号 : ENDOFLINE CHR$(10)&CHR$(13)
SET #経路番号 : ENDOFLINE CHR$(13)
SET #経路番号 : ENDOFLINE CHR$(10)
ASK #経路番号 : FILESIZE 数値変数　　バイト単位のファイル長
SET DIRECTORY a$　　　　　カレントディレクトリを、a$が指定するディレクトリに変更
ASK DIRECTORY s$　　　　　カレントディレクトリを表す文字列を、文字列変数s$に代入
FILE GETNAME s$　　　　　　ファイルを開くダイアログを表示し，指定するファイル名をs$に代入
FILE GETNAME s$, 文字列式　　文字列式を既定の拡張子としてファイルダイアログを開く
FILE SPLITNAME (a$) path$, name$, ext$　　ファイル名を表す文字列式a$を，3つに分割
FILE RENAME a$,b$　　　　　　　　　　　　a$が示すファイルの名前をb$に変える
FILE DELETE a$　　　　　　　　　　　　　a$が示すファイルを削除する。
FILE LIST 文字列式,s$　　　　　　　　　s$には１次元文字列配列を書く。
FILES(文字列式)　　　　　　　　　　　文字列式に合致するファイルの数。
----------------------------------------------
OPEN # 数値式 : PRINTER　　経路にプリンタを割り当てる
----------------------------------------------
OPEN # 数値式 : TextWindow1
OPEN # 数値式 : TextWindow1 ,ACCESS INPUT
OPEN # 数値式 : TextWindow1 ,ACCESS OUTPUT
OPEN # 数値式 : TextWindow1 ,ACCESS OUTIN
----------------------------------------------
COMPLEX(x , y)　複素数　x+ y i  　　//複素数モード
RE(z)　　　　　zの実部
IM(z)　　　　  zの虚部
CONJ(z)　　　  zの共役複素数　CONJ(x + y i)= x - y i
ARG(z)　　　　 zの偏角、angle radians(-π< ~<=π)　angle degrees(-180°< ~<=180°)
ABS(z)　　　　 zの絶対値
SQR(z)　　　　 zの平方根（偏角：-90°< ~<=90°)
SQR(-1)= i
EXP(z)　　　　 指数関数（角度単位は常にラジアン)
LOG(z)　　　　 zの自然対数。実部はlog|z|,虚部はarg z(単位は常にラジアンで -π〜π）。
図形変形関数の複素数への拡張( shift(z), scale(z),,, )
----------------------------------------------
NUMER(x)　　　xの分子(numerator)      //有理数モード
DENOM(x)　　　xの分母(denominator)
GCD(x,y)　　　xとyの最大公約数(Greatest Common Divisor)。結果は正符号をもつ。
INTSQR(x)　　 xの正の平方根の小数点以下を切り捨てた数値。INT(SQR(x))
INTLOG2(x)　　xの整数部分の2を底とする対数の整数部分。INT(LOG2(INT(x)))

 		 

２００９年占い

 投稿者：GAI  投稿日：2009年 1月 4日(日)18時27分13秒 		返信・引用
  2009年作品を挑戦
�　複坑娃娃押檻横娃娃后法爍后瓧沓沓掘　淵薀奪�ーセブン！！！大当たり）

�∪称顳横娃娃糠�＝平成２１年＝３×７年
より３，７で　３×７×３７＝７７７

��２００９＝７×７×７×７−７×７×７−７×７

�ぃ沓沓沓沓掘娃�
≡７７７７７＾７７
≡７７７７７＾７７７
≡７７７７７＾７７７７
≡７７７７７＾７７７７７
・・・・・・・・・・・・
≡７７７７７＾７７７・・・・・・・・・・・７
≡０（ＭＯＤ２００９） 		 

Re: “独自の拡張”

 投稿者：荒田浩二  投稿日：2009年 1月 4日(日)21時51分27秒 		返信・引用 　編集済
  > No.227[元記事へ]

SECONDさんへのお返事です。

これもありますよ。

----------------------------------------------
識別名に漢字が使えるように文法を拡張している。
識別名に使えるのは，JIS文字コード表で"０"(数字のゼロ)以降の文字。
ただし，全角英数字で始まる名前は不可。
----------------------------------------------

全角文字22文字からなる変数名です。(注意;環境依存文字もあります)
10 LET かぃ１ＢｄサΣβДя┴�鵜鍬吻岫爿澂筬絖雖鶲�=3
20 PRINT かぃ１ＢｄサΣβДя┴�鵜鍬吻岫爿澂筬絖雖鶲�+5
30 END 		 

Re: “独自の拡張”

 投稿者：SECOND  投稿日：2009年 1月 4日(日)22時42分47秒 		返信・引用
  > No.229[元記事へ]

漢字　については、次の様に書かれていました。

「Full BASICはコード番号が0から127までの文字を使用することを前提に
　規格化されている。そのため，JISには128番以降の文字を扱うことにしても
　よいという程度のことしか書かれていない。」

これを見ると、むずかしい判断ですね。
仕方が無いので、とりあえず、白石先生が、"独自の拡張"とマークされた個所
だけに、しています。 		 

Re: “独自の拡張”

 投稿者：荒田浩二  投稿日：2009年 1月 5日(月)00時08分3秒 		返信・引用
  > No.230[元記事へ]

SECONDさんへのお返事です。

なるほど。JISにもあいまいな規定があるのですね。

ところで、あのおかしな変数名を作っていて思ったのですが、白石先生に提案があります。
JISコードでギリシャ文字より後ろから漢字の前までを、識別名から除外してはいかがでしょうか。
ロシア文字を読める人は少ないでしょうし、罫線素片が識別名にふさわしいとも思えません。環境依存文字の使用回避にもなります。
JIS規格とのかねあいもあるでしょうが、ご検討をお願いします。（差し出がましく申し訳ありません） 		 

Re: “独自の拡張”

 投稿者：白石　和夫  投稿日：2009年 1月 6日(火)10時04分15秒 		返信・引用 　編集済
  > No.231[元記事へ]

公開するプログラムは，可能な限り，
http://hp.vector.co.jp/authors/VA008683/QA1.htm
に示すガイドラインにしたがってください。
独自拡張機能は，他に代替手段が存在しない場合にかぎり用いるのが大原則です。
たとえば，漢字などのマルチバイト文字を識別名に用いることは，代替手段が存在するので，推奨しません。
（外国人が見たら普通の漢字でも変てこな文字です） 		 

Re: “独自の拡張”

 投稿者：荒田浩二  投稿日：2009年 1月 6日(火)18時57分16秒 		返信・引用
  > No.232[元記事へ]

白石　和夫さんへのお返事です。

早速のご回答ありがとうございます。
個人で利用する以外では、拡張機能は使用してはいけないということですね。
漢字使用はともかく、拡張機能は便利なだけに原則を守るのはなかなか厳しいですが…。 		 

Knight's Tour（ナイト・ツアー）

 投稿者：SECOND  投稿日：2009年 1月 7日(水)16時10分5秒 		返信・引用 　編集済
  !
!　Knight's Tour（ナイト・ツアー）
!
!　注意！出発点に戻る経路 Closed Tour のみに、限定して計算。⇔Open Tour
!
!　KNIGHTGR.UB
!　Original Version　　1990/10/01 by unknown
!　Modified Version　　1997/04/10 by Aiichi Yamasaki
!　Modified Version　　2009/01/06 uBASIC から、十進Basic へ移植。
!--------------------
OPTION BASE 0
SET TEXT background "OPAQUE"
SET POINT STYLE 4
!
LET DF=0 !　0:通常　1:探索過程のstep　2:探索完了毎のstep //debug
LET Xw=6 !8 !　盤の横巾
LET Yw=6 !8 !　盤の縦巾
!-----
! Schwenk's Theorem
! For any m × n board with m less than or equal to n,
! a closed knight's tour is always possible
! unless one or more of these three conditions are true:
!１）m and n are both odd
!２）m = 1, 2, or 4; m and n are not both 1
!３）m = 3 and n = 4, 6, or 8
!
LET m= MIN(Xw,Yw)
LET n= MAX(Xw,Yw)
!
IF MOD(m,2)=1 AND MOD(n,2)=1 THEN CALL outer
IF (m=1 OR m=2 OR m=4) AND (m<>1 OR n<>1) THEN CALL outer
IF m=3 AND (n=4 OR n=6 OR n=8) THEN CALL outer

SUB outer
   beep
   PRINT "Xw=";Xw;"Yw=";Yw;" … No Closed Tour."
   STOP
END SUB

!-----
LET D0=INT(192/MAX(MAX(Xw,Yw),8)) !　盤の１目幅
SET WINDOW -55/D0, 445/D0, 370/D0,-130/D0
PLOT TEXT,AT 0,-50/D0:"Knight's Tour"
LET Xct= 0
LET Yct= -30/D0 !　count--time の位置
CALL guide( 205/D0, 10/D0) ! x,y
!-----init
DIM P_(-2 TO Yw+1,-2 TO Xw+1), E_(-2 TO Yw+1,-2 TO Xw+1), I_(Xw*Yw), DX_(7), DY_(7)
MAT READ DX_,DY_
DATA  2, 1,-1,-2,-2,-1, 1, 2
DATA  1, 2, 2, 1,-1,-2,-2,-1
!-----
IF DF<>0 THEN MAT PRINT USING REPEAT$("## ",8): DX_ ! //debug
IF DF<>0 THEN MAT PRINT USING REPEAT$("## ",8): DY_ ! //debug
!-----init P_
MAT P_=CON
FOR y=0 TO Yw-1
   FOR x=0 TO Xw-1
      LET P_(y,x)=0
   NEXT x
NEXT y
!-----init E_
MAT E_=20*CON
FOR y=0 TO Yw-1
   FOR x=0 TO Xw-1
      LET E_(y,x)=0
   NEXT x
NEXT y
FOR y=0 TO Yw-1
   FOR x=0 TO Xw-1
      LET c=8
      FOR i=0 TO 7
         LET c=c-P_(y+DY_(i),x+DX_(i))
      NEXT i
      LET E_(y,x)=c
   NEXT x
NEXT y
!-----
IF DF<>0 THEN MAT PRINT USING REPEAT$(" ##",Xw+4) :P_ ! //debug
IF DF<>0 THEN MAT PRINT USING REPEAT$(" ##",Xw+4) :E_ ! //debug
!-----
LET sp=0 !　0~(Xw*Yw-1) 階層位置（再帰型のStackPointerに相当）
LET xx=0 !　開始地点
LET yy=0 !　(0,0)
LET I_(sp)=-1 !　全階層の方向カウンター
LET Count=0
LET t0=TIME
IF DF<>0 THEN CALL PUTL(xx,yy,0,0,2) ! //debug
DO
   LET I_(sp)=I_(sp)+1
   LET ii=I_(sp)
   IF 7< ii THEN
      CALL BACK !　１層戻す。
   ELSE
      IF P_(yy+DY_(ii),xx+DX_(ii))=0 THEN !　重複検査。
         IF DF<>0 THEN CALL PUTL(xx,yy,DX_(ii),DY_(ii),2) ! //debug
         LET xx=xx+DX_(ii)
         LET yy=yy+DY_(ii)
         LET P_(yy,xx)=1
         !-----dec E_
         LET E_(yy,xx)= E_(yy,xx)+10
         FOR i=0 TO 7
            LET E_(yy+DY_(i),xx+DX_(i))= E_(yy+DY_(i),xx+DX_(i))-1
         NEXT i
         IF DF<>0 THEN CALL DISP_E ! 探索過程の配列 E_ モニター //debug
         !-----　１層進める。
         LET sp=sp+1
         LET I_(sp)=-1
         IF sp=Xw*Yw THEN
            CALL FIN !　１経路の完成。
            CALL BACK !　１層戻す。
         ELSEIF fnCHECK(xx,yy)<>0 THEN !　次の重複検査前の、予見検査。
            CALL BACK !　１層戻す。
         END IF
      END IF
   END IF
LOOP

SUB BACK
   LET P_(yy,xx)=0
   !-----inc E_
   LET E_(yy,xx)= E_(yy,xx)-10
   FOR i=0 TO 7
      LET E_(yy+DY_(i),xx+DX_(i))= E_(yy+DY_(i),xx+DX_(i))+1
   NEXT i
   !-----
   LET sp=sp-1
   IF sp=0 THEN STOP !　終了、Count：１倍
   !IF sp< 0 THEN STOP !　終了、Count：２倍（開始点も回転、帰路まで別経路になる）
   LET ii=I_(sp)
   LET xx=xx-DX_(ii)
   LET yy=yy-DY_(ii)
   IF DF<>0 THEN CALL PUTL(xx,yy,DX_(ii),DY_(ii),0) ! //debug
END SUB

FUNCTION fnCHECK(x,y) !　予見検査。
   LET c=0
   IF sp< Xw*Yw-1 THEN
      LET fnCHECK=1 !　帰りの引数＝１
      IF ABS(I_(1)-I_(0))=4 THEN EXIT FUNCTION !return(1)
      FOR i=0 TO 7
         IF E_(y+DY_(i),x+DX_(i))< 2 THEN
            IF E_(y+DY_(i),x+DX_(i))=0 THEN EXIT FUNCTION !return(1)
            LET c=c-1
         END IF
      NEXT i
      IF c< -1 THEN
         IF sp<>1 THEN EXIT FUNCTION !return(1)
      END IF
      FOR y=0 TO Yw-1
         FOR x=0 TO Xw-1
            IF E_(y,x)< 2 THEN
               IF E_(y,x)=0 THEN  EXIT FUNCTION !return(1)
               LET c=c+1
               IF c>1 THEN  EXIT FUNCTION !return(1)
            END IF
         NEXT x
      NEXT y
   END IF
   LET fnCHECK=0 !　帰りの引数＝０
END FUNCTION !return(0)

SUB PUTL(x,y,dx,dy,c)
   SET LINE COLOR c
   PLOT LINES: x,y; x+dx,y+dy
   PLOT POINTS: x+dx,y+dy
END SUB

SUB DISP_E
   PRINT
   MAT PRINT USING REPEAT$(" ##",Xw+4) :E_
   IF DF=1 THEN pause !　//debug
END SUB

SUB FIN
!-----disp_A
   SET AREA COLOR 0
   PLOT AREA :0,0; Xw-1,0; Xw-1,Yw-1; 0,Yw-1
   LET x=0
   LET y=0
   CALL PUTL(x,y,0,0,2)
   FOR s=0 TO Xw*Yw-1
      CALL PUTL(x,y,DX_(I_(s)),DY_(I_(s)),2)
      LET x=x+DX_(I_(s))
      LET y=y+DY_(I_(s))
   NEXT s
   !-----disp cout--time
   LET Count=Count+1
   LET t1=INT(TIME-t0)
   IF t1< 0 THEN LET t1=t1+86400
   PLOT TEXT,AT Xct,Yct :"count= "& STR$(Count)& " ----- "&
&& USING$("%%",MOD(INT(t1/3600),24))& ":"&
&& USING$("%%",MOD(INT(t1/60),60))& ":"& USING$("%%",MOD(t1,60))
   IF DF=2 THEN pause !　//debug
END SUB

!----------ガイド表示-----
SUB guide(x,y)
   PLOT TEXT,AT x,y: "H V　　一巡する経路の数"
   PLOT TEXT,AT x,y +20/D0,USING "3x4: can't close　　### open 参考": 2
   PLOT TEXT,AT x,y +40/D0,USING "5x5: can't close　　### open 参考": 304
   PLOT TEXT,AT x,y +60/D0,USING "5x6: ##,###,###,###,### closed": 8
   PLOT TEXT,AT x,y +80/D0,USING "6x6: ##,###,###,###,### closed": 9862
   PLOT TEXT,AT x,y+100/D0,USING "8x8: ##,###,###,###,### closed": 26534728821064
   !
   PLOT TEXT,AT x,y+140/D0:"Knight の移動規則"
   LET x=x+2
   LET y=y+160/D0+2
   SET LINE COLOR 2
   SET AREA COLOR 2
   LET j=SQR(5)
   FOR i=ATN(0.5) TO 2*PI STEP PI/2
      DRAW knight WITH ROTATE(i)*SHIFT(x,y)
      DRAW knight WITH ROTATE(-i)*SHIFT(x,y)
   NEXT i
   FOR j=-2 TO 2
      FOR i=-2 TO 2
         PLOT POINTS: x+i, y+j
      NEXT i
   NEXT j
END SUB

PICTURE knight
   PLOT LINES: 0,0; j,0
   PLOT AREA: j-0.4,-0.16; j,0; j-0.4,0.16; j-0.24,0
   PLOT POINTS: j,0
END PICTURE

END 		 

Re: “独自の拡張”

 投稿者：白石　和夫  投稿日：2009年 1月 7日(水)16時59分52秒 		返信・引用
  > No.233[元記事へ]

JISの範囲外の機能については，将来，変更もありえます。
たとえば，マルチバイト文字の識別名を使えなくする変更の可能性もあります。
（国際化の観点を重視すればその方向に進むことになります。）
なので，規格外の機能の使用は可能なかぎり避けてください。 		 

PAUSE ボタン

 投稿者：SECOND  投稿日：2009年 1月 7日(水)17時15分48秒 		返信・引用
  PAUSE の WINHANDLE(文字列式) が、解りません。
Box 位置の移動は、どうすればよいでしょうか。 		 

Re: PAUSE ボタン

 投稿者：白石　和夫  投稿日：2009年 1月 7日(水)20時35分51秒 		返信・引用 　編集済
  > No.236[元記事へ]

PAUSEのフォームは常駐しないので，ハンドルの取得は難しいかと思います。
（PAUSE文のなかでウィンドウの作成から消去までの動作が完結してしまっている）
BASICの複数起動を行うようなことをすればできるかもしれませんが，一般には，
Win32APIを使って独自のウィンドウを作るのが順当な解決策のように思います。 		 

Re: PAUSE ボタン

 投稿者：SECOND  投稿日：2009年 1月 7日(水)21時03分44秒 		返信・引用
  > No.237[元記事へ]

白石 先生へ

　ありがとうございました。 		 

Re: “独自の拡張”

 投稿者：荒田浩二  投稿日：2009年 1月 8日(木)12時57分40秒 		返信・引用
  > No.233[元記事へ]

配列の添字の再定義をJISの規格内でできるようにしました。

JISに従うと、配列の宣言で添字には数値定数しか使えなくなります。
あらかじめある程度大きく配列を宣言しておき、MAT文で配列の大きさを変更できます。

DIM A(100),B(100),C(100)
LET m=3
LET n=8
MAT A=ZER(m)
MAT B=ZER(m*n)
MAT C=ZER(m TO n)

ところがMAT文では添字の下限を変更することはできないため、Cの下限は1,上限は6(=n-m+1)になります。
ヘルプでは『添字の下限を変えたいときは，MAT READ文か，拡張機能のMAT REDIM文を用いる。』とあります。
MAT READ C(m TO n) とすればよいわけですが、DATA文を読ませる必要があります。
MAT REDIM C(m TO n) ならば配列要素はそのままで添字の下限を変更できますがJIS規格外です。

次の外部副プログラム redim は、MAT REDIM文と同様の機能を持ちます。

DECLARE EXTERNAL SUB redim
DIM A(100)
LET m=3
LET n=8
CALL redim(A,m,n)  ! MAT REDIM A(m TO n)と同義
PRINT LBOUND(A),UBOUND(A)
END
!
EXTERNAL SUB redim(p(),m,n) !配列の添字の上下限を再定義
WHEN EXCEPTION IN
   DIM q(10000)
   MAT q=p
   MAT READ p(m TO n)
   DATA 0
USE
END WHEN
FOR i=m TO n
   LET p(i)=q(LBOUND(q)+i-m)
NEXT i
END SUB
 		 

MAT REDIMの代替

 投稿者：白石　和夫  投稿日：2009年 1月 8日(木)18時35分32秒 		返信・引用
  > No.239[元記事へ]

EXTERNAL SUB redim(p(),m,n) !配列の添字の上下限を再定義
DATA 0
MAT READ p(m TO m)
MAT p=ZER(m TO n)
END SUB
でいけます。 		 

２重振子メーター付（解析したい方へ）再投稿

 投稿者：SECOND  投稿日：2009年 1月10日(土)02時54分20秒 		返信・引用 　編集済
  !２重振子メーター付（解析したい方へ）再投稿

!２重振り子特有の下降衝撃時に、その急変する過程が、
!演算ピッチの間に入って脱落し、全エネルギーが変動する計算エラーが見られる。
!演算ピッチが小さいと、緩和するが、低速パソコンでは、描画ピッチが伴わない。

!-----
LET g= 9.8 ! m/s^2　重力加速度
LET m1=.188 ! kg　おもり
LET m2=.188 ! kg
LET L1= 5 !　m　吊り棒
LET L2= 5 !　m
LET r1=.75*SQR(m1) !　おもりの描画径
LET r2=.75*SQR(m2)
!
LET dt=0.05 !sec. 演算ピッチ。高速機 ほど、小さく。(0.05は、Pentium3 500MHz)
!
!※0.01くらいが望ましいが、描画ピッチ(画面に表示)が、ついて来れなくなったら戻す。
!　２つのピッチが、ズレていると物理的な速度ではなくなる。
!
!------------ ２重振り子の方程式
! d(dθ1)/dt^2=
! [ g*{sinθ2*cosΔ-μ*sinθ1}-{L2*(θ2/dt)^2+L1*(θ1/dt)^2*cosΔ}*sinΔ]
!　　　　　　　　　　/[ L1*{μ-cosΔ^2}]
! d(dθ2)/dt^2=
! [ g*μ*{sinθ1*cosΔ-sinθ2}+{μ*L1*(θ1/dt)^2+L2*(θ2/dt)^2*cosΔ}*sinΔ]
!　　　　　　　　　　/[ L2*{μ-cosΔ^2}]
!
! g= 重力加速度　μ=(m1+m2)/m2　Δ=θ1-θ2
!
!---------- 式の整理（θ1θ2 共に、重力方向０からの左回り角）
LET μ2=m2/(m1+m2)
LET L21=L2/L1
!
!ss1=-g/L1*sinθ1 -μ2*L21*ω2^2*sinΔ
!ss2=-g/L2*sinθ2 +　　　　ω1^2*sinΔ/L21
!D=1-μ2*COSΔ^2
!d(θ1)/dt=ω1
!d(θ2)/dt=ω2
!d(ω1)/dt=[　　　　　　ss1 - L21*μ2*cosΔ*ss2 ] /D
!d(ω2)/dt=[ -cosΔ/L21*ss1 + 　　　　　　　ss2 ] /D
!
!---------- 微分方程式のまま、ルンゲ・クッタ法で描画。
LET θ1=PI*0.8 ! 初期角度
LET θ2=PI*0.8
LET w1=0 !　初期角速度
LET w2=0
!
DEF ss1(w2,θ1,θ2)=-g/L1*SIN(θ1) -μ2*L21*w2^2*SIN(θ1-θ2)
DEF ss2(w1,θ1,θ2)=-g/L2*SIN(θ2) +        w1^2*SIN(θ1-θ2)/L21
DEF D(θ1,θ2)=1-μ2*COS(θ1-θ2)^2
!
DEF α1(w1,w2,θ1,θ2)=( ss1(w2,θ1,θ2) -L21*μ2*COS(θ1-θ2)*ss2(w1,θ1,θ2) )/D(θ1,θ2)
DEF α2(w1,w2,θ1,θ2)=(-ss1(w2,θ1,θ2)*COS(θ1-θ2)/L21     +ss2(w1,θ1,θ2) )/D(θ1,θ2)

SUB RungeKutta
   LET w11=w1
   LET w12=w2
   LET α11=α1(w1,w2,θ1,θ2)
   LET α12=α2(w1,w2,θ1,θ2)
   !
   LET w21=w1+α11*dt/2
   LET w22=w2+α12*dt/2
   LET α21=α1(w21,w22,θ1+w11*dt/2,θ2+w12*dt/2)
   LET α22=α2(w21,w22,θ1+w11*dt/2,θ2+w12*dt/2)
   !
   LET w31=w1+α21*dt/2
   LET w32=w2+α22*dt/2
   LET α31=α1(w31,w32,θ1+w21*dt/2,θ2+w22*dt/2)
   LET α32=α2(w31,w32,θ1+w21*dt/2,θ2+w22*dt/2)
   !
   LET w41=w1+α31*dt
   LET w42=w2+α32*dt
   LET α41=α1(w41,w42,θ1+w31*dt,θ2+w32*dt)
   LET α42=α2(w41,w42,θ1+w31*dt,θ2+w32*dt)
   !
   LET θ1=θ1+(w11+2*w21+2*w31+w41)*dt/6
   LET θ2=θ2+(w12+2*w22+2*w32+w42)*dt/6
   LET w1=w1+(α11+2*α21+2*α31+α41)*dt/6
   LET w2=w2+(α12+2*α22+2*α32+α42)*dt/6
END SUB

!----エネルギー・メーター
DEF ep1=m1*g*(L1-L1*COS(θ1)) !位置１
DEF em1=(L1*w1)^2*m1/2 !運動１
DEF ep2=m2*g*( (L1-L1*COS(θ1)+L2)-L2*COS(θ2) ) !位置２
DEF em2=( (L1*w1)^2+(L2*w2)^2-2*L1*w1*L2*w2*COS(PI+θ1-θ2) )*m2/2 !運動２
!
!----run
LET w=13
SET WINDOW -w,w,-w,w
SET COLOR MIX(15) .5,.5,.5
SET TEXT background "OPAQUE"
LET t0=TIME
DO
   LET t=TIME
   IF dt=<ABS(t-t0) THEN
      SET DRAW mode hidden
      CLEAR
      DRAW grid(5,5)
      PLOT TEXT,AT -w*0.92,w*0.9:"おもりのエネルギー[J]"
      PLOT TEXT,AT -w*0.92,w*0.83:"位置１　運動１　 位置２　運動２"
      PLOT TEXT,AT -w*0.96,w*0.76,USING"##.#### ##.####　##.#### ##.####":ep1,em1,ep2,em2
      PLOT TEXT,AT -w*0.86,w*0.69,USING"##.####　　　　　##.####":ep1+em1,ep2+em2
      PLOT TEXT,AT -w*0.62,w*0.62,USING"##.####":ep1+em1+ep2+em2
      PLOT TEXT,AT w*0.25,w*0.9:"マウス 右ボタンで、終了。"
      PLOT TEXT,AT w*0.4,w*0.76,USING"演算ピッチ=#.### 秒":dt
      PLOT TEXT,AT w*0.4,w*0.69,USING"描画ピッチ=#.### 秒":t-t0
      LET t0=t
      DRAW Pendulum0 WITH ROTATE(θ1)
      CALL RungeKutta !　次のθ1,θ2 へ更新
      SET DRAW mode explicit
      !stop
   END IF
   WAIT DELAY 0 !　省電力効果
   MOUSE POLL mx,my,mlb,mrb
LOOP UNTIL mrb=1

PICTURE Pendulum0
   DRAW circle WITH SCALE(0.2)
   DRAW Pendulum1(L1,r1,"1")
   DRAW Pendulum1(L2,r2,"2") WITH ROTATE(θ2-θ1)*SHIFT(0,-L1)
END PICTURE

PICTURE Pendulum1(L,r,w$)
   PLOT LINES: 0,0;0,-L
   DRAW disk WITH SCALE(r)*SHIFT(0,-L)
   PLOT TEXT,AT r, r-L:w$
END PICTURE

END 		 

センター試験程度のプログラム演習

 投稿者：山中和義  投稿日：2009年 1月15日(木)10時44分57秒 		返信・引用
  直線上の酔歩問題
　コインを投げて、表が出たら＋１、裏なら−１と数直線上を動く。

●シミュレーションによる解法（モンテカルロ法）
RANDOMIZE

LET N=6 !コインを投げる回数

DIM s(-N TO N) !点xに戻る回数
MAT s=ZER

LET iter=50000 !試行回数
FOR i=1 TO iter

   LET x=0 !原点
   FOR k=1 TO N !コインを投げる
      IF RND<0.5 THEN LET x=x+1 ELSE LET x=x-1 !表なら＋１、裏なら−１
   NEXT k
   LET s(x)=s(x)+1 !結果

NEXT i

FOR i=-N TO N !点xに戻る確率
   PRINT i;s(i)/iter
NEXT i
PRINT

FOR i=-N TO N !場合の数
   PRINT USING "###: ###.##": i,s(i)/s(N) !x=Nを１とする
NEXT i

END


●理論値の算出

コインをｎ回投げて、ｋ回表が出たする。
位置x=1*k+(-1)*(n-k)=2*k-nとなる。確率は、nＣk(1/2)^k*(1-1/2)^(n-k)。

たとえば、n=6で原点の場合、0=2*k-nより、k=3。
LET x=0 !原点

LET k=(x+N)/2 !整数解があれば
IF k=INT(k) THEN
   PRINT k; comb(N,k)*(1/2)^k*(1-1/2)^(N-k)
ELSE
   PRINT "到達しません。"
END IF

END


投げる回数ごとの「場合の数」の一覧表は、パスカルの三角形をつくればよい。
!パスカルの三角形

LET N=10 !コインを投げる回数

LET a=1 !パスカルの三角形
LET b=0
LET c=1

DIM P(-N TO N) !数直線上の各点
MAT P=ZER
LET P(0)=1 !原点に位置付ける

FOR i=-N TO N !目盛り
   PRINT USING " ####": i;
NEXT i
PRINT
FOR i=-N TO N !数直線
   PRINT "----+";
NEXT i
PRINT

FOR i=0 TO N !指定回数

   MAT PRINT USING(REPEAT$(" ####",2*N+1)): P; !現状
   PRINT USING " ### 回の場合": i

   LET T1=0 !左　※左端
   LET T2=P(-N) !中央
   FOR x=-N TO N !左から右へ走査する
      IF x+1>N THEN LET T3=0 ELSE LET T3=P(x+1) !右

      LET P(x)=a*T1+b*T2+c*T3

      LET T1=T2 !次へ
      LET T2=T3
   NEXT x

NEXT i

END
 

comb関数の不具合

 投稿者：山中和義  投稿日：2009年 1月16日(金)10時42分29秒 		返信・引用
  有理数モードで１となる。

PRINT comb(3,6) !3C6
PRINT comb(3,-4)
END 		 

Re: comb関数の不具合

 投稿者：白石　和夫  投稿日：2009年 1月16日(金)18時12分34秒 		返信・引用
  > No.244[元記事へ]

ご報告ありがとうございます。
修正します。

> 有理数モードで１となる。
>
> PRINT comb(3,6) !3C6
> PRINT comb(3,-4)
> END 		 

Re: センター試験程度のプログラム演習

 投稿者：山中和義  投稿日：2009年 1月17日(土)13時27分49秒 		返信・引用 　編集済
  > No.243[元記事へ]

作表と表の計算、数列の生成
・２次元配列を使わず、順次求める

!九九表（乗算表）と〜数

!１の段　−　自然数
!２の段　−　偶数
!各段　−　倍数


LET N=9 !※書式（PRINT USING）の桁を調整すれば変更可能

DIM A(0 TO 2*N) !数列 An
DIM S(0 TO 2*N) !数列 Sn


!●平方数（四角数）　n^2
MAT A=ZER
PRINT

FOR i=1 TO N
   FOR j=1 TO N
      LET t=i*j !乗算

      IF i=j THEN !対角線上なら
         PRINT USING "(####)": t;
         LET A(i)=t
      ELSE
         PRINT USING " #### ": t;
      END IF

   NEXT j
   PRINT
NEXT i
PRINT


!四角錐数（平方数の和）Square Pyramid Numbers
!　Σ[k=1,n]k^2
! =1^2 + 2^2 + 3^2 + … + (n-1)^2 + n^2
! =n*(n+1)*(2*n+1)/6
MAT S=ZER

FOR i=1 TO N
   LET S(i)=S(i-1)+A(i) !和　※A()は上記の平方数
NEXT i
FOR i=1 TO N !〜数を表示する
   PRINT S(i);
NEXT i
PRINT
PRINT


!奇数の和　1 + 3 + 5 + … + (2*n-3) + (2*n-1)
!　Σ[k=1,n](2*k-1)
! =n^2
MAT S=ZER

FOR i=1 TO N
   LET S(i)=A(i)-A(i-1) !階差　※A()は上記の平方数
NEXT i
FOR i=1 TO N !〜数を表示する
   PRINT S(i);
NEXT i
PRINT
PRINT



!●四面体数（三角数の和、三角錐数 tetrahedral number）
!　Σ[k=1,n]k*(n-k+1)
! =1*n+2*(n-1)+3*(n-2)+ … +(n-1)*2+n*1
! =n*(n+1)*(n+2)/6
MAT A=ZER
PRINT

FOR i=1 TO N
   FOR j=1 TO N
      LET t=i*j !乗算

      LET A(i+j-1)=A(i+j-1)+t !右斜め（／）に加算する
      PRINT USING "####": t;

   NEXT j
   PRINT
   IF i<N THEN PRINT "　";REPEAT$("　／",N-1) !行間
NEXT i
PRINT

FOR i=1 TO N !〜数を表示する
   PRINT A(i);
NEXT i
PRINT
PRINT



!●立方数　n^3
MAT A=ZER
PRINT

FOR i=1 TO N
   FOR j=1 TO N
      LET t=i*j !乗算

      IF i<j THEN !Ｌ字に加算する
         LET A(j)=A(j)+t
         PRINT USING "│####": t;
      ELSE
         LET A(i)=A(i)+t
         PRINT USING "　####": t;
      END IF

   NEXT j
   PRINT "│" !行末
   PRINT REPEAT$("───",i);"┘";REPEAT$("　　│",N-i) !行間
NEXT i
PRINT

FOR i=1 TO N !〜数を表示する
   PRINT A(i);
NEXT i
PRINT
PRINT



!立方数の和
!　Σ[k=1,n]k^3=(n*(n+1)/2)^2の導出
!　1*Σ[k=1,n]k + 2*Σ[k=1,n]k + 3*Σ[k=1,n]k + … + (n-1)*Σ[k=1,n]k + n*Σ[k=1,n]k
! =(1+2+ … +(n-1)+n)*Σ[k=1,n]k
! =(Σ[k=1,n]k)^2
PRINT

FOR i=1 TO N
   FOR j=1 TO N
      LET t=i*j !乗算
      PRINT USING " ####": t;
   NEXT j
   PRINT "　←１段目の";i;"倍"
NEXT i
PRINT

MAT S=ZER
FOR i=1 TO N
   LET S(i)=S(i-1)+A(i) !※A()は上記の立方数
NEXT i
FOR i=1 TO N !〜数を表示する
   PRINT S(i);
NEXT i
PRINT
PRINT


END
 

一個の神経細胞(neuro)

 投稿者：SECOND  投稿日：2009年 1月18日(日)10時37分30秒 		返信・引用 　編集済
  !
! 一個の神経細胞(neuro)
! その カオス(chaos)を、探し、見る、ツール
!
!----------------------------
!　"Neuro12"
!
!　2009.1.18
!----------------------------
OPTION ARITHMETIC NATIVE
OPTION BASE 0
SET TEXT background "OPAQUE"
SET POINT STYLE 1
SET AREA COLOR 0
LET DLY=50
DIM St(1,DLY) ,Sy(2000), B4(0,500)
!
LET Kr=0.5
LET Af=1
LET Ei=-70
LET Ss=0.31 !　Ss=(Kr-1)(theta-s(t))　…s(t)=0
LET theta=Ss/(Kr-1)

DEF Ri(Yi,Ss)=Kr*Yi-Af/(1+EXP(Ei*Yi))+Ss

PLOT TEXT,AT .04,.96:"*** Neuro Cell"
PLOT TEXT,AT .04,.92:"Right Click to Stop"
PLOT TEXT,AT .04,.89:"Left  Click & Drag '|' Line"
!
!-----
LET Y0=Af/100
LET Af2=Af
DO
   LET Af=Af2
   CALL ma200_
   ! ma100_
   !----- clear
   SET WINDOW -Af*2.07-Af*1.06,Af*2.07-Af*1.06,-Af*2.07-Af*1.05,Af*2.07-Af*1.05
   PLOT AREA: -Af,-Af;Af,-Af;Af,Af;-Af,Af
   !----- box outline
   SET LINE COLOR "blue"
   PLOT LINES: -Af,-Af; Af,-Af; Af,Af; -Af,Af; -Af,-Af
   !-----
   PLOT TEXT,AT Af*.03,Af*.85: "+Af Y(t+1)"
   PLOT TEXT,AT -Af*.97,Af*0.13: "Y(t)"
   PLOT TEXT,AT -Af*.97, 0: "-Af"
   PLOT TEXT,AT Af*.8, 0: "+Af"
   PLOT TEXT,AT Af*.03,-Af*.98: "-Af"
   !----- Sy(w)=Y(t)
   LET imax=pixelx(Af)-pixelx(-Af)
   LET dA1=(Af+Af)/imax
   FOR i=0 TO imax
      LET Sy(i)=Ri(-Af+i*dA1, Ss)
   NEXT i
   !-----
   DO
      LET Y1=Ri(Y0,Ss)
      !----- erase old signal
      LET W0=St(0,t)
      LET W1=St(1,t)
      FOR i=0 TO DLY-1
         IF W0=St(0,i) AND W1=St(1,i) AND t<>i THEN EXIT FOR
      NEXT i
      IF DLY=i THEN
         SET LINE COLOR 0
         PLOT LINES: W0,W0; W0,W1;
         PLOT LINES: W1,W1
      END IF
      !----- axis
      SET LINE COLOR "cyan" ! axis_Y(t)… ―
      PLOT LINES: -Af,0; Af,0
      SET LINE COLOR "magenta" ! axis_Y(t+1)…｜
      PLOT LINES: 0,-Af; 0,Af
      !----- draw curve Y(t)
      SET LINE COLOR 1
      FOR i=0 TO imax
         PLOT LINES: -Af+i*dA1, Sy(i);
      NEXT i
      PLOT LINES
      !----- signal
      SET LINE COLOR "cyan" ! input_Y(t)…｜
      PLOT LINES: Y0,Y0; Y0,Y1;
      SET LINE COLOR "magenta" ! output_Y(t+1)… ―
      PLOT LINES: Y1,Y1
      !-----
      LET St(0,t)=Y0
      LET St(1,t)=Y1
      LET t=MOD(t+1,DLY)
      LET Y0=Y1
      !-----
      WAIT DELAY .02
      MOUSE POLL x,y,mlb,mrb
   LOOP UNTIL mlb=1 OR mrb=1
   !
   !----- cursor input
   IF mlb=1 THEN
      SET WINDOW -0.1*Af,Af, -Af*2.1+Af*1.08,Af*2.1+Af*1.08
      DO
         MOUSE POLL x,y,mlb,mrb
         IF 0<=x AND x<=Af THEN
            IF y< Af THEN
               IF bx4<>pixelx(x) THEN
                  LET Ss=x
                  LET theta=Ss/(Kr-1)
                  CALL cursor4( bx4,B4)
               END IF
            ELSEIF x< Af*.43 THEN
               IF y< Af*1.4 THEN
               ELSEIF y< Af*1.7 THEN
                  IF bx3<>pixelx(x) THEN
                     LET Ei=x*120/(Af*.43)-120
                     CALL cursor13( bx3, 1.7, 1.4)
                  END IF
               ELSEIF y< Af*2.1 THEN
                  IF bx2<>pixelx(x) THEN
                     LET Kr=x*1/(Af*.43)
                     LET theta=Ss/(Kr-1)
                     CALL cursor13( bx2, 2.1, 1.8)
                  END IF
               ELSEIF y< Af*2.5 THEN
                  IF bx1<>pixelx(x) THEN
                     LET Af2=x*2/(Af*.43)+0.5
                     MAT St=ZER
                     LET Y0=Af/100
                     CALL cursor13( bx1, 2.5, 2.2)
                  END IF
               END IF
            END IF
         END IF
         WAIT DELAY .05
      LOOP UNTIL mlb=0
   END IF
LOOP UNTIL mrb=1

SUB cursor4( bx,B(,))
   MAT PLOT CELLS, IN worldx(bx),Af; worldx(bx),-Af: B
   LET bx=pixelx(x)
   ASK PIXEL ARRAY (x,Af) B
   SET LINE COLOR "red"
   PLOT LINES: x,-Af; x,Af
   PLOT TEXT,AT 0,Af,USING "Kr=#.### :Af=#.### :Ei=####.# :Ss=#.### :theta=####.###": Kr, Af, Ei, Ss, theta
END SUB

SUB cursor13( bx, uy,ly)
   SET LINE COLOR 0
   PLOT LINES: worldx(bx),Af*uy-dAy; worldx(bx),Af*ly+dAy
   LET bx=pixelx(x)
   SET LINE COLOR "red"
   PLOT LINES: x,Af*uy-dAy; x,Af*ly+dAy
   PLOT TEXT,AT 0,Af,USING "Kr=#.### :Af=#.### :Ei=####.# :Ss=#.### :theta=####.###": Kr, Af2, Ei, Ss, theta
END SUB

SUB ma200_
!----- clear
   SET WINDOW -0.1*Af,Af, -Af*2.1+Af*1.08,Af*2.1+Af*1.08
   PLOT AREA: 0,-Af;Af,-Af;Af,Af;0,Af
   !----- box outline
   SET LINE COLOR "blue"
   PLOT LINES: 0,-Af; Af,-Af; Af,Af; 0,Af; 0,-Af
   PLOT LINES: 0,0; Af,0
   !-----
   PLOT TEXT,AT -.06*Af,.9*Af : "+Af"
   PLOT TEXT,AT -.07*Af,-.05*Af : "Y(t)"
   PLOT TEXT,AT -.06*Af,-Af : "-Af"
   PLOT TEXT,AT Af*.5,-Af*.98: "0 <--- Ss ---> +Af"
   !-----
   LET dA2=Af/(pixelx(Af)-pixelx(0))
   LET dAy=Af/(pixely(Af)-pixely(0))
   LET Yt=0 ! Y(t)
   FOR j=0 TO Af STEP dA2 ! j= Ss= (Kr-1)*theta
      FOR i=0 TO 99
         LET Yt=Ri(Yt,j)
         PLOT POINTS: j,Yt
      NEXT i
   NEXT j
   !----- setup cursor Ss
   LET x=Ss
   ASK PIXEL SIZE (x,Af;x,-Af) i,j
   MAT B4=ZER(0,j-1)
   ASK PIXEL ARRAY (x,Af) B4
   LET bx4=pixelx(x)
   CALL cursor4( bx4, B4)
   !-----
   LET x=(Ei+120)*Af*.43/120 !// Ei=x*120/(Af*.43)-120
   LET bx3=pixelx(x)
   CALL cursor130( bx3, 1.7, 1.4, "Ei")
   LET x=Kr*Af*.43 !// Kr=x*1/(Af*.43)
   LET bx2=pixelx(x)
   CALL cursor130( bx2, 2.1, 1.8, "Kr")
   LET x=(Af-0.5)*Af*.43/2 !// Af2=x*2/(Af*.43)+0.5
   LET bx1=pixelx(x)
   CALL cursor130( bx1, 2.5, 2.2, "Af")
END SUB

SUB cursor130( bx, uy, ly, w$)
   PLOT TEXT,AT -.06*Af,Af*(uy-0.2): w$
   SET LINE COLOR "blue"
   PLOT LINES: 0,Af*uy; Af*.43,Af*uy; Af*.43,Af*ly; 0,Af*ly; 0,Af*uy
   CALL cursor13( bx, uy, ly)
END SUB

END
 		 

漂流するニューラル・ネット

 投稿者：SECOND  投稿日：2009年 1月18日(日)11時12分0秒 		返信・引用 　編集済
  !
!　漂流するニューラル・ネット（更新）再投稿
!
!----
OPTION ARITHMETIC NATIVE
OPTION BASE 0
SET WINDOW -10,10, 20,0
SET TEXT background "OPAQUE"
!
DIM E(99),R(99),theta(99),F(99)
DIM Y(99),X(99),NetWork(99,99)
DIM P_(1 TO 5, 99),Px(99)
DIM Sum(1 TO 5)
MAT READ P_
! 1)
DATA 1,1,0,0,0,0,0,0,1,1
DATA 1,1,1,0,0,0,0,1,1,1
DATA 0,1,1,1,0,0,1,1,1,0
DATA 0,0,1,1,1,1,1,1,0,0
DATA 0,0,0,1,1,1,0,0,0,0
DATA 0,0,0,0,1,1,1,0,0,0
DATA 0,0,1,1,1,1,1,1,0,0
DATA 0,1,1,1,0,0,1,1,1,0
DATA 1,1,1,0,0,0,0,1,1,1
DATA 1,1,0,0,0,0,0,0,1,1
! 2)
DATA 0,0,0,0,0,1,0,0,0,0
DATA 0,0,0,0,1,1,1,0,0,0
DATA 0,0,0,0,1,1,1,0,0,0
DATA 0,0,0,1,1,1,1,1,0,0
DATA 0,0,0,1,1,0,1,1,0,0
DATA 0,0,1,1,1,0,1,1,1,0
DATA 0,0,1,1,0,0,0,1,1,0
DATA 0,1,1,1,0,0,0,1,1,1
DATA 0,1,1,1,1,1,1,1,1,1
DATA 0,1,1,1,1,1,1,1,1,1
! 3)
DATA 0,0,1,1,1,0,0,0,1,1
DATA 0,1,1,1,1,1,1,1,1,1
DATA 1,1,1,0,1,1,1,1,0,0
DATA 1,1,0,0,0,1,1,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,1,1,0,0,0,1,1
DATA 0,0,1,1,1,1,0,1,1,1
DATA 1,1,1,1,1,1,1,1,1,0
DATA 1,1,0,0,0,1,1,1,0,0
DATA 0,0,0,0,0,0,0,0,0,0
! 4)
DATA 0,0,1,0,0,0,0,1,0,0
DATA 0,0,1,1,0,0,1,1,0,0
DATA 0,0,1,1,1,1,1,1,0,0
DATA 0,0,1,1,1,1,1,1,0,0
DATA 0,0,1,1,1,1,1,1,0,0
DATA 0,1,1,1,1,1,1,1,1,0
DATA 1,1,1,1,1,1,1,1,1,1
DATA 0,0,0,1,1,1,1,0,0,0
DATA 0,0,0,0,1,1,1,0,0,0
DATA 0,0,0,0,0,1,0,0,0,0
! 5)
DATA 0,0,0,0,1,1,0,0,0,0
DATA 0,1,1,0,1,1,0,1,1,0
DATA 0,1,0,0,1,1,0,0,1,0
DATA 0,0,0,0,1,1,0,0,0,0
DATA 1,1,1,1,1,1,1,1,1,1
DATA 1,1,1,1,1,1,1,1,1,1
DATA 0,0,0,0,1,1,0,0,0,0
DATA 0,1,1,0,1,1,0,1,1,0
DATA 0,1,1,0,1,1,0,1,1,0
DATA 0,0,0,0,1,1,0,0,0,0

!----- 初期値サンプル１（感で探すのは無理かも。）
! MAT theta=(-1.27)*CON
! LET Af=1.6
! LET Kr=0.92
! LET Kf=0.4
! LET Ei=-10
!
!----- 初期値サンプル２
MAT theta=ZER !　ニューロン不応の固定成分 (しきい値)
LET Af=1 !　ニューロン自身の感度を不応にする負性の自己帰還結合係数 と、
LET Kr=0.95 !　その減衰定数(0< ,< 1)
LET Kf=0.4 !　ニューロンが、他のニューロンから受ける相互結合の減衰定数(0< ,< 1)
LET Ei=-100 !　２値化関数、S字形 sigmoid() の入力係数
!
!----- 引き金となる相互結合の刺激の作成（無信号からの励起はできない。）
RANDOMIZE !15 !6
DO
   LET j=0
   FOR i=0 TO 99
      LET F(i)=RND-0.5
      LET j=j+F(i)
   NEXT i
LOOP UNTIL ABS(j)< .002
!
!----- 環境の準備
SET LINE COLOR 2
FOR n_=1 TO 5
   LET w=0
   !----- サンプル・パターンの表示
   FOR j=0 TO 9
      FOR i=0 TO 9
         IF P_(n_,j*10+i)>0 THEN
            DRAW circle WITH SCALE(0.03)*SHIFT(i*.08-9, j*.08+n_+.9)
            LET w=w+1
         END IF
      NEXT i
   NEXT j
   PLOT TEXT,AT -6,n_+1.5:"Dots/Body="&STR$(w)&"/100"
   PLOT TEXT,AT -8,n_+1.5:":"&STR$(Sum(n_))
   LET DC=w/100 ! 平均値（直流成分）
   !-----
   !　５つのパターンの平均値からの偏差（交流成分）を、
   !　１つの行列 NetWork(,) の中に、埋め込む。相互結合係数の行列 作成。
   !
   !　　　　　　　　　 　   5　(p) ＿　 (p) ＿
   !　共分散行列の作成 ωij=Σ(χi-χ)*(χj-χ)　　…参照。
   !　　　　　　　　　　　　p=1
   !-----
   FOR i=0 TO 99
      FOR j=0 TO 99
         LET NetWork(i,j)=NetWork(i,j)+(P_(n_,i)-DC)*(P_(n_,j)-DC)
      NEXT j
   NEXT i
NEXT n_
!-----
!　５つが、自己の共分散の形で合算され、１つなった行列 NetWork(,) で、
!　１００個のニューロンを接続し、漂流させると・・・
!
!　（ 周期の無い計算ですが、演算桁の制限による丸めのために、周期的
!　　　動作へ落ちています・・長々と、漂着しないときは、Run しなおす。）
!
!-----
PLOT TEXT,AT -9, 1:"漂流するニューラル・ネット"
PLOT TEXT,AT -9, 9:"右クリックで 終了"
PLOT TEXT,AT -9,10:"左クリック STOP/START"
SET LINE COLOR 1
DO
   DO
      LET T=T+1
      PLOT TEXT,AT -9,8:"t="&STR$(T)
      CALL DispX
      CALL Compare
      CALL Xi00
      MOUSE POLL mx,my,mlb,mrb
      WAIT DELAY 0
   LOOP UNTIL mlb=1 OR mrb=1
   !----- left click stop/start
   IF mlb=1 THEN
      DO
         WAIT DELAY 0.02
         MOUSE POLL mx,my,mlb,mrb
      LOOP UNTIL mlb=0
      DO
         WAIT DELAY 0.02
         MOUSE POLL mx,my,mlb,mrb
      LOOP UNTIL mlb=1 OR mrb=1
      WAIT DELAY 0.1
   END IF
   !----- right click stop end.
LOOP UNTIL mrb=1

!----- 各ニューロン0~99 の駆動
SUB Xi00
   FOR i=0 TO 99
      LET w=0
      FOR j=0 TO 99
         LET w=w+NetWork(i,j)*X(j)
      NEXT j
      LET F(i)=Kf*F(i)+w
      LET R(i)=Kr*(R(i)+theta(i))-Af*X(i)-theta(i)
      LET Y(i)=R(i)+F(i)
   NEXT i
   FOR i=0 TO 99
      IF Ei*Y(i)< 709 THEN !　桁あふれ防止
         LET X(i)=1/(1+EXP(Ei*Y(i)))
      ELSE
         LET X(i)=1/(1+EXP(709))
      END IF
   NEXT i
END SUB

!----- 各ニューロンの出力 X(0~99) 発火の、画面表示。
SUB DispX
   SET DRAW mode hidden
   SET AREA COLOR 0
   PLOT AREA:-10,10; 0,10; 0,0; 10,0; 10,20;-10,20
   SET AREA COLOR 2 !　//fire
   FOR V=0 TO 9
      FOR H=0 TO 9
         LET i=V*10+H
         IF 0.5=< X(i) THEN
            PLOT AREA: H,V; H+1,V; H+1,V+1; H,V+1
            LET Px(i)=1
            SET COLOR MIX(0) 0,1,1 ! B.G.color cyan( text)
         ELSE
            PLOT LINES: H,V; H,V+1; H+1,V+1
            LET Px(i)=0
            SET COLOR MIX(0) 1,1,1 ! B.G.color 0
         END IF
         !----- ニューロンの内部(-~0~+) 0=< は発火
         PLOT TEXT,AT H*2-10, V*0.8+12, USING"###.###":Y(i)
      NEXT H
   NEXT V
   SET COLOR MIX(0) 1,1,1 ! B.G.color 0
   SET DRAW mode explicit
END SUB

!----- 生成パターンの分別 計数の、画面表示。
SUB Compare
   FOR n_=1 TO 5
      FOR i=0 TO 99
         IF P_(n_,i)<>Px(i) THEN EXIT FOR
      NEXT i
      IF 99< i THEN
      !　----- 一致
         LET PC_=10 !　//timer ON 1st.to 2nd.Cursor
         IF PB_=n_ THEN EXIT SUB
         IF PN_>0 THEN PLOT TEXT,AT -8, PN_+1.5: ":"& STR$(Sum(PN_))& " " !　//old 1st.2nd.Cursor OFF
         LET PB_=n_ !　//flag 2nd.Cursor
         LET PN_=n_ !　//flag 1st.Cursor
         LET Sum(n_)=Sum(n_)+1 !　計数
         SET COLOR MIX(0) 0,1,1 !　//new 1st.Cursor ON (B.G.color)
         PLOT label,AT -8, n_+1.5: ":"& STR$(Sum(n_))& " "
         SET COLOR MIX(0) 1,1,1
         beep
         EXIT SUB
         !-----
      END IF
   NEXT n_
   !　----- 不一致
   IF PB_=0 THEN EXIT SUB
   IF PC_>1 THEN
      LET PC_=PC_-1
      EXIT SUB
   END IF
   SET COLOR MIX(0) .75,.75,.75 !　//new 2nd.Cursor ON (B.G.color)
   PLOT TEXT,AT -8, PB_+1.5: ":"& STR$(Sum(PB_))& " "
   SET COLOR MIX(0) 1,1,1
   LET PB_=0
END SUB

END 		 

今年のセンター試験BASIC

 投稿者：山中和義  投稿日：2009年 1月20日(火)10時36分8秒 		返信・引用
  ●問題とプログラム

p,qは異なる自然数とする。
与えられた自然数kについて、d以下の自然数kのうちで
　k=m*p+n*q、m,nは０以上の整数
で表すことができるものを小さい順に列挙する。

例. p=3,q=7,d=15のとき、 3  6  7  9  10  12  13  14  15   総数= 9
例. p=3,q=7,d=100のとき、総数= 94。


100 INPUT PROMPT "p=": P
110 INPUT PROMPT "q=": Q
120 INPUT PROMPT "d=": D
130 LET U=0
140 FOR K=1 TO D !d以下の自然数kのうちで
150    IF K-INT(K/P)*P=0 THEN GOTO 210 !kがpの倍数の場合（k=m*p+0）　※MOD(K,P)=0
160    FOR M=0 TO INT(K/P) !０からPで割った商まで　∵k=m*p+r
170       LET R=K-M*P !k-m*p=n*q
180       IF R-INT(R/Q)*Q=0 THEN GOTO 210 !rがqの倍数の場合　※MOD(R,Q)=0
190    NEXT M
200    GOTO 230 !該当なし。次へ
210    PRINT K !条件を満たす
220    LET U=U+1
230 NEXT K
240 PRINT "総数="; U
250 END



●P=3,Q=7,D=100での総数を求める問題の解法について
　トレースするには手順が多すぎる。世界のナベアツではないが、ほとんどアホになってしまう。

そこで、・・・

・拡張ユークリッドの互除法　m*3+n*7=gcd(3,7)=1=k　より
　整数組(m,n)で、kの倍数を表すことができる。（一意ではない）

これより
　問題文にヒントがある。
　1〜3*7=21までの整数が表現できるか確認する。　1,2,4,5,8,11が無理。


・「３の倍数と７の倍数との和」の線形性は、「左斜め」になる。（7=2*3+1ずつずれる）

　縦：３の倍数、横：７の倍数
   0   7  14  21  28  35  42  49  56  63  70  77  84
   3  10  17  24  31  38  45  52  59  66  73  80  87
   6  13  20  27  34  41  48  55  62  69  76  83  90
   9  16  23  30  37  44  51  58  65  72  79  86  93
  12  19  26  33  40  47  54  61  68  75  82  89  96
  15  22  29  36  43  50  57  64  71  78  85  92  99
  18  25  32  39  46  53  60  67  74  81  88  95 102
  21  28  35  42  49  56  63  70  77  84  91  98 105
  24  31  38  45  52  59  66  73  80  87  94 101 108
  27  34  41  48  55  62  69  76  83  90  97 104 111
  30  37  44  51  58  65  72  79  86  93 100 107 114
  33  40  47  54  61  68  75  82  89  96 103 110 117
  36  43  50  57  64  71  78  85  92  99 106 113 120
  39  46  53  60  67  74  81  88  95 102 109 116 123
  42  49  56  63  70  77  84  91  98 105 112 119 126
  45  52  59  66  73  80  87  94 101 108 115 122 129

これより
　一目瞭然！？


・・・と考えてみた。 		 

Re: 今年のセンター試験BASIC

 投稿者：山中和義  投稿日：2009年 1月21日(水)11時08分47秒 		返信・引用
  > No.249[元記事へ]

●210行目で、条件を満たすMとNを表示するように改良してみた。

・150行目を削除
・210行目にM,Nの計算を追加

100 INPUT PROMPT "p=": P
110 INPUT PROMPT "q=": Q
120 INPUT PROMPT "d=": D
130 LET U=0
140 FOR K=1 TO D !d以下の自然数kのうちで
150    !
160    FOR M=0 TO INT(K/P) !０からKをPで割った商まで
170       LET R=K-M*P !k-m*p=n*q
180       IF R-INT(R/Q)*Q=0 THEN GOTO 210 !rがqの倍数の場合　※MOD(R,Q)=0
190    NEXT M
200    GOTO 230 !該当なし。次へ
210    PRINT K; M;INT(R/Q) !条件を満たすM,N　※
220    LET U=U+1
230 NEXT K
240 PRINT "総数="; U
250 END


＊アルゴリズムの数学的背景
不定方程式 k=m*p+n*q は、k-m*p=n*q と変形される。
合同式で表すと、k-m*p≡0 mod q となる。

m は０以上の整数、p は自然数より、m*p≧0 となる。　同様に、n*q≧0。
また、n*q=k-m*p≧0 より、k≧m*p となる。
したがって解があれば、mは0〜INT(K/P)で見つかる。



●(m,n)の組は一通りでない。その組を調べる。

・180行目を変更と追加（210,220行目）
・150,200,210,220行目を削除

100 INPUT PROMPT "p=": P
110 INPUT PROMPT "q=": Q
120 INPUT PROMPT "d=": D
130 LET U=0
140 FOR K=1 TO D !d以下の自然数kのうちで
150    !
160    FOR M=0 TO INT(K/P) !０からKをPで割った商まで
170       LET R=K-M*P !k-m*p=n*q
180       IF R-INT(R/Q)*Q=0 THEN !rがqの倍数の場合　※MOD(R,Q)=0
             PRINT K; M;INT(R/Q) !条件を満たすM,N
             LET U=U+1
          END IF
190    NEXT M
200    !
210    !
220    !
230 NEXT K
240 PRINT "総数="; U !※意味が変わる
250 END
 

let文の変数名並び

 投稿者：荒田浩二  投稿日：2009年 1月25日(日)00時25分45秒 		返信・引用
  JISによると、let文には次のような構文があります。みなさんご存じでしたか。

10 DIM M(8)
20 LET a,b,c=5
30 PRINT a;b;c
40 LET a,b,c,M(b)=b+2
50 PRINT a;b;c
60 MAT PRINT M;
70 LET m$,n$="xyz"
80 PRINT m$,n$
90 END 		 

格納できる　マトリックス

 投稿者：与坂　　昇平  投稿日：2009年 1月26日(月)10時22分43秒 		返信・引用
  今日は
full  basic  で　　有限要素法の　構造解析ソフトを　　開発しています
C++　でも　していますが
full  basic  は　　グラヒックが　　簡単で　　ｃ++　より　　便利です
しかし
時間が　　かかります

解析可能要素数は
３GRAM　　で

full  basic  ６０００　要素
C++　　　　　１２０００　要素です


構造解析では　　要素数　　６０００要素では
不足です
解析可能要素数　　つまり
格納可能マトリツクス数を　　増やすには
どうすればいいでしょうか　？？？

また
full  basic  は
６４bit　に　　対応　　していますか

是非
教えて下さい

よろしく 		 

Re: 格納できる　マトリックス

 投稿者：白石　和夫  投稿日：2009年 1月26日(月)17時40分30秒 		返信・引用 　編集済
  > No.252[元記事へ]

Full BASIC規格には，整数型の概念がありません。
規格の範囲では，32ビットの変数も64ビットの変数も使えません。
また，Full BASICには，配列の大きさに関する規定がありません。
規格上は，
DECLARE NUMERIC m(0 TO 10000000)
のような巨大な配列の宣言も許されます。
(仮称)十進BASICはメモリの使用効率がよくないので，
True BASICを試してみるとよいかも知れません。

(仮称)十進BASICの現在のバージョンのなかで最適化を図りたいのであれば，
ヘルプの言語使用の詳細の最後のページ「制限」に書いてある

★ 変数用管理用仮想メモリー
通常，変数管理用に割り当てる仮想メモリーは，実装物理メモリ容量から16Mバイトを減じた値（ただし，最小1Mバイト,最大512Mバイト）を上限とする。
なお，BASIC.INIにキーを追加することで直接指定することができる。

を参照して，BASIC.INIを書き換えてみてください。
なお，Win32アプリケーションのアドレス空間は2GBで，その一部に変数管理用メモリを割り当てるので，2048Mバイト以上を指定することはできませんし，2048MBより小さくても2048MBに近い数値を指定するとBASIC本体が正常に動作しません。
なお，2進モードの場合，配列は変数管理管理用メモリをほとんど消費しないので，変数管理用メモリの割り当てを減らすほうが効果的な可能性があります。

（注）BASIC.INIを使いたいときは，アーカイブ版をダウンロードし展開したものを使ってください。
（レジストリを使用する場合はレジストリの当該項目を修正することになります）

（参照）旧掲示板過去ログ
http://www.geocities.jp/thinking_math_education/log/22/koctpp/index.html 		 

すみません編集させていただきました（測量最小二乗法について）

 投稿者：kikiriri  投稿日：2009年 1月29日(木)18時12分33秒 		返信・引用 　編集済
  測量網平均　最小二乗法について、
情報待つ、 		 

Re: 測量最小二乗法について

 投稿者：山中和義  投稿日：2009年 1月30日(金)15時06分48秒 		返信・引用
  > No.254[元記事へ]

kikiririさんへのお返事です。

参考サイト　http://hw001.gate01.com/kazuok/geodetic/leveling.html

Full BASICの場合、行列が計算できるので、他の言語よりは簡単に計算できると思います。
ただ、２項演算までですから、展開しながらこつこつ計算する必要があります。

また、表計算の方がGUIを含めて実用化し易いかもしれません。


上記サイトの例題（PDFファイル内）のサンプルコーディング
!最小２乗法による測量網平均（条件方程式法）

!Ｈ型
!　 Ａ　　Ｃ
!　1↓ 5　↓3
! 　Ｐ → Ｑ
!　2↑　　↑4
! 　Ｂ　　Ｄ

!既知点
LET C=4 !数

DATA 25.645 !Ａ点の標高（m）
DATA 24.666 !Ｂ点
DATA 25.024 !Ｃ点
DATA 25.699 !Ｄ点
DIM Z(C)
MAT READ Z

!観測値
LET P=5 !数

DATA -6.225, 0.44 !路線１　高低差（m）、路線長（km）
DATA -5.245, 0.25 !路線２
DATA  0.278, 0.33 !路線３
DATA -0.399, 0.26 !路線４
DATA  5.879, 0.44 !路線５

DIM X(P),G(P,P) !観測値、コアファクタ
MAT G=ZER
FOR i=1 TO P
   READ X(i),G(i,i)
NEXT i
MAT PRINT X;
MAT PRINT G;


!未知数
LET Px=2 !求点ＰとＱ


!------------------------------

!自由度R　※条件方程式の数
LET R=P-Px


!条件方程式 UV=t
DIM U(R,P)
DATA 1,-1,0,0,0 !点Ｐについて HA+h1~=HB+h2~ より、(h1+v1)-(h2+v2)=HB-HA　∴v1-v2=-(h1+HA)+(h2+HB)
DATA 0,0,1,-1,0 !点Ｑについて HC+h3~=HD+h4~
DATA 1,0,0,-1,1 !点Ｐと点Ｑについて HA+h1~+h5~=HD+h4~
MAT READ U

DIM t(R,1)
FOR i=1 TO R
   LET s=0
   FOR j=1 TO P
      IF j>C THEN LET Zj=0 ELSE LET Zj=Z(j)
      LET s=s-(X(j)+Zj)*U(i,j)
   NEXT j
   LET t(i,1)=s
NEXT i
!!!LET t(1,1)=-X(1)+X(2)-Z(1)+Z(2) !0.001
!!!LET t(2,1)=-X(3)+X(4)-Z(3)+Z(4) !-0.002
!!!LET t(3,1)=-X(1)+X(4)-X(5)-Z(1)+Z(4) !0.001
MAT PRINT t;


!------------------------------

!相関式 NK=t、N=UG(Ut)より、K=(Ni)tを求める
DIM Ut(P,R)
MAT Ut=TRN(U)
DIM TMP(P,R) !G(Ut)　※次でも使う
MAT TMP=G*Ut
DIM N(R,R)
MAT N=U*TMP
MAT PRINT N;

DIM invN(R,R)
MAT invN=INV(N)
DIM K(R,1)
MAT K=invN*t

MAT PRINT K;


!補正値の計算（mm） V=G(Ut)K
DIM V(P,1)
MAT V=TMP*K

MAT PRINT V;


!最確値 X~=X+V
FOR i=1 TO P
   PRINT "路線";STR$(i);"=";X(i)+V(i,1)
NEXT i
PRINT "点Ｐ";Z(1)+(X(1)+V(1,1)); Z(2)+(X(2)+V(2,1)) !有効桁数 ##.###
PRINT "点Ｑ";Z(3)+(X(3)+V(3,1)); Z(4)+(X(4)+V(4,1))




!精度の計算（mm^2） σ^2=(Kt)NK/r
DIM s2(1,1),Kt(1,R)
MAT Kt=TRN(K)
MAT s2=Kt*t !NK=t
LET sigma2=s2(1,1)/R

PRINT "σ^2=";sigma2


!分散行列（mm^2） σ^2*Gx、Gx=G-G(Ut)(Ni)UG
DIM Gx(P,P)
MAT Gx=TMP*invN !G(Ut)(Ni)
MAT Gx=Gx*U
MAT Gx=Gx*G
MAT Gx=G-Gx
MAT Gx=sigma2*Gx

MAT PRINT Gx;


END
 

すみません編集させていただきました

 投稿者：kikiriri  投稿日：2009年 1月30日(金)19時56分54秒 		返信・引用 　編集済
  測量最小二乗法について、
早速のご返答
ありがとうございました。 		 

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

 投稿者：山中和義  投稿日：2009年 1月30日(金)20時27分56秒 		返信・引用
  > No.256[元記事へ]

kikiririさんへのお返事です。

> 用語について、説明お願いできないでしょうか。

測量用語の基礎知識　http://www.1roba.com/


また、参考文献
　最小二乗法と測量網平均の基礎　田島稔(著)、小牧和雄(著)　　東洋書店 (2001/03)
などがあります。 		 

ありがとうございました

 投稿者：kikiriri  投稿日：2009年 1月31日(土)11時09分30秒 		返信・引用
  早速のご返答ありがとうございました。
参考にしたいと思います。
最小二乗法と測量網平均の基礎　田島稔(著)、小牧和雄(著)　　東洋書店 (2001/03)
持っているんですが、正直読めないです。
測量の基礎から分かってないと思います。
正直どこから、どの程度？勉強すればいいのかが分かりません。
コロナ社　測量（１）　測量（２）
実教出版　測量演習ノート
など、
持っています。
”参考になるものがあれば紹介してください。”
”ひとつの目標というか、それが平均網のプログラミング化で。”
僕には参考にされていたページを見つけることさえできませんでしたので。
こうしてご助言求めている次第です。
よろしくお願いします。 		 

編集させていただきました

 投稿者：kikiriri  投稿日：2009年 2月 1日(日)13時30分16秒 		返信・引用 　編集済
  長らく情報などの返答得られずこのような形で編集させていただきました。

気にしてくださった方々、誠にありがとうございました

ありがとうございました。 		 

節点解析法について

 投稿者：大熊　正  投稿日：2009年 2月 1日(日)14時39分35秒 		返信・引用
  増幅器を含む、交流回路の解析

1.　ＣＲ回路2段の低域フィルターで単純な増幅器を含まないものは、
　　節点方程式を立てて解けることが分りました。
　　入力　E1 から最初の抵抗　R1,次がR2,その次が最終端子にアース
　　に対しC2ガ在り、 このC2の出力が増幅器でＫ倍される。
    この増幅器の出力は、C1を介して　R1とR2の節点に結ばれる。
　　C1=2*C2　の時、K=1前後で最適である。
　　即ち、典型的なアクテブ　2段フィルターの問題で質問いたします。

　　C1 の電圧をE2 C2の電圧をE3とし、そのK倍の電圧がC1でR1とR2の
　　節点に正帰還。とすると、E1とE3の関係式がでて、回路は解けます。

2. このようにまず解いて、周波数特性などを表示するのではなく、節点
　方程式のように、・・・・機械的に節点にアドミタンス等を挿入？？
   して問題を解きたいのですが、E2やE3,そしてK等をマトリクス上でどう
　 表現して良いか分りません。
　 式を予め解かずとも、機械的に表示すれば、マトリクスが自動的に
　 解いてくれるのではないかと期待しています。
   何方か御教えて下さると有り難いのですが。

3, マトリクスで複素数を　MAT　PRINT  A とやると、複素数がやたら
　　長い表示になります。
　　何とかPRINT USING　＃＃＃＃　的に簡結な表示は出来ないでしょうか。
　　無理にやるとマトリクスでは複素数をPRINT USING　表示は出来ないと
　　表示されます。 		 

Re: 節点解析法について

 投稿者：白石　和夫  投稿日：2009年 2月 1日(日)16時10分14秒 		返信・引用
  > No.260[元記事へ]

> 3, マトリクスで複素数を　MAT　PRINT  A とやると、複素数がやたら
> 　　長い表示になります。
> 　　何とかPRINT USING　＃＃＃＃　的に簡結な表示は出来ないでしょうか。
> 　　無理にやるとマトリクスでは複素数をPRINT USING　表示は出来ないと
> 　　表示されます。

実部と虚部，あるいは，絶対値と偏角など，虚数部分を含まない数値のペアに分けてから書式を指定してください。
また，MAT PRINT USINGみたいのが必要であれば，配列と書式を引数としてとる副プログラムを作成して使ってください。 		 

Re: 節点解析法について

 投稿者：山中和義  投稿日：2009年 2月 2日(月)10時38分2秒 		返信・引用 　編集済
  > No.260[元記事へ]

大熊　正さんへのお返事です。

理想的なオペアンプの計算
　仮想の素子を考える（図２）
　・ナレータ
　　��V+とV-との電位は同じ（イマージナリーショート）
　　��V+とV-とには電流が流れない（入力抵抗が無限大）
　・ノレータ
　　��Voからは必要な電流が供給される（両方向）

これを適用すると、図３は、図１の等価回路になると思います。

この図３の回路図で節点方程式を考えます。
通常、Voは固定値とするが、アンプにより確定できません。（Vo=K*e2、e2は節点�△療徹漫�
そこで、アンプの入力を出力に反映させて（反復計算で）収束させます。


プログラムは図１のようなアンプを含んだ回路図で計算できるように
以前紹介した節点電位法のものを改良してあります。

1000 !節点電位法によるフィルタ回路の周波数解析（利得、位相）
1010
1020 OPTION ARITHMETIC COMPLEX
1030
1040 LET j=SQR(-1) !虚数単位　※電気系はｊを使う
1050
1060 LET f=60 !周波数[Hz]
1070 DEF w=2*PI*f !角周波数ω
1080
1090 DEF H2Ohm(L)=j*w*L ![H]を[Ω]へ
1100 DEF F2Ohm(C)=1/(j*w*C) ![F]を[Ω]へ
1110 DEF xL(L)=w*L !誘導リアクタンス
1120 DEF xC(C)=1/(w*C) !容量リアクタンス
1130
1140 SUB DispS(z) !複素数をS表示する　※スタインメッツ（Steinmetz）
1150    PRINT ABS(z);
1160    IF ABS(z)<>0 THEN
1170       IF arg(z)<>0 THEN PRINT "∠";DEG(arg(z));"°";
1180    END IF
1190    !PRINT
1200 END SUB
1210
1220 FUNCTION S2COMPLEX(l,th) !S表示（極座標形式）を複素数へ
1230    LET S2COMPLEX=COMPLEX(l*COS(RAD(th)),l*SIN(RAD(th)))
1240 END FUNCTION
1250 FUNCTION i2COMPLEX(im,th) !瞬時値式を複素数へ　※最大値、初期位相
1260    LET i2COMPLEX=S2COMPLEX(im/SQR(2),th) !実効値、初期位相
1270 END FUNCTION
1280 !-------------------- ここまでがサブルーチン
1290
1300
1310 SUB set_curcit !素子や結線を定義する
1320    !---------- ↓↓↓↓↓ ----------
1330
1340    !●回路図　Sallen-Key ３次ローパス・フィルタ
1350
1360    !参考サイト　http://sim.okawa-denshi.jp/OPseikiLowkeisan.htm
1370
1380    !　　　　　　　　　　┌─C2─┬──────┐
1390    !　　　　　　　　　　│　　　│　┌──┐　│
1400    !　　　　　　　　　　│　　　└─┤- 　│　│
1410    !　　　　　　　　　　│　　　　　│　Ｋ├─６─
1420    !　─２─R1─３─R2─４─R3─５─┤+ 　│　↑
1430    !　　↑　　　│　　　　　　　│　└──┘　│
1440    !　　Vi　　　C1　　　　　　　C3　　　　　　Vo
1450    !　　↓　　　│　　　　　　　│　　　　　　↓
1460    !　─１───┴───────┴──────┴─
1470    !　　│
1480    !　　≡アース
1490
1500    LET GND=1 !アース
1510    LET Vi=2 !入力端子
1520    LET Vo=6 !出力端子
1530
1540    !素子: Rn,Vn,In、n:番号（連番）　※２文字目以降は番号
1550    !値:
1560    !端子番号（起点）: １以上の値　※節点
1570    !端子番号: １以上の値　※節点
1580
1590    CALL AddElements("R1",51e3,2,3) !51k[Ω]、枝路電流は2→3と仮定する
1600    CALL AddElements("C1",F2Ohm(0.0068e-6),3,1) !0.0068[μF]
1610    CALL AddElements("R2",82e3,3,4) !82k[Ω]
1620    CALL AddElements("C2",F2Ohm(0.022e-6),4,6) !0.022[μF]
1630    CALL AddElements("R3",39e3,4,5) !39k[Ω]
1640    CALL AddElements("C3",F2Ohm(330e-12),5,1) !330[pF]
1650
1660    !※電圧源の番号は１からの連番　例. CALL AddElements("V1",?,?,?) !?[V]
1670    !なし
1680
1690    CALL AddElements("A1",1.0,5,6) !アンプ　増幅率1.0,＋端子5,出力端子6
1700
1710    !---------- ↑↑↑↑↑ ----------
1720
1730    CALL AddElements("Vi",10,GND,Vi) !10[V]　※測定用の電圧
1740 END SUB
1750
1760 !---------- ↓↓↓↓↓ ----------
1770 LET Ns=0 !電圧源の数
1780 LET Nd=6 !節点の数
1790 LET Na=1 !アンプの数
1800 !---------- ↑↑↑↑↑ ----------
1810
1820 LET N=Nd+Ns+Na+1
1830
1840 !●キルヒホッフの電流則より、節点方程式を組み立てる
1850 DIM A(N,N),x(N),b(N) !連立方程式 Ax=b
1860
1870 DIM AmpK(Na),AmpPlus(Na),AmpOut(Na)
1880
1890 SUB AddElements(el$,ev,nd1,nd2) !結線情報から回路方程式を組み立てる
1900    IF (nd1<1 OR nd1>Nd) OR (nd2<1 OR nd2>Nd) THEN
1910       PRINT "素子";el$;"の節点番号が違います。";nd1;nd2
1920       STOP
1930    END IF
1940
1950    !連立方程式を組み立てる　Ax=b
1960    ! ┌　 │　 ┐┌　┐ ┌　┐
1970    ! │Ｇ │±1││V │=│I │　R,C,L,電流源(Nd個)
1980    !───┼─────────
1990    ! │±1│-Zp││Ip│ │Ep│　電圧源(Ns個)、アンプ(Na個)、入力電圧源(1個)
2000    ! └　 │　 ┘└　┘ └　┘
2010
2020    SELECT CASE UCASE$(el$(1:1)) !素子に応じて
2030    CASE "V" !電圧源なら
2040       LET t$=UCASE$(el$(2:LEN(el$)))
2050       IF t$="I" THEN !計測用の入力電圧源なら
2060          LET p=Nd+Ns+Na+1
2070       ELSE
2080          LET p=VAL(t$) !番号を得る
2090          IF p<1 OR p>Ns THEN
2100             PRINT "電圧源の番号が違います。";el$
2110             STOP
2120          END IF
2130          LET p=p+Nd
2140       END IF
2150       LET A(nd1,p)=A(nd1,p)-1 !電流Ipが節点iから節点jへ流れたとして、(Vi-Vj)-Ip*Zp=Ep
2160       LET A(p,nd1)=A(p,nd1)-1
2170       LET A(nd2,p)=A(nd2,p)+1
2180       LET A(p,nd2)=A(p,nd2)+1
2190       LET A(p,p)=A(p,p)+0 !内部抵抗Zpは０とする
2200       LET b(p)=b(p)+ev !起電力
2210
2220    CASE "A" !アンプなら
2230       LET t=VAL(el$(2:LEN(el$))) !番号を得る
2240       IF t<1 OR t>Na THEN
2250          PRINT "アンプの番号が違います。";el$
2260          STOP
2270       END IF
2280       LET p=t+Nd+Ns !出力側をノレータ（初期値０Ｖの電圧源）として扱う
2290       LET A(GND,p)=A(GND,p)-1
2300       LET A(p,GND)=A(p,GND)-1
2310       LET A(nd2,p)=A(nd2,p)+1
2320       LET A(p,nd2)=A(p,nd2)+1
2330
2340       LET AmpK(t)=ev !増幅率
2350       LET AmpPlus(t)=nd1 !＋端子
2360       LET AmpOut(t)=p !方程式内での出力端子
2370
2380    CASE "I" !電流源なら
2390       LET b(nd1)=b(nd1)-ev
2400       LET b(nd2)=b(nd2)+ev
2410
2420    CASE ELSE !素子なら
2430       LET Gij=1/ev
2440       !対角成分　※節点に接続された素子（アドミタンス）の和
2450       LET A(nd1,nd1)=A(nd1,nd1)+Gij
2460       LET A(nd2,nd2)=A(nd2,nd2)+Gij
2470       !その他の成分　※節点に接続された素子（アドミタンス）に-1をかけたものの和
2480       LET A(nd1,nd2)=A(nd1,nd2)-Gij
2490       LET A(nd2,nd1)=A(nd2,nd1)-Gij
2500
2510    END SELECT
2520 END SUB
2530
2540 DIM Ai(N,N) !連立方程式を解く
2550 SUB routine
2560    MAT A=ZER
2570    MAT b=ZER
2580    CALL set_curcit !結線から方程式を組み立てる
2590
2600    FOR i=1 TO Nd !結線されていない節点　1*Vi=0
2610       IF A(i,i)=0 THEN LET A(i,i)=1
2620    NEXT i
2630    LET A(GND,GND)=0 !電位を０とする
2640
2650    !!!MAT PRINT A; !dump it
2660    !!!MAT PRINT b;
2670
2680
2690    MAT Ai=INV(A)
2700    MAT x=Ai*b
2710    IF Na>0 THEN !アンプがあれば
2720       FOR iter=1 TO 100 !安定させる　※要調整
2730          FOR i=1 TO Na
2740             LET b(AmpOut(i))=AmpK(i)*x(AmpPlus(i)) !Vo=K*V+　※入力を出力に反映させる
2750          NEXT i
2760          MAT x=Ai*b
2770       NEXT iter
2780    END IF
2790 END SUB
2800
2810
2820
2830 !SET bitmap SIZE 600,600 !画面を大きくする
2840 LET ymin=-150
2850 SET WINDOW -0.5,6.5, ymin,5 !表示領域
2860 DRAW grid(1,5) !左端の目盛り
2870
2880 FOR f=1 TO 6 !ｘ軸が対数
2890    PLOT TEXT ,AT f-0.3,-0.15: mid$("10  100 1k  10k 100k1M  ",4*(f-1)+1,4)
2900 NEXT f
2910
2920 FOR f=10 TO 100000 STEP 100 !周波数[Hz]
2930    CALL routine
2940    PLOT LINES: LOG10(f),20*LOG10(ABS(x(Vo)/x(Vi))); !利得[dB]
2950 NEXT f
2960 PLOT LINES
2970
2980
2990 SET TEXT COLOR 2
3000 FOR i=5 TO ymin STEP -5 !右端の縦軸目盛り
3010    PLOT TEXT ,AT 6,i: STR$(i*2)&"°" !※利得のグラフに合わせるために2倍する
3020 NEXT i
3030
3040 SET LINE COLOR 2
3050 FOR f=10 TO 100000 STEP 100 !周波数[Hz]
3060    CALL routine
3070    LET t=arg(x(Vo)/x(Vi))
3080    IF t>0 THEN LET t=t-2*PI !0〜-2πへ補正する
3090    PLOT LINES: LOG10(f),DEG(t)/2; !位相θ　※利得のグラフに合わせるために1/2倍する
3100 NEXT f
3110 PLOT LINES
3120
3130
3140 END
 

マクローリン展開の高速近似値計算への応用

 投稿者：いがらしまなと  投稿日：2009年 2月 4日(水)18時40分56秒 		返信・引用
  マクローリン展開の高速近似値計算への応用

１、十進法ＢＡＳＩＣによるプログラム

REM ***　逆行列で高速マクローリン展開
DIM a(3,3),b(3,1),c(3,1),d(3,3)
DEF f(x)=EXP(x)
LET x=0.0001
LET a(1,1)=x
LET a(1,2)=x^2
LET a(1,3)=x^3
LET a(2,1)=2*x
LET a(2,2)=4*x^2
LET a(2,3)=8*x^3
LET a(3,1)=3*x
LET a(3,2)=9*x^2
LET a(3,3)=27*x^3
MAT d=INV(a)
LET e=f(0)
LET c(1,1)=f(x)-e
LET c(2,1)=f(2*x)-e
LET c(3,1)=f(3*x)-e
MAT b=d*c
PRINT b(1,1)
PRINT b(2,1)
PRINT b(3,1)
END

２、理論

マクローリン展開の公式より

ｆ（ｘ）＝a(0)+a(1)x+a(2)x^2+a(3)x^3+・・・・であるから。

ｘ≒０に対して、解a(m)持つ連立方程式
ｆ（nｘ）＝a(0)+a(1)(nx)+a(2)(nx)^2+a(3)(nx)^3
を解くとマクロリン展開の近似値が求まる。

３、結果

f(x)=e^xのマクロリン展開を行列の逆行列を用いて計算した。

a(1)=0.999999999998332
a(2)=0.50000001
a(3)=0.166666766681668　を得るこれは真値

a(1)=１
a(2)=1/2=0.5
a(3)=1/6=0.1666・・・

に近い値となっている。

４、発展課題（自分に対して。。。。）

これをガウス・ジョルダン法により計算せよ！ 		 

(無題)

 投稿者：大熊　正  投稿日：2009年 2月 5日(木)10時42分50秒 		返信・引用
  白石　様　山中　様　　大熊です。

御多忙中の所、色々と御指導を頂きまことに有難うございます。

白石様
別途プログラムを作り、部分的に試した所、上手く動きました。

山中様
プログラムをコピーし、動かした所、綺麗に周波数特性が出ました。
「アンプの入力を出力に反映させて（反復計算で）収束させます。」
というのは、「目からうろこ」で驚きました。
総てを此れから勉強させていただきます。

それから、一番最後の　回路図は、どこから　どのようにコピーし、
この投稿欄に貼りつけるのでしょうか。この投稿欄に貼りつけよう
としましたが、出来ませんでした。
また、パソコンの「メモ帖」や、10進BASIC　にも貼り付きません。

出来ましたら、御教えください。

敬具 		 

Re: (無題)

 投稿者：山中和義  投稿日：2009年 2月 5日(木)11時32分41秒 		返信・引用 　編集済
  > No.264[元記事へ]

大熊　正さんへのお返事です。

> それから、一番最後の　回路図は、どこから　どのようにコピーし、
> この投稿欄に貼りつけるのでしょうか。この投稿欄に貼りつけよう
> としましたが、出来ませんでした。

この掲示板の投稿欄は（この画面の一番上）
　投稿者
　メール
　題名
　内容
　画像　←←←ここ
　ＵＲＬ
となっていますが、この画像の欄に
自分のパソコン内の画像データ（gif、jpg、png形式）を指定するとアップロードすることができます。

画像データの作成は、Windoes付属の「ペイント」で可能です。保存のとき、gif、jpg形式にします。



> また、パソコンの「メモ帖」や、10進BASIC　にも貼り付きません。

メモ帳やBASICの編集画面は「テキスト（文字）」のみを扱いますので、「画像」を貼り付けることはできません。
また簡易ワープロの「ワードパッド」では、「デキスト」と「画像」が扱えます。
したがって、画像データはプログラムとは別に管理（保存など）する必要があります。




●補足
　回路図を変更するときの修正箇所

−端子への入力の場合
1310 SUB set_circuit !素子や結線を定義する
1320    !---------- ↓↓↓↓↓ ----------
1330
1340    !●回路図　オペアンプ多重帰還型バンドパス・フィルタ
1350
1360    !参考サイト　http://sim.okawa-denshi.jp/OPseikiLowkeisan.htm
1370
1380    !　　　　　　┌─C1─┬──────┐
1390    !　　　　　　│　　　│　　　　　　│
1400    !　　　　　　│　　　R3　　　　　　│
1410    !　　　　　　│　　　│　┌──┐　│
1420    !　─２─R1─３─C2─４─┤- 　├─５─
1430    !　　↑　　　│　　　　　│　Ｋ│　↑
1440    !　　Vi　　　R2　　　┌─┤+ 　│　Vo
1450    !　　↓　　　│　　　│　└──┘　↓
1460    !　─１───┴───┴──────┴─
1470    !　　│
1480    !　　≡アース
1490
1500    LET GND=1 !アース
1510    LET Vi=2 !入力端子
1520    LET Vo=5 !出力端子
1530
1540    !素子: Rn,Cn,Ln,Vn,In、n:番号（連番）　※２文字目以降は番号
1550    !値:
1560    !端子番号（起点）: １以上の値　※節点
1570    !端子番号: １以上の値　※節点
1580
1590    CALL AddElements("R1",5.1e3,2,3) !5.1k[Ω]、枝路電流は2→3と仮定する
1600    CALL AddElements("C1",F2Ohm(0.022e-6),3,5) !0.022[μF]
1610    CALL AddElements("R2",20e3,3,1) !20k[Ω]
1620    CALL AddElements("C2",F2Ohm(0.033e-6),3,4) !0.033[μF]
1630    CALL AddElements("R3",8.2e3,4,5) !8.2k[Ω]
1640    !
1650
1660    !※電圧源の番号は１からの連番　例. CALL AddElements("V1",?,?,?) !?[V]
1670    !なし
1680
1690    CALL AddElements("A1",-1.0,4,5) !アンプ　増幅率-1.0,−端子4,出力端子5
1700
1710    !---------- ↑↑↑↑↑ ----------
1720
1730    CALL AddElements("Vi",10,GND,Vi) !10[V]　※測定用の電圧
1740 END SUB
1750
1760 !---------- ↓↓↓↓↓ ----------
1770 LET Ns=0 !電圧源の数
1780 LET Nd=5 !節点の数
1790 LET Na=1 !アンプの数
1800 !---------- ↑↑↑↑↑ ----------
1810

通常、この箇所を変更します。

特に負帰還の場合は繰り返しは１回のみでよいみたいです。
2710    IF Na>0 THEN !アンプがあれば
2720       FOR iter=1 TO 1 !安定させる　※要調整　　<---------- ここ
2730          FOR i=1 TO Na
2740             LET b(AmpOut(i))=AmpK(i)*x(AmpPlus(i)) !Vo=K*V+　※入力を出力に反映させる
2750          NEXT i
2760          MAT x=Ai*b
2770       NEXT iter
2780    END IF


なお、サブルーチンset_circuitのスペルが違っていました。訂正します。 		 

節点解析法について　（２）

 投稿者：大熊　正  投稿日：2009年 2月 7日(土)11時32分28秒 		返信・引用
  白石様　山中様　いつも御指導を頂き有難うございます。大熊です。

下記のごときプログラムを作り、山中様の回答を別解でなぞってみました。
答えは一致していると思ってます。
10進BASICは、マトリクスと複素数の計算が簡単に出来、初学修者にはとても
便利だと言うことを実感しています。

敬具


10 OPTION ARITHMETIC COMPLEX
   LET j=SQR(-1)
   OPTION BASE 1
   OPTION ANGLE DEGREES

   DIM FREQ(100,5)
   LET FREQ(1,1)=10
   LET FREQ(2,1)=12.25
   LET FREQ(3,1)=15
   LET FREQ(4,1)=17.32
   LET FREQ(5,1)=20
   LET FREQ(6,1)=24.5
   LET FREQ(7,1)=30
   LET FREQ(8,1)=34.6
   LET FREQ(9,1)=40
   LET FREQ(10,1)=50
   LET FREQ(11,1)=60
   LET FREQ(12,1)=70
   LET FREQ(13,1)=80
   LET FREQ(14,1)=90

   FOR I=1 TO 14
      LET P=I
      LET FREQ(I,1)=FREQ(P,1)
   NEXT I
   FOR I=15 TO 28
      LET P=I-14
      LET FREQ(I,1)=FREQ(P,1)*10
   NEXT I
   FOR I=29 TO 42
      LET P=I-28
      LET FREQ(I,1)=FREQ(P,1)*100
   NEXT I
   FOR I=43 TO 56
      LET P=I-42
      LET FREQ(I,1)=FREQ(P,1)*1000
   NEXT I
   LET FREQ(57,1)=100000

   ! FOR I=1 TO 57
   !    PRINT "FREQ(";I;",1)=";FREQ(I,1)
   ! NEXT I


   !                             ┌─C2─┬──────┐ 「注意」
   !                             │      │  ┌──┐  │   山中さんの回路と1番
   !                             │      └─┤-   │  │  端子番号が
   !                             │          │  Ｋ├─�エ� 小さくなってます。
   !         ┌─�；�R1─�※�R2─��─R3─�え；�+   │  ↑ V5
   !         ↑  ↑V1    ↑V2    ↑V3    ↑V4└──┘  │
   !         Is  Rs      C1              C3            │
   !         ↑  │      │              │            │
   !         ┴─０───┴───────┴──────┴─
   !             │
   !             ≡アース
   !    GND=0 !アース
   !    V1=1V !入力端子�� Rs=0.1オームに定電流源Is から10A流して1Vとする。
   !    V5=�� !出力端子�� V5=K*V4

20 ! CR 3段回路
   LET FF=1000             !Fの単位はヘルツ
   LET R1=51000            !Rの単位はオーム
   LET R2=82000
   LET R3=39000
   LET C1=0.00685/(10^6)   !Cの単位はuF,
   LET C2=0.022/(10^6)     !Cの単位はuF,
   LET C3=330/(10^12)      !Cの単位はPF,

   LET Y1=(2*PI*FF*C1)     !Yの単位はモー
   LET Y2=(2*PI*FF*C2)
   LET Y3=(2*PI*FF*C3)

   LET ω=(2*PI*FF)
   LET Rs=0.1    !Rsの単位はオーム      �，肇◆璽垢貌�れる。
   LET IS=10     !Isの単位はアムペア  Rsに加わる電流源で�，肇◆璽垢�1Vにする。

   LET NP=4
   DIM A(NP,NP)
   DIM T(NP,NP)

   DIM EOUT(NP,1)
   DIM B(NP,1)
   LET K=1

   !*********** データーと計算方法*****************
   !方法-1
   !  ミルマンの定理やキルヒホッフの法則なぞを多用、直接解く。

   !方法-2
   !  回路の�｜嫉劼肇◆璽拘屬�0.1オームの抵抗、アドミッタンスGsをわざとつける。
   !  電流源 10A を入力にして�｜嫉劼肇◆璽拘屬痢�Gs）に加えて V1を約  1Vとする。
   !  以下は、想定の回路につなげ、端子間のアドミッタンスを考え節点方程式を作る。
   !  �　辞△�R1,�◆辞�にR2,�◆璽◆璽垢僕椴�C1,��ー�い�R3,�ぁ璽◆璽垢僕椴�C3
   !  C3の電圧V4を増幅器に入力。�イ砲�V5=K*V4の電圧がでる。
   !  ��に増幅器の出力V5を、�イ�ら容量C2で ��に正帰還,・・・ V5=K*V4
   !  ��端子の電圧をV2,�Ｃ嫉劼療徹気�V3,�っ嫉劼療徹気�V4,�ッ嫉劼療徹気�V5
   !  総てアドミッタンスで計算。
   !  �´�,�↓�,����,�きづ� Gij(i=j)はその節点に接続されるアドミッタンスの和
   !  ��-��, ��-�� 等 Gij(i?j)は接続されてるアドミッタンスに-1を掛けて代入。
   !  Ampを除き、要素のみを考えると対称行列になり,ノードの数が行列の大きさ。
   !  行列は 5x5 だが V5=K*V4 を考えA(3,4)=-(1/R3)に A(3,5)=-ω*C2*jを加える
   !  Kは A(3,4)=-(1/R3)-K*ω*C2*j増幅器の出力 E5=K*E4の関係を入れA(3,5)を消す
   !  一方  A(4,3)=-(1/R3) とし非対称とした。A(4,3)＝A(3,4)では不具合であった
   !  最終の行列は  4x4 の非対称に成るが、Kが直接指定できる利点があるようだ。
   !  結果はKの値に敏感で K=0.9875〜1.0125までで、K=1 が最適。K= 1.0125でピーク


   !方法-3
   !文献や投稿を参照

   !***********************方法-2の計算  今回はこれで挑戦*****************

   FOR K=0.9875 TO 1.0125 STEP 0.0125       !KはAMPのゲイン。
      FOR P=1 TO 57
         LET FF=FREQ(P,1)
         LET ω=(2*PI*FF)

         LET A(1,1)=(1/Rs)+(1/R1)           !�´｜嫉劼離▲疋潺織鵐垢旅膩�
         LET A(1,2)=-(1/R1)                 !�´�端子のアドミタンスの -1

         LET A(1,3)=0
         LET A(1,4)=0

         LET A(2,1)=-(1/R1)
         LET A(2,2)=(1/R1)+(1/R2)+ω*C1*j  !�↓�端子のアドミタンスの合計
         LET A(2,3)=-(1/R2)
         LET A(2,4)=0

         LET A(3,1)=0
         LET A(3,2)=-(1/R2)
         LET A(3,3)=(1/R2)+(1/R3)+ω*C2*j  !���Ｃ嫉劼離▲疋潺織鵐垢旅膩�
         LET A(3,4)=-(1/R3)-K*ω*C2*j   !ここにKの値を入れ V5=K*V4 を反映。
         !ミルマンの定理を適用。
         LET A(4,1)=0
         LET A(4,2)=0
         LET A(4,3)=-(1/R3)                !A(3,4)とは値が異なる。
         LET A(4,4)=(1/R3)+ω*C3*j         !�きっ嫉劼離▲疋潺織鵐垢旅膩�

         LET B(1,1)=10   ! 電流源から10Aを流している。�｜嫉劼�1Vになる。
         LET B(2,1)=0    ! キルヒホッフの法則から  ゼロである。
         LET B(3,1)=0    ! キルヒホッフの法則から  ゼロである。
         LET B(4,1)=0    ! キルヒホッフの法則から  ゼロである。
         MAT T=INV(A)
         MAT EOUT=T*B
         ! PRINT "FF=";FF
         ! MAT PRINT EOUT
         LET EE1=EOUT(1,1)
         LET EE2=EOUT(2,1)
         LET EE3=EOUT(3,1)
         LET EE4=EOUT(4,1)
         LET EE5=K*EOUT(4,1)
         PRINT
         LET FREQ(P,2)=20*LOG10(ABS(EE5))
         ! LET FREQ(P,3)=20*LOG10(ABS(EE3))
         LET  G5=(ATN(IM(EE5)/RE(EE5)))
         IF FF>750 THEN LET G5=G5-180
         IF G5>0 THEN LET G5=G5-180
         LET  FREQ(P,4)=G5
         ! LET  G3=(ATN(IM(EE3)/RE(EE3)))
         ! IF FF>750 THEN LET G3=G3-180
         ! LET  FREQ(P,5)=G3
      NEXT P
      PRINT "K=";K
      PRINT "番号   周波 数      E5         E3         θ5         θ3"
      FOR I=1 TO 57
         PRINT USING "###": I;
         PRINT USING " ###,###.#"  : FREQ(I,1);
         PRINT USING " ####.### dB": FREQ(I,2);
         PRINT USING " ####.### dB": FREQ(I,3);
         PRINT USING " ####.### 度": FREQ(I,4);
         PRINT USING " ####.### 度": FREQ(I,5)
      NEXT I

      !ここからは、山中様のグラフプログラムを参照。
      SET WINDOW 0.5,5.5, -55,5      !表示領域
      DRAW grid(1,5)                  ! 左端の目盛り
      FOR f=1 TO 6   !ｘ軸が対数目盛 f=1 TO 5 で100k まで目盛る。
         SET COLOR 1 !１は黒色
  PLOT TEXT ,AT f-0.1,+0.15: mid$("10  100 1k  10k 100k ",4*(f-1)+1,4)
      NEXT f

      FOR f=1 TO 6   !y軸が直線目盛り
         SET COLOR 1 !１は黒色
  PLOT TEXT ,AT 0.8,-10*(f-1)-2: mid$("  0 -25 -50 -75 -100-125 ",4*(f-1)+1,4)
      NEXT f

      FOR I=1 TO 57 STEP 1 !周波数[Hz]
         SET COLOR 1
     PLOT LINES:LOG10(FREQ(I,1)) ,FREQ(I,2)/2.5; !利得[dB]
      NEXT I
      PLOT LINES

      !  FOR I=1 TO 57 STEP 1 !周波数[Hz]
      !     SET COLOR 5    !5は水色
      !     PLOT LINES: LOG10(FREQ(I,1)) ,FREQ(I,3)/2; !利得[dB]
      !  NEXT I
      !  PLOT LINES

      FOR I=1 TO 57 STEP 1 !位相角度[度]
         SET COLOR 4  !4は赤色
         PLOT LINES:LOG10(FREQ(I,1)) ,0.125*FREQ(I,4); !角度[度]
      NEXT I
      PLOT LINES

      !  FOR I=1 TO 57 STEP 1 !位相角度[度]
      !     SET COLOR 3   !3は緑色
      !     PLOT LINES:LOG10(FREQ(I,1)) ,0.25*FREQ(I,5); !角度[度]
      !  NEXT I
      !  PLOT LINES
      FOR f=1 TO 6     !y軸が直線目盛り
         SET COLOR 4
   PLOT TEXT ,AT 5.1,-10*(f-1)-2: mid$(" 0  -80 -160-240-320-400 ",4*(f-1)+1,4)
      NEXT f
      PRINT

   NEXT K   ! ここで,利得 Kを変化させる。

   !*******************************************************************
   !100 LET FF=1000
   !    PRINT 1/R1
   !    PRINT 1/R2
   !    PRINT 1/R3
   !    PRINT  Y1
   !    PRINT  Y2
   !    PRINT  Y3
   !   FOR I=1 TO NP      ! 白石様の御助言を参照。マトリクスのチェックをした。
   !      FOR J=1 TO NP
   !         LET Z=A(I,J)
   !         PRINT USING "(##.######### ":RE(Z);
   !         PRINT USING "##.#########)  ":IM(Z);
   !      NEXT J
   !      PRINT
   !   NEXT I
   !**********************************************************************

END 		 

節点解析法について　（３）

 投稿者：大熊　正  投稿日：2009年 2月 9日(月)12時12分3秒 		返信・引用
  大熊です。
前回投稿したのですが、４Ｘ４行列が対称でないのが気に食わず、
５x５にし、そのうち４Ｘ４は対称で、５行目に一括して増幅器
の増幅度Ｋの関係を入れるように改良しました。
このようにすれば、入力ミスが少なく、後はマトリクスが自動で
答えを出してくれる・・・？？。

敬具。

10 OPTION ARITHMETIC COMPLEX
   LET j=SQR(-1)
   OPTION BASE 1
   OPTION ANGLE DEGREES

   DIM FREQ(100,5)
   LET FREQ(1,1)=10
   LET FREQ(2,1)=12.25
   LET FREQ(3,1)=15
   LET FREQ(4,1)=17.32
   LET FREQ(5,1)=20
   LET FREQ(6,1)=24.5
   LET FREQ(7,1)=30
   LET FREQ(8,1)=34.6
   LET FREQ(9,1)=40
   LET FREQ(10,1)=50
   LET FREQ(11,1)=60
   LET FREQ(12,1)=70
   LET FREQ(13,1)=80
   LET FREQ(14,1)=90

   FOR I=1 TO 14
      LET P=I
      LET FREQ(I,1)=FREQ(P,1)
   NEXT I
   FOR I=15 TO 28
      LET P=I-14
      LET FREQ(I,1)=FREQ(P,1)*10
   NEXT I
   FOR I=29 TO 42
      LET P=I-28
      LET FREQ(I,1)=FREQ(P,1)*100
   NEXT I
   FOR I=43 TO 56
      LET P=I-42
      LET FREQ(I,1)=FREQ(P,1)*1000
   NEXT I
   LET FREQ(57,1)=100000

   ! FOR I=1 TO 57
   !    PRINT "FREQ(";I;",1)=";FREQ(I,1)
   ! NEXT I


   !                             ┌─C2─┬──────┐ 「注意」
   !                             │      │  ┌──┐  │   山中さんの回路と
   !                             │      └─┤-   │  │  1番端子番号が
   !                             │          │  Ｋ├─�エ� 小さい。
   !         ┌─�；�R1─�※�R2─��─R3─�え；�+   │  ↑ V5
   !         ↑  ↑V1    ↑V2    ↑V3    ↑V4└──┘  │
   !         Is  Rs      C1              C3            │
   !         ↑  │      │              │            │
   !         ┴─０───┴───────┴──────┴─
   !             │
   !             ≡アース
   !    GND=0 !アース
   !    V1=1V !入力端子�� Rs=0.1オームに定電流源Is から10A流して1V。
   !    V5=�� !出力端子�� V5=K*V4

20 ! CR 3段回路
   LET FF=1000             !Fの単位はヘルツ
   LET R1=51000            !Rの単位はオーム
   LET R2=82000
   LET R3=39000
   LET C1=0.00685/(10^6)   !Cの単位はuF,
   LET C2=0.022/(10^6)     !Cの単位はuF,
   LET C3=330/(10^12)      !Cの単位はPF,

   LET Y1=(2*PI*FF*C1)     !Yの単位はモー
   LET Y2=(2*PI*FF*C2)
   LET Y3=(2*PI*FF*C3)

   LET ω=(2*PI*FF)
   LET Rs=0.1    !Rsの単位はオーム      �，肇◆璽垢貌�れる。
   LET IS=10     !Isの単位はアムペア  Rsを1Vにする。

   LET NP=5
   DIM A(NP,NP)
   DIM T(NP,NP)

   DIM EOUT(NP,1)
   DIM B(NP,1)
   LET K=1

   !*********** データーと計算方法*****************
   !方法-1
   !  ミルマンの定理やキルヒホッフの法則なぞを多用、直接解く。

   !方法-2Ｂ
   !  回路の�｜嫉劼肇◆璽拘屬�0.1オームの抵抗、アドミッタンスGsをとつける。
   !  電流源 10A を入力にして�｜嫉劼肇◆璽拘屬痢�Gs）に加えて V1を約  1V。
   !  以下は、想定の回路につなげ、端子間のアドミッタンスを考え節点方程式。
   !  �　辞△�R1,�◆辞�にR2,�◆璽◆璽垢僕椴�C1,��ー�い�R3,�ぁ璽◆璽垢僕椴�
   !  C3、C3の電圧V4を増幅器に入力。�イ砲�V5=K*V4の電圧がでる。
   !  ��に増幅器の出力V5を、�イ�ら容量C2で ��に正帰還,・・・ V5=K*V4
   !  ��端子の電圧をV2,�Ｃ嫉劼療徹気�V3,�っ嫉劼療徹気�V4,�ッ嫉劼療徹気�V5
   !  総てアドミッタンスで計算。
   !  �´�,�↓�,����,�きづ� Gij(i=j)はその節点に接続されるアドミッタンス和
   !  ��-��, ��-�� 等 Gij(i?j)は接続されてるアドミッタンスに-1を掛けて代入
   !  Ampを除き、要素のみを考えると対称行列になり,ノードの数が行列の大きさ
   !  行列は 5x5 で4x4 の部分は対称に成る。 これが利点。
   !  行列の 5行目に E5=K*E4の関係をいれる。これが利点。
   !  Kは A(5,4)=-K   A(5,5)=1   B(5,1)=0  で増幅器の出力を関係付ける。
   !  最終の行列は  5x5 の非対称に成るが、Kが直接指定できる利点があるようだ
   !  結果はKの値に敏感で K=0.9875〜1.0125までで、K=1 が最適。


   !方法-3
   !文献や投稿を参照

   !***********************方法-2Ｂの計算  今回はこれで挑戦*****************

   FOR K=0.9875 TO 1.0125 STEP 0.0125       !KはAMPのゲイン。
      FOR P=1 TO 57
         LET FF=FREQ(P,1)
         LET ω=(2*PI*FF)

         LET A(1,1)=(1/Rs)+(1/R1)       !�´｜嫉劼離▲疋潺織鵐垢旅膩�
         LET A(1,2)=-(1/R1)             !�´�端子のアドミタンスの -1
         LET A(1,3)=0
         LET A(1,4)=0
         LET A(1,5)=0

         LET A(2,1)=-(1/R1)
         LET A(2,2)=(1/R1)+(1/R2)+ω*C1*j  !�↓�端子のアドミタンスの合計
         LET A(2,3)=-(1/R2)
         LET A(2,4)=0
         LET A(2,5)=0

         LET A(3,1)=0
         LET A(3,2)=-(1/R2)
         LET A(3,3)=(1/R2)+(1/R3)+ω*C2*j!���Ｃ嫉劼離▲疋潺織鵐垢旅膩�
         LET A(3,4)=-(1/R3)   !A(4,3)と値が同じくし対称行列にする。
         LET A(3,5)=-ω*C2*j

         LET A(4,1)=0
         LET A(4,2)=0
         LET A(4,3)=-(1/R3)  !A(3,4)と値が同じくし対称行列にする。
         LET A(4,4)=(1/R3)+ω*C3*j !�きっ嫉劼離▲疋潺織鵐垢旅膩�
         LET A(4,5)=0

         LET A(5,1)=0
         LET A(5,2)=0
         LET A(5,3)=0
         LET A(5,4)=-K   ! ここにKの値を入れ V5=K*V4 を反映。
         LET A(5,5)=1    ! ここに1の値を入れ V5=K*V4 を反映。

         LET B(1,1)=10   ! 電流源から10Aを流す。�｜嫉劼�1V。
         LET B(2,1)=0    ! キルヒホッフの法則から  ゼロである。
         LET B(3,1)=0    ! キルヒホッフの法則から  ゼロである。
         LET B(4,1)=0    ! キルヒホッフの法則から  ゼロである。
         LET B(5,1)=0    ! ここに0の値を入れ V5=K*V4 を反映。
         MAT T=INV(A)
         MAT EOUT=T*B
         ! PRINT "FF=";FF
         ! MAT PRINT EOUT
         LET EE1=EOUT(1,1)
         LET EE2=EOUT(2,1)
         LET EE3=EOUT(3,1)
         LET EE4=EOUT(4,1)
         LET EE5=EOUT(5,1)
         PRINT
         LET FREQ(P,2)=20*LOG10(ABS(EE5))
         ! LET FREQ(P,3)=20*LOG10(ABS(EE3))
         LET  G5=(ATN(IM(EE5)/RE(EE5)))
         IF FF>750 THEN LET G5=G5-180
         IF G5>0 THEN LET G5=G5-180
         LET  FREQ(P,4)=G5
         ! LET  G3=(ATN(IM(EE3)/RE(EE3)))
         ! IF FF>750 THEN LET G3=G3-180
         ! LET  FREQ(P,5)=G3
      NEXT P
      PRINT "K=";K
      PRINT "番号   周波 数      E5         E3         θ5         θ3"
      FOR I=1 TO 57
         PRINT USING "###": I;
         PRINT USING " ###,###.#"  : FREQ(I,1);
         PRINT USING " ####.### dB": FREQ(I,2);
         PRINT USING " ####.### dB": FREQ(I,3);
         PRINT USING " ####.### 度": FREQ(I,4);
         PRINT USING " ####.### 度": FREQ(I,5)
      NEXT I

      !ここからは、山中様のグラフプログラムを参照。
      SET WINDOW 0.5,5.5, -55,5      !表示領域
      DRAW grid(1,5)                  ! 左端の目盛り
      FOR f=1 TO 6   !ｘ軸が対数目盛 f=1 TO 5 で100k まで目盛る。
         SET COLOR 1 !１は黒色
   PLOT TEXT ,AT f-0.1,+0.15: mid$("10  100 1k  10k 100k ",4*(f-1)+1,4)
      NEXT f

      FOR f=1 TO 6   !y軸が直線目盛り
         SET COLOR 1 !１は黒色
PLOT TEXT ,AT 0.8,-10*(f-1)-2: mid$("  0 -25 -50 -75 -100-125 ",4*(f-1)+1,4)
      NEXT f

      FOR I=1 TO 57 STEP 1 !周波数[Hz]
         SET COLOR 1
         PLOT LINES:LOG10(FREQ(I,1)) ,FREQ(I,2)/2.5; !利得[dB]
      NEXT I
      PLOT LINES

      !  FOR I=1 TO 57 STEP 1 !周波数[Hz]
      !     SET COLOR 5    !5は水色
      !     PLOT LINES: LOG10(FREQ(I,1)) ,FREQ(I,3)/2; !利得[dB]
      !  NEXT I
      !  PLOT LINES

      FOR I=1 TO 57 STEP 1 !位相角度[度]
         SET COLOR 4  !4は赤色
         PLOT LINES:LOG10(FREQ(I,1)) ,0.125*FREQ(I,4); !角度[度]
      NEXT I
      PLOT LINES

      !  FOR I=1 TO 57 STEP 1 !位相角度[度]
      !     SET COLOR 3   !3は緑色
      !     PLOT LINES:LOG10(FREQ(I,1)) ,0.25*FREQ(I,5); !角度[度]
      !  NEXT I
      !  PLOT LINES
      FOR f=1 TO 6     !y軸が直線目盛り
         SET COLOR 4
PLOT TEXT ,AT 5.1,-10*(f-1)-2: mid$(" 0  -80 -160-240-320-400 ",4*(f-1)+1,4)
      NEXT f
      PRINT
    NEXT K   ! ここで,利得 Kを変化させる。

END 		 

コンデンサと、抵抗だけ？

 投稿者：SECOND  投稿日：2009年 2月 9日(月)12時48分25秒 		返信・引用 　編集済
  この回路で、700Hz 付近の、入出力電圧比を、計算して下さい。
きっと、信じられないことが、見つかります。
 

Re: コンデンサと、抵抗だけ？

 投稿者：大熊　正  投稿日：2009年 2月10日(火)10時18分37秒 		返信・引用
  > No.268[元記事へ]

SECONDさんへのお返事です。

> この回路で、700Hz 付近の、入出力電圧比を、計算して下さい。
> きっと、信じられないことが、見つかります。

大熊です。
最近、習い覚えた節点方程式で解いたところ、確かに
700Hz付近で0.7dB 程度の盛り上がりが、ゆるやかに
ありました。
パッシブ素子のみで、トランスみたいな動作をするのは
確かに不思議です。

そこで御質問いたします。

（１）この回路は「？？？回路」として有名な回路なのですか。
（２）既に、なにかの製品に使われてるのでしょうか。

その他
（１）10進BASIC で既に作られた科学技術のソフトを　電気、
　　　土木、医療・・・・などと分類して登録してある
　　　インターネットの場所はありませんか。
　　　LINUX でそういうのが、ある事を最近知りました。
　　　10進BASIC でもあれば、皆が大層便利に使い発展に
　　　繋がると思います。

敬具 		 

宣言可能な配列の大きさの上限

 投稿者：白石　和夫  投稿日：2009年 2月10日(火)11時28分54秒 		返信・引用
  > No.252[元記事へ]

十進BASICが記憶領域として用いるメモリは大別してヒープとスタックの2種類があります。
スタックは，手続きの実行・終了にしたがって自動的に増減します。
ヒープは手続きの進行と非同期に確保・解放されます。
ヘルプの「言語使用の詳細」―「制限」の頁に記載されている「変数管理用メモリ」はスタックメモリに割り当てる領域です。

十進BASICは，
LET N=1000
DIM A(N)
のような拡張構文を許容するため，配列要素の実領域をヒープ上に確保します。
DIM B(1000)
のようにFull BASIC規格の範囲で宣言された配列はスタックメモリ上に確保できますが，
内部構造の複雑さを避けるためにどちらの形式の配列も配列要素はヒープ上に置いています。

配列を多用するプログラムを実行する場合には，変数管理用メモリを小さくとったほうが有利です。
しかし，ヒープから1回に取得できるメモリの大きさにはOS，開発言語および実行環境に由来する制限があります。
実装メモリ1GB(ビデオメモリを含む)のWindows XP機で，
BASIC.INIの[FRAME]セクションに
Virtualmemory=16
の記述を追加して実験すると，
10 OPTION ARITHMETIC NATIVE
20 DIM A(88000000)
30 END
程度が限界で，このプログラムを実行するとHDDへのスワップが発生します。
20行を A(90000000)に変えるとメモリ不足のエラーになります。
2進モードでは数値変数1個で8バイト占有するので，88000000個の変数は704MBに相当します。
なお，プログラムを実行すると，ヒープ領域のメモリの断片化が起こるので，プログラムの実行に成功したとき続けて要素数を増やしたプログラムを実行すると失敗する可能性が高くなります。成功した後の試行は，一旦，BASIC.EXEを終了・再起動後に行う必要があります。
また，このことは，プログラムの開発のために何度もプログラムの実行をくり返すような場面にもあてはまります。 		 

Re: コンデンサと、抵抗だけ？

 投稿者：SECOND  投稿日：2009年 2月10日(火)20時01分34秒 		返信・引用
  > No.269[元記事へ]

＞（１）この回路は「？？？回路」として有名な回路なのですか。

　　実は、このままでは、実用にならないのですが、もう１段のＣＲを追加し、
　　ＣＲ３段型の昇圧回路にしたものが、５０年も大昔（1962年以前）に、
　　Ｒ−Ｃ カソード・ホロワ発振器　米国特許2769088
　　------------------------------------------------------------
　　参考文献：　エレクトロニクス エンジニアのための ラプラス変換
　　　　　　　　ホルブルーク著　宮脇一男 訳（朝倉書店）
　　------------------------------------------------------------
　　３段以上にすると、０移相での昇圧効果が得られ、ボルテージ・フォロアー
　　のような、電圧利得＜１　のバッファーだけで、出力インピーダンスの低い
　　発振器が、作れます。
　　　（下記ベクトル図参照。直感的把握には、この方が解り易い。）

＞（２）既に、なにかの製品に使われてるのでしょうか。

　　殆んど知られていません。調べてはいませんが、もう時効だとも、思います。

＞その他
＞（１）10進BASIC で既に作られた科学技術のソフトを　電気、
　　　土木、医療・・・・などと分類して登録してある
　　　インターネットの場所はありませんか・・・

　　それが、できるといいですね。複素数も使えない御本家よりは、
　　「十進ＢＡＳＩＣ」の方がいいです。
 

Re: コンデンサと、抵抗だけ？（２）

 投稿者：大熊　正  投稿日：2009年 2月12日(木)14時21分48秒 		返信・引用
  > No.271[元記事へ]

SECONDさんへのお返事です。

> ＞（１）この回路は「？？？回路」として有名な回路なのですか。
>
> 　　実は、このままでは、実用にならないのですが、もう１段のＣＲを追加し、
> 　　ＣＲ３段型の昇圧回路にしたものが、５０年も大昔（1962年以前）に、
> 　　Ｒ−Ｃ カソード・ホロワ発振器　米国特許2769088
> 　　------------------------------------------------------------
> 　　３段以上にすると、０移相での昇圧効果が得られ、ボルテージ・フォロアー
> 　　のような、電圧利得＜１　のバッファーだけで、出力インピーダンスの低い
> 　　発振器が、作れます。
>

大熊　です。
勇を鼓して、３段に挑戦しました。1.225khz付近で0.9dbの盛り上がりでした。
何か、負荷が重いのだろうと、抵抗を図の下から1.5k,15k,150kと増やし、
容量を逆に下から0.1uF,0.01uF,0.001uFと減らすと、実に1.225khz付近で1.99db
の盛り上がりになりました。これなら発振しそうです。
・・・尚、２段でもこのようにすると、700HZ付近で1.153dbと増えました。


質問ですが
（１）発振器とは、何処とー何処を　つなぐのでしょうか。
（２）其の時、マトリクスも答えがグジャグジャと止まらなく
　　　成るのでしょうか。・・・それで発振とする？？？。
（３）・・・別に方程式を作り時間で解くのでしょうか。
　　　このような時の方程式のサンプルを教えていただけると
　　　ありがたいのですが。

敬具 		 

Re: コンデンサと、抵抗だけ？（２）

 投稿者：SECOND  投稿日：2009年 2月13日(金)00時43分30秒 		返信・引用 　編集済
  > No.272[元記事へ]

大熊　正さんへのお返事です。

プログラムではない為、ここに適当ではありませんが、ご参考に。

オペアンプ自体の周波数、位相特性が問題になるような高周波発振器でない場合、
帰還回路の計算だけで、十分だと思います。

発振条件は、ループゲイン１（0dB)、移相量は、０を含む２πの整数倍ですが、
0dB では、開始起動が、できない場合を含むため、ゲインを多めにします。
しかし、
正弦波が欲しい場合、起動の信頼性を確保する程度の少なめにしないと、
元々が、高調波を含んだ歪波なのに、益々正弦波形から、遠くなります。

どれくらい多目のゲインが適当かについて、数学的には１を越えてさえおれば、
いいのですが、実際のアンプの場合、無歪の正弦波を、維持するゲインに命中
させても、不安定で固定できません。出力振幅で、抵抗値の変化する素子を用い、
ゲインの自動制御をしない限り、正弦波は無理です。一般の発振器は、波形の尖頭
を、出力飽和に、ぶつける事で、安定を保っているため、必ず歪んでいます。

発振回路は、線型である限り、無限大か、減衰停止か、どちらかに流れますが、
計算上は、１周ループの伝達関数（出力／入力）を複素数で求め、
（実数部＝１、虚数部＝０）になる条件で、解としているようです。

下図は、ＣＡＤで、発振させた例で、実物には、さらに、ダイナミック・レンジや、
直流バイアスを、検討します。（適当な参考書をさがして下さい。）
 

Re: コンデンサと、抵抗だけ？（２）

 投稿者：SECOND  投稿日：2009年 2月13日(金)06時08分54秒 		返信・引用
  > No.273[元記事へ]

大熊　正さんへのお返事です。
＜＜追記＞＞
1KHz で、発振している帰還回路の特性が、下の様になっているのは、奇妙に
思えるかもしれません。発振している 1KHz 付近は、約 +0.1dB  +0.3deg.です。
昇圧の大きい部分は、位相角が２ｎπでなく、発振条件を、満たしていない。

0deg.でなく、やや進相ぎみなのは、ＯＰアンプ内部の入出力インピーダンスが、
1MΩ,　100Ωになっていて、純粋な理想アンプではない事と、接続した事によって、
帰還回路の定数が、僅かに移動した為かと思います。
 

Re: コンデンサと、抵抗だけ？（２）

 投稿者：大熊　正  投稿日：2009年 2月13日(金)19時07分50秒 		返信・引用
  > No.274[元記事へ]

SECONDさんへのお返事です。

> 大熊　正さんへのお返事です。
> ＜＜追記＞＞
> 1KHz で、発振している帰還回路の特性が、下の様になっているのは、奇妙に
> 思えるかもしれません。発振している 1KHz 付近は、約 +0.1dB  +0.3deg.です。
> 昇圧の大きい部分は、位相角が２ｎπでなく、発振条件を、満たしていない。
>
> 0deg.でなく、やや進相ぎみなのは、ＯＰアンプ内部の入出力インピーダンスが、
> 1MΩ,　100Ωになっていて、純粋な理想アンプではない事と、接続した事によって、
> 帰還回路の定数が、僅かに移動した為かと思います。


大熊です。
色々な図面を提示していただき有難うございます。
勉強しなければならぬことが実に多いことも
分りました。
今後とも御指導よろしく御願いいたします。

敬具 		 

数値式文字列式評価

 投稿者：荒田浩二  投稿日：2009年 2月14日(土)00時14分36秒 		返信・引用 　編集済
  
十進BASICに添付されたサンプルプログラム"\BASICw32\SAMPLE\INTERPRE.bas"は数値式の評価を行います。
数値式を入力すると、その式の値を出力します。
それを次のように拡張しました。

(1) 数値定数
   小数点で始まる小数や、指数部のある数値も扱える。

(2) 組込み関数
   十進BASICの組込み関数は、配列や特殊な例を除きほとんど利用できる。

(3) 変数
   数値式に変数を使える。
   数値式内に変数を認識すると,変数名を表示し入力を求めてくる(中止は[中止]ボタンで)。
   変数への入力は数値式も可。ただし,この数値式に変数を含むことは不可。
    例) a^2+1 の変数a に[4],[-3/2],[8-3*5],[sqr(5)-1],[SIN(pi/6)]など入力可。[4*n+9]は不可。
   変数名の命名規則は十進BASICに準ずる(漢字可、PI,RND,MAXNUM,DATE,TIME,DATE$,TIME$以外の機能語も可)。
   配列には対応していない。

(4) 文字列式
   文字列式の評価も行える。その場合は入力する文字列式の先頭に「$=」を付ける。
    例) $=REPEAT$("aBc D",3) ; $="alphabet "&CHR$(64+Number) ; $="2*3+7="&STR$(2*3+7)
   文字列では大文字と小文字を区別する。空白も認識する。漢字も可。

(5) 文字列変数
   数値式や文字列式に、文字列変数を使用できる。
   文字列変数への入力は、文字列定数(前後の(")は不要)または文字列式が可。
   文字列変数に文字列式を入力する場合は先頭に「$=」を付ける。この文字列式に変数を含むことは不可。
    例) $=USING$(a$,800.52) のa$に[###],[$=REPEAT$("#",3)]など入力可。
    例) LEN(mj$&"yz") のmj$に[ab漢],[$=LTRIM$("  ab")&UCASE$"cd"]など入力可。[$="mn"&A$]は不可。
    例) VAL(c$)+7 のc$に[-2.5],[$=str$(1/2-3)]など入力可(-2.5は"-2.5"という文字列定数)。

(6) 部分文字列指定
   文字列変数に部分文字列指定ができる。
   ただし部分文字列指定より前に,同名の文字列変数が書かれている必要がある。
    例) $=a$&","&a$(3:5) ; $=UCASE$(cap$&"aBc")∩$(2:2-1+m) ; POS(r$,r$(k:k))
    誤入力例) $=box$(2:4)&","&box$
    修正例) $=REPEAT$(box$,0)&box$(2:4)&","&box$ ; $=SUBSTR$(box$,2,4)&","&box$

(7) ユーザー定義関数
   数値式に独自に定義した関数を使えるようにした。
   関数名は F1(a)、F2(a,b)、F3(a,b,c)、FS$(a$,b,c)。
   変数への入力にも使える。 例) SQR(r-4)+1 のrに[2*F2(3,7-5)]など入力可。
   この関数の定義部は1260行の後ろにあるので必要に応じて変更して下さい。再帰呼び出しも可能です。

入力例(関数名,変数名は大文字と小文字の区別はしない)
  2*.43+7E2  ;  MOD(10^2,int(MAX(7.4,sqr(10)+3)))-1  ;  sin(a)^2+cos(b)^2
  2*x^2-7*x+6  ;  1+INT(RND*n)  ;  INT(借入金*(1+年利/100)^年数)  ;  LEN("ab""cd ef gh")
  $=mj$&"xYz"&STR$(n)  ;  $=UCASE$(p$)&","&LCASE$(p$)  ;  $="0x"&BSTR$(Decimal,16)
  $=STR$(1/(2*a)*(-b+sqr(b^2-4*a*c)))&","&STR$((-b-sqr(b^2-4*a*c))/(2*a)) !2次方程式の2根
  $="a="&STR$(abs(m^2-n^2))&",b="&STR$(2*m*n)&",c="&STR$(m^2+n^2) !ピタゴラス数
  $=enter$&TIME$&USING$(".#",FP(TIME))  ;  m*f3(N-5,4,sqr(M))  ;  $=FS$("abc",x,6)&"."

目標としたのは「PRINT *******」で出力できる数値式、文字列式を網羅することでした。
配列以外は達成できたと思うのですがどうでしょう。
すべてをチェックしているわけでなく間違った数値式を入力してもエラー表示されないかもしれません。
不具合があれば報告お願いします。
REM 十進BASIC添付"\BASICw32\SAMPLE\INTERPRE.bas"に加筆
REM 行番号のない行が加筆部分。行番号は削除可。
1000 REM Full BASICのモジュールの使い方を示すサンプル
1010 REM
1020 REM 数値式の評価を行う
1030 REM 組込み関数は，SIN，COS，TAN, LOG, EXP, SQR, INT，ABSとPIのみ
1040 REM 大文字と小文字の区別はしない
1050 REM 数値式の文法はほぼFull BASICに準ずるが，関数名に続く括弧は空白を入れずに書く。
1060 REM 数値は，数字で始まり，コンマを1個以下含む数字の列としてのみ書ける。
1070 REM 零除算エラーなどは考慮していない。
1080 DECLARE EXTERNAL FUNCTION interpreter.expression  ! 数値式を評価する関数
1090 DECLARE EXTERNAL STRING interpreter.s$            ! 入力行
1100 DECLARE EXTERNAL NUMERIC interpreter.i            ! 入力行の文字位置
1110 DECLARE EXTERNAL SUB interpreter.skip             ! 空白文字を読み飛ばす副プログラム
     DECLARE EXTERNAL FUNCTION interpreter.str_expression$  !文字列式を評価する関数
     DECLARE EXTERNAL NUMERIC interpreter.vc,interpreter.sc !変数の個数(vc=数値,sc=文字列)
     DECLARE EXTERNAL SUB interpreter.error                 !エラーメッセージ
1120 LINE INPUT s$
1130 ! LET s$=UCASE$(s$) !文字列の小文字保持のため無効にした
     DO
        LET vc,sc=0
1140    LET i=1
1150    CALL skip
        IF s$(i:i)="$" THEN
           LET i=i+1
           CALL skip
           IF s$(i:i)="=" THEN
              LET i=i+1
              CALL skip
              PRINT str_expression$   ! 文字列式評価
           ELSE
              CALL error("$=")
           END IF
        ELSE
1160       PRINT expression   ! 数値式評価
        END IF
1170    IF i<>LEN(s$)+1 THEN PRINT "Syntax error" ! 比較式をi<LEN(s$)から変更
     LOOP UNTIL vc+sc=0 OR i<>LEN(s$)+1 ! 中止は[中止]ボタンで
1180 END
1190 !
1200 MODULE interpreter
  ! MODULE OPTION ARITHMETIC NATIVE ! DECIMAL_HIGH,COMPLEX,RATIONAL 数値オプション
1210 PUBLIC STRING s$
1220 PUBLIC NUMERIC i
1230 PUBLIC FUNCTION expression
1240 PUBLIC SUB skip
1250 SHARE FUNCTION term,factor,primary,numeric
     PUBLIC FUNCTION str_expression$
     PUBLIC NUMERIC vc,sc
     PUBLIC SUB error
     SHARE FUNCTION check,argument,rounding,position,bitval,v_chr,variable
     SHARE FUNCTION str_primary$,str_constant$,str_naming$,sub_string$,str_input$,bitstr$
     SHARE NUMERIC vari_val(20),inputv   ! 20=変数の個数
     SHARE STRING sn$,vari_name$(20),string$(20),str_name$(20)
     SHARE FUNCTION F1,F2,F3,FS$  !!! ユーザー定義関数
     ! MODULE OPTION ANGLE DEGREES  ! 角の大きさの単位
     ! MODULE OPTION CHARACTER BYTE ! 文字列処理の単位
     LET inputv=0
1260 !
     EXTERNAL FUNCTION F1(a)      !!! ユーザー定義関数
        let F1=a
     END FUNCTION
     EXTERNAL FUNCTION F2(a,b)    !!! ユーザー定義関数
        let F2=a+b
     END FUNCTION
     EXTERNAL FUNCTION F3(a,b,c)  !!! ユーザー定義関数
        let F3=a+b+c
     END FUNCTION
     EXTERNAL FUNCTION FS$(a$,b,c)  !!! ユーザー定義関数
        let FS$=a$&str$(b)&str$(c)
     END FUNCTION
     !
1270 EXTERNAL SUB skip
1280    DO WHILE s$(i:i)=" "
1290       LET i=i+1
1300    LOOP
1310 END SUB
1320 !
1330 EXTERNAL FUNCTION expression
1340    DECLARE NUMERIC n
1350    DECLARE STRING op$
1360    SELECT CASE s$(i:i)
1370    CASE "-"
1380       LET i=i+1
1390       CALL skip
1400       LET n=-term
1410    CASE "+"
1420       LET i=i+1
1430       CALL skip
1440       LET n=term
1450    CASE ELSE
1460       LET n=term
1470    END SELECT
1480    DO WHILE s$(i:i)="+" OR s$(i:i)="-"
1490       LET op$=s$(i:i)
1500       LET i=i+1
1510       CALL skip
1520       IF op$="+" THEN LET n=n+term ELSE LET n=n-term
1530    LOOP
1540    LET expression =n
1550    CALL skip
1560 END FUNCTION
1570 !
1580 EXTERNAL FUNCTION term
1590    DECLARE NUMERIC n
1600    DECLARE STRING op$
1610    LET n=factor
1620    DO WHILE s$(i:i)="*" OR s$(i:i)="/"
1630       LET op$=s$(i:i)
1640       LET i=i+1
1650       CALL skip
1660       IF op$="*" THEN LET n=n*factor ELSE LET n=n/factor
1670    LOOP
1680    LET term=n
1690 END FUNCTION
1700 !
1710 EXTERNAL FUNCTION factor
1720    DECLARE NUMERIC n
1730    LET n=primary
1740    DO WHILE s$(i:i)="^"
1750       LET i=i+1
1760       CALL skip
1770       LET n=n^primary
1780    LOOP
1790    LET factor=n
1800 END FUNCTION
1810 !
1820 EXTERNAL FUNCTION primary
1830    IF s$(i:i)>="0" AND s$(i:i)<="9" THEN
1840       LET  primary=numeric
        ELSEIF s$(i:i)="." THEN
           LET  primary=numeric
1850    ELSEIF UCASE$(s$(i:i+1))="PI" AND check(s$(i+2:i+2))=1 THEN ! 関数check加筆
1860       LET i=i+2
1870       CALL skip
1880       LET primary=PI  ! 有理数モード注意
        ELSEIF UCASE$(s$(i:i+2))="RND" AND check(s$(i+3:i+3))=1 THEN
           LET i=i+3
           CALL skip
           LET primary=RND ! 変数入力がある数値式では都度更新
        ELSEIF UCASE$(s$(i:i+3))="TIME" AND check(s$(i+4:i+4))=1 THEN
           LET i=i+4
           CALL skip
           LET primary=TIME ! 変数入力がある数値式では都度更新
        ELSEIF UCASE$(s$(i:i+3))="DATE" AND check(s$(i+4:i+4))=1 THEN
           LET i=i+4
           CALL skip
           LET primary=DATE ! 変数入力がある数値式では都度更新
           !ELSEIF UCASE$(s$(i:i+5))="MAXNUM" AND check(s$(i+6:i+6))=1 THEN
           !   LET i=i+6
           !   CALL skip
           !   LET primary=MAXNUM  ! 有理数モード不可
1890    ELSE
1900       IF s$(i:i)="(" THEN
1910          LET i=i+1
1920          CALL skip
1930          LET  primary=expression
           ELSEIF UCASE$(s$(i:i+2))="F1(" THEN   !!! ユーザー定義関数
              LET i=i+3
              CALL skip
              LET Primary=F1(expression)
           ELSEIF UCASE$(s$(i:i+2))="F2(" THEN   !!! ユーザー定義関数
              LET i=i+3
              CALL skip
              LET primary=F2(expression,argument)
           ELSEIF UCASE$(s$(i:i+2))="F3(" THEN   !!! ユーザー定義関数
              LET i=i+3
              CALL skip
              LET primary=F3(expression,argument,argument)
1940       ELSEIF UCASE$(s$(i:i+3))="SIN(" THEN ! 超越関数
1950          LET i=i+4
1960          CALL skip
1970          LET Primary=SIN(expression)
1980       ELSEIF UCASE$(s$(i:i+3))="COS(" THEN ! 超越関数
1990          LET i=i+4
2000          CALL skip
2010          LET Primary=COS(expression)
2020       ELSEIF UCASE$(s$(i:i+3))="TAN(" THEN ! 超越関数
2030          LET i=i+4
2040          CALL skip
2050          LET Primary=TAN(expression)
2060       ELSEIF UCASE$(s$(i:i+3))="LOG(" THEN ! 超越関数
2070          LET i=i+4
2080          CALL skip
2090          LET Primary=LOG(expression)
2100       ELSEIF UCASE$(s$(i:i+3))="EXP(" THEN ! 超越関数
2110          LET i=i+4
2120          CALL skip
2130          LET Primary=EXP(expression)
2140       ELSEIF UCASE$(s$(i:i+3))="SQR(" THEN ! 有理数モード注意
2150          LET i=i+4
2160          CALL skip
2170          LET Primary=SQR(expression)
2180       ELSEIF UCASE$(s$(i:i+3))="INT(" THEN
2190          LET i=i+4
2200          CALL skip
2210          LET Primary=INT(expression)
2220       ELSEIF UCASE$(s$(i:i+3))="ABS(" THEN
2230          LET i=i+4
2240          CALL skip
2250          LET Primary=ABS(expression)
           ELSEIF UCASE$(s$(i:i+3))="MOD(" THEN
              LET i=i+4
              CALL skip
              LET primary=MOD(expression,argument)
           ELSEIF UCASE$(s$(i:i+5))="ROUND(" THEN
              LET i=i+6
              CALL skip
              LET primary=rounding
           ELSEIF UCASE$(s$(i:i+4))="CEIL(" THEN
              LET i=i+5
              CALL skip
              LET Primary=CEIL(expression)
           ELSEIF UCASE$(s$(i:i+3))="SGN(" THEN
              LET i=i+4
              CALL skip
              LET Primary=SGN(expression)
           ELSEIF UCASE$(s$(i:i+2))="IP(" THEN
              LET i=i+3
              CALL skip
              LET Primary=IP(expression)
           ELSEIF UCASE$(s$(i:i+2))="FP(" THEN
              LET i=i+3
              CALL skip
              LET Primary=FP(expression)
           ELSEIF UCASE$(s$(i:i+9))="REMAINDER(" THEN
              LET i=i+10
              CALL skip
              LET primary=REMAINDER(expression,argument)
           ELSEIF UCASE$(s$(i:i+8))="TRUNCATE(" THEN
              LET i=i+9
              CALL skip
              LET primary=TRUNCATE(expression,argument)
           ELSEIF UCASE$(s$(i:i+4))="LOG2(" THEN ! 超越関数
              LET i=i+5
              CALL skip
              LET Primary=LOG2(expression)
           ELSEIF UCASE$(s$(i:i+5))="LOG10(" THEN ! 超越関数
              LET i=i+6
              CALL skip
              LET Primary=LOG10(expression)
           ELSEIF UCASE$(s$(i:i+3))="CSC(" THEN ! 超越関数
              LET i=i+4
              CALL skip
              LET Primary=CSC(expression)
           ELSEIF UCASE$(s$(i:i+3))="SEC(" THEN ! 超越関数
              LET i=i+4
              CALL skip
              LET Primary=SEC(expression)
           ELSEIF UCASE$(s$(i:i+3))="COT(" THEN ! 超越関数
              LET i=i+4
              CALL skip
              LET Primary=COT(expression)
           ELSEIF UCASE$(s$(i:i+4))="ASIN(" THEN ! 超越関数
              LET i=i+5
              CALL skip
              LET Primary=ASIN(expression)
           ELSEIF UCASE$(s$(i:i+4))="ACOS(" THEN ! 超越関数
              LET i=i+5
              CALL skip
              LET Primary=ACOS(expression)
           ELSEIF UCASE$(s$(i:i+3))="ATN(" THEN ! 超越関数
              LET i=i+4
              CALL skip
              LET Primary=ATN(expression)
           ELSEIF UCASE$(s$(i:i+5))="ANGLE(" THEN ! 超越関数
              LET i=i+6
              CALL skip
              LET primary=ANGLE(expression,argument)
           ELSEIF UCASE$(s$(i:i+4))="SINH(" THEN ! 超越関数
              LET i=i+5
              CALL skip
              LET Primary=SINH(expression)
           ELSEIF UCASE$(s$(i:i+4))="COSH(" THEN ! 超越関数
              LET i=i+5
              CALL skip
              LET Primary=COSH(expression)
           ELSEIF UCASE$(s$(i:i+4))="TANH(" THEN ! 超越関数
              LET i=i+5
              CALL skip
              LET Primary=TANH(expression)
              !ELSEIF UCASE$(s$(i:i+3))="EPS(" THEN ! 有理数モード不可
              !   LET i=i+4
              !   CALL skip
              !   LET Primary=EPS(expression)
           ELSEIF UCASE$(s$(i:i+3))="DEG(" THEN
              LET i=i+4
              CALL skip
              LET Primary=DEG(expression)
           ELSEIF UCASE$(s$(i:i+3))="RAD(" THEN
              LET i=i+4
              CALL skip
              LET Primary=RAD(expression)
           ELSEIF UCASE$(s$(i:i+3))="MAX(" THEN
              LET i=i+4
              CALL skip
              LET primary=MAX(expression,argument)
           ELSEIF UCASE$(s$(i:i+3))="MIN(" THEN
              LET i=i+4
              CALL skip
              LET primary=MIN(expression,argument)
           ELSEIF UCASE$(s$(i:i+4))="FACT(" THEN !十進BASIC独自拡張
              LET i=i+5
              CALL skip
              LET Primary=FACT(expression)
           ELSEIF UCASE$(s$(i:i+4))="PERM(" THEN !十進BASIC独自拡張
              LET i=i+5
              CALL skip
              LET primary=PERM(expression,argument)
           ELSEIF UCASE$(s$(i:i+4))="COMB(" THEN !十進BASIC独自拡張
              LET i=i+5
              CALL skip
              LET primary=COMB(expression,argument)
           ELSEIF UCASE$(s$(i:i+10))="COLORINDEX(" THEN !十進BASIC独自拡張
              LET i=i+11
              CALL skip
              LET primary=COLORINDEX(expression,argument,argument)
              !ELSEIF UCASE$(s$(i:i+7))="COMPLEX(" THEN !複素関数
              !   LET i=i+8
              !   CALL skip
              !   LET primary=COMPLEX(expression,argument)
              !ELSEIF UCASE$(s$(i:i+2))="RE(" THEN      !複素関数
              !   LET i=i+3
              !   CALL skip
              !   LET Primary=RE(expression)
              !ELSEIF UCASE$(s$(i:i+2))="IM(" THEN      !複素関数
              !   LET i=i+3
              !   CALL skip
              !   LET Primary=IM(expression)
              !ELSEIF UCASE$(s$(i:i+4))="CONJ(" THEN    !複素関数
              !   LET i=i+5
              !   CALL skip
              !   LET Primary=CONJ(expression)
              !ELSEIF UCASE$(s$(i:i+3))="ARG(" THEN     !複素関数
              !   LET i=i+4
              !   CALL skip
              !   LET Primary=ARG(expression)
              !ELSEIF UCASE$(s$(i:i+5))="NUMER(" THEN   !有理数モード専用
              !   LET i=i+6
              !   CALL skip
              !   LET Primary=NUMER(expression)
              !ELSEIF UCASE$(s$(i:i+5))="DENOM(" THEN   !有理数モード専用
              !   LET i=i+6
              !   CALL skip
              !   LET Primary=DENOM(expression)
              !ELSEIF UCASE$(s$(i:i+3))="GCD(" THEN     !有理数モード専用
              !   LET i=i+4
              !   CALL skip
              !   LET primary=GCD(expression,argument)
              !ELSEIF UCASE$(s$(i:i+6))="INTSQR(" THEN  !有理数モード専用
              !   LET i=i+7
              !   CALL skip
              !   LET Primary=INTSQR(expression)
              !ELSEIF UCASE$(s$(i:i+7))="INTLOG2(" THEN !有理数モード専用
              !   LET i=i+8
              !   CALL skip
              !   LET Primary=INTLOG2(expression)
           ELSEIF UCASE$(s$(i:i+3))="LEN(" THEN
              LET i=i+4
              CALL skip
              LET primary=LEN(str_expression$)
           ELSEIF UCASE$(s$(i:i+3))="POS(" THEN
              LET i=i+4
              CALL skip
              LET primary=position
           ELSEIF UCASE$(s$(i:i+3))="VAL(" THEN
              LET i=i+4
              CALL skip
              LET primary=VAL(str_expression$)
           ELSEIF UCASE$(s$(i:i+3))="ORD(" THEN
              LET i=i+4
              CALL skip
              LET primary=ORD(str_expression$)
           ELSEIF UCASE$(s$(i:i+4))="BVAL(" THEN
              LET i=i+5
              CALL skip
              LET primary=bitval
           ELSEIF UCASE$(s$(i:i+4))="BLEN(" THEN !十進BASIC独自拡張
              LET i=i+5
              CALL skip
              LET primary=BLEN(str_expression$)
           ELSEIF v_chr(s$(i:i))=1 THEN
              LET primary=variable    !  変数
              CALL skip
              EXIT FUNCTION
2260       ELSE
              CALL error("FUNCTION primary")
2270          PRINT "Syntax error"
2280          STOP
2290       END IF
2300       IF s$(i:i)=")" THEN
2310          LET i=i+1
2320          CALL skip
2330       ELSE
              CALL error("FUNCTION primary")
2340          PRINT "Syntax error"
2350          STOP
2360       END IF
2370    END IF
2380 END FUNCTION
2390 !
2400 EXTERNAL FUNCTION numeric
2410    DECLARE NUMERIC i0
2420    CALL skip
2430    LET i0=i
        IF s$(i:i)="." THEN ! 小数点で始まる
           LET i=i+1
        ELSE
2440       DO WHILE s$(i:i)>="0" AND s$(i:i)<="9"
2450          LET i=i+1
2460       LOOP
2470       IF s$(i:i)="." THEN LET i=i+1
        END IF
2480    DO WHILE s$(i:i)>="0" AND s$(i:i)<="9"
2490       LET i=i+1
2500    LOOP
        IF LEN(s$)>=i AND UCASE$(s$(i:i))="E" THEN ! 指数部
           LET i=i+1
           IF s$(i:i)="+" OR s$(i:i)="-" THEN LET i=i+1
           DO WHILE s$(i:i)>="0" AND s$(i:i)<="9"
              LET i=i+1
           LOOP
        END IF
2510    LET numeric=VAL(s$(i0:i-1))
2520    CALL skip
2530 END FUNCTION
2540 !
![その２]へ続く
 

Re: 数値式文字列式評価[その２]

 投稿者：荒田浩二  投稿日：2009年 2月14日(土)00時18分47秒 		返信・引用
  > No.276[元記事へ]

! [その２]
  !  *以下すべて加筆部分*
     EXTERNAL FUNCTION check(c$) !! 予約語の後続字
        DECLARE STRING p$
        LET check=-1
        DO
           READ IF MISSING THEN EXIT DO : p$
           IF c$=p$ THEN LET check=1
        LOOP
        DATA " " , "+" , "-" , "*" , "/" , "^" , "," , ")" , ""
     END FUNCTION
     !
     EXTERNAL FUNCTION argument !! 引数
        CALL skip
        IF s$(i:i)="," THEN
           LET i=i+1
           CALL skip
        ELSE
           CALL error("FUNCTION argument,引数")
        END IF
        LET argument=expression
     END FUNCTION
     !
     EXTERNAL FUNCTION rounding  !! 関数ROUNDの識別
        DECLARE NUMERIC a
        LET a=expression
        IF s$(i:i)="," THEN
           LET i=i+1
           CALL skip
           LET rounding=ROUND(a,expression)
        ELSEIF s$(i:i)=")" THEN
           LET rounding=ROUND(a) ! 十進BASIC独自拡張
        ELSE
           CALL error("FUNCTION rounding,関数ROUND")
        END IF
     END FUNCTION
     !
     EXTERNAL FUNCTION position  !! 関数POSの識別
        DECLARE STRING aa$,bb$
        LET aa$=str_expression$
        IF s$(i:i)="," THEN
           LET i=i+1
           CALL skip
           LET bb$=str_expression$
           IF s$(i:i)=")" THEN
              LET position=POS(aa$,bb$)
           ELSEIF s$(i:i)="," THEN
              LET i=i+1
              CALL skip
              LET position=POS(aa$,bb$,expression)
           ELSE
              CALL error("FUNCTION position,関数POS")
           END IF
        ELSE
           CALL error("FUNCTION position,関数POS")
        END IF
     END FUNCTION
     !
     EXTERNAL FUNCTION bitval   !! 関数BVALの識別
        DECLARE STRING aa$
        LET aa$=str_primary$
        IF s$(i:i)="," THEN
           LET i=i+1
           CALL skip
           IF s$(i:i)="2" THEN
              LET i=i+1
              CALL skip
              LET bitval=BVAL(aa$,2)
           ELSEIF s$(i:i+1)="16" THEN
              LET i=i+2
              CALL skip
              LET bitval=BVAL(aa$,16)
           ELSE
              CALL error("FUNCTION bitval,関数BVAL")
           END IF
        ELSE
           CALL error("FUNCTION bitval,関数BVAL")
        END IF
     END FUNCTION
     !
     EXTERNAL FUNCTION v_chr(c$)   !! 変数名文字
        IF c$>="A" AND c$<="Z" OR c$>="a" AND c$<="z" OR c$>="ぁ" THEN !先頭文字及びそれ以降
           LET v_chr=1
        ELSEIF c$>="0" AND c$<="9" OR c$="_" OR c$>="０" THEN ! 2文字目以降
           LET v_chr=2
        ELSE
           LET v_chr=-1
        END IF
     END FUNCTION
     !
     EXTERNAL FUNCTION variable   !! 変数
        DECLARE NUMERIC j,vi
        DECLARE STRING vn$,aa$,vs$
        LET vn$=""
        DO WHILE v_chr(s$(i:i))>=1
           LET vn$=vn$&s$(i:i)
           LET i=i+1
        LOOP
        FOR j=1 TO vc
           IF UCASE$(vn$)=UCASE$(vari_name$(j)) THEN
              LET variable=vari_val(j)  ! 既出の変数
              EXIT FUNCTION
           END IF
        NEXT j
        LET vc=vc+1
        LET vari_name$(vc)=vn$
        IF inputv=0 THEN
           DO
              LINE INPUT PROMPT vn$&"=" : aa$ ! 変数への入力
           LOOP UNTIL aa$<>""
        ELSE
           CALL error("FUNCTION variable,変数入力")
        END IF
        LET vs$=s$
        LET vi=i
        LET s$=LTRIM$(aa$)
        LET i=1
        LET inputv=1
        LET vari_val(vc)=expression ! 変数に入力した数値式の処理
        LET inputv=0
        LET s$=vs$
        LET i=vi
        LET variable=vari_val(vc)
     END FUNCTION
     !
     !
     EXTERNAL FUNCTION str_expression$ !! 文字列式
        DECLARE STRING str_n$
        LET str_n$=str_primary$
        DO WHILE s$(i:i)="&"
           LET i=i+1
           CALL skip
           LET str_n$=str_n$&str_primary$
        LOOP
        LET str_expression$ =str_n$
        CALL skip
     END FUNCTION
     !
     EXTERNAL FUNCTION str_primary$ !! 文字列一次子
        DECLARE NUMERIC j
        IF s$(i:i)="""" THEN
           LET i=i+1
           LET str_primary$=str_constant$
        ELSEIF UCASE$(s$(i:i+4))="DATE$" THEN
           LET i=i+5
           CALL skip
           LET str_primary$=DATE$  !変数入力がある数値式では都度更新
        ELSEIF UCASE$(s$(i:i+4))="TIME$" THEN
           LET i=i+5
           CALL skip
           LET str_primary$=TIME$  !変数入力がある数値式では都度更新
        ELSE
           IF v_chr(s$(i:i))=1 THEN
              LET sn$=str_naming$ ! 文字列関数/変数名
              FOR j=1 TO sc
                 IF UCASE$(sn$)=UCASE$(str_name$(j)) THEN
                    CALL skip
                    IF s$(i:i)="(" THEN
                       LET i=i+1
                       CALL skip
                       LET str_primary$=sub_string$(string$(j)) !部分文字列
                    ELSE
                       LET str_primary$=string$(j)  ! 既出の文字列変数
                    END IF
                    EXIT FUNCTION
                 END IF
              NEXT j
           ELSE
              CALL error("FUNCTION str_primary$,文字列一次子")
           END IF
           SELECT CASE UCASE$(sn$)&s$(i:i)
           CASE "FS$("    !!! ユーザー定義関数
              LET i=i+1
              CALL skip
              LET str_primary$=FS$(str_expression$,argument,argument)
           CASE "REPEAT$("
              LET i=i+1
              CALL skip
              LET str_primary$=REPEAT$(str_expression$,argument)
           CASE "STR$("
              LET i=i+1
              CALL skip
              LET str_primary$=STR$(expression)
           CASE "USING$("
              LET i=i+1
              CALL skip
              LET str_primary$=USING$(str_expression$,argument)
           CASE "CHR$("
              LET i=i+1
              CALL skip
              LET str_primary$=CHR$(expression)
           CASE "LCASE$("
              LET i=i+1
              CALL skip
              LET str_primary$=LCASE$(str_expression$)
           CASE "UCASE$("
              LET i=i+1
              CALL skip
              LET str_primary$=UCASE$(str_expression$)
           CASE "LTRIM$("
              LET i=i+1
              CALL skip
              LET str_primary$=LTRIM$(str_expression$)
           CASE "RTRIM$("
              LET i=i+1
              CALL skip
              LET str_primary$=RTRIM$(str_expression$)
           CASE "BSTR$("
              LET i=i+1
              CALL skip
              LET str_primary$=bitstr$
           CASE "SUBSTR$(" ! 十進BASIC独自拡張
              LET i=i+1
              CALL skip
              LET str_primary$=SUBSTR$(str_expression$,argument,argument)
           CASE "MID$("    ! 十進BASIC独自拡張
              LET i=i+1
              CALL skip
              LET str_primary$=MID$(str_expression$,argument,argument)
           CASE "LEFT$("   ! 十進BASIC独自拡張
              LET i=i+1
              CALL skip
              LET str_primary$=LEFT$(str_expression$,argument)
           CASE "RIGHT$("  ! 十進BASIC独自拡張
              LET i=i+1
              CALL skip
              LET str_primary$=RIGHT$(str_expression$,argument)
           CASE ELSE
              LET str_primary$=str_input$ ! 文字列入力
              CALL skip
              EXIT FUNCTION
           END SELECT
           IF s$(i:i)=")" THEN
              LET i=i+1
              CALL skip
           ELSE
              CALL error("FUNCTION str_primary$")
           END IF
        END IF
     END FUNCTION
     !
     EXTERNAL FUNCTION str_constant$  !! 文字列定数
        DECLARE STRING cc$
        LET cc$=""
        DO
           IF s$(i:i)="""" THEN
              IF s$(i+1:i+1)="""" THEN ! [""]の識別
                 LET cc$=cc$&s$(i:i)
                 LET i=i+2
              ELSE
                 LET i=i+1
                 EXIT DO
              END IF
           ELSE
              LET cc$=cc$&s$(i:i)
              LET i=i+1
              IF i>LEN(s$)+1 THEN
                 CALL error("FUNCTION str_constant$,文字列定数")
                 EXIT DO
              END IF
           END IF
        LOOP
        CALL skip
        LET str_constant$=cc$
     END FUNCTION
     !
     EXTERNAL FUNCTION str_naming$ !! 文字列関数/変数名
        LET sn$=""
        DO WHILE v_chr(s$(i:i))>=1
           LET sn$=sn$&s$(i:i)
           LET i=i+1
        LOOP
        IF s$(i:i)="$" THEN
           LET str_naming$=sn$&s$(i:i)
           LET i=i+1
        ELSE
           CALL error("FUNCTION str_naming$,文字列関数/変数名")
        END IF
     END FUNCTION
     !
     EXTERNAL FUNCTION sub_string$(ss$)  !! 部分文字列
        DECLARE NUMERIC a
        LET a=expression
        IF s$(i:i)=":" THEN
           LET i=i+1
           CALL skip
           LET sub_string$=ss$(a:expression)
           IF s$(i:i)=")" THEN
              LET i=i+1
              CALL skip
           ELSE
              CALL error("FUNCTION sub_string$,部分文字列")
           END IF
        ELSE
           CALL error("FUNCTION sub_string$,部分文字列")
        END IF
     END FUNCTION
     !
     EXTERNAL FUNCTION str_input$  !! 文字列入力
        DECLARE NUMERIC j,vi
        DECLARE STRING vs$
        LET sc=sc+1
        LET str_name$(sc)=sn$
        IF inputv=0 THEN
           LINE INPUT PROMPT sn$&"=" : string$(sc)
        ELSE
           CALL error("FUNCTION str_input$,文字列入力")
        END IF
        LET j=1
        DO WHILE string$(sc)(j:j)=" "
           LET j=j+1
        LOOP
        IF string$(sc)(j:j)="$" THEN
           LET j=j+1
           DO WHILE string$(sc)(j:j)=" "
              LET j=j+1
           LOOP
           IF string$(sc)(j:j)="=" THEN
              LET vs$=s$
              LET vi=i
              LET s$=string$(sc)(j+1:LEN(string$(sc)))
              LET s$=LTRIM$(s$)
              LET i=1
              LET inputv=1
              LET string$(sc)=str_expression$ ! 文字列変数に入力した文字列式の処理
              LET inputv=0
              LET s$=vs$
              LET i=vi
           END IF
        END IF
        LET str_input$=string$(sc)
     END FUNCTION
     !
     EXTERNAL FUNCTION bitstr$   !! 関数BSTR$の識別
        DECLARE NUMERIC a
        LET a=expression
        IF s$(i:i)="," THEN
           LET i=i+1
           CALL skip
           IF s$(i:i)="2" THEN
              LET i=i+1
              CALL skip
              LET bitstr$=BSTR$(a,2)
           ELSEIF s$(i:i+1)="16" THEN
              LET i=i+2
              CALL skip
              LET bitstr$=BSTR$(a,16)
           ELSE
              CALL error("FUNCTION bitstr$,関数BSTR$")
           END IF
        ELSE
           CALL error("FUNCTION bitstr$,関数BSTR$")
        END IF
     END FUNCTION
     !
     EXTERNAL SUB error(e$)  !! エラー表示
        PRINT "Error (";e$;")"
        !STOP
     END SUB
     !
2550 END MODULE
 

伝達関数によるフィルタ回路の周波数解析、過渡解析

 投稿者：山中和義  投稿日：2009年 2月16日(月)11時47分59秒 		返信・引用
  ●伝達関数による周波数解析
OPTION ARITHMETIC COMPLEX

LET j=SQR(-1) !虚数単位

LET f=60 !周波数[Hz]
DEF w=2*PI*f !角周波数ω

SUB DispS(z) !複素数をS表示する　※スタインメッツ（Steinmetz）
   PRINT ABS(z);
   IF ABS(z)<>0 THEN
      IF arg(z)<>0 THEN PRINT "∠";DEG(arg(z));"°";
   END IF
   PRINT
END SUB
!-------------------- ここまでがサブルーチン


!---------- ↓↓↓↓↓ ----------
LET xmax=6 !<----- ※要調整
LET ymin=-50
LET ymax=5


!●回路図　CRローパス・フィルタ
!vi・─R1┬─・vo
!　　　　C1
!　　　  │
!　　　　≡
!　参考サイト　http://sim.okawa-denshi.jp/CRlowkeisan.htm

LET R1=1.6e3 !1.6k[Ω]
LET C1=0.1e-6 !0.1μ[F]

DEF G(s)=1/(s*C1*R1+1) !入出力システムの伝達関数　G(s)=Vo/Vi=(1/(C1*R1))/(s+1/(C1*R1))
!---------- ↑↑↑↑↑ ----------


!!!SET bitmap SIZE 600,600 !画面を大きくする
SET WINDOW -0.5,xmax+0.5, ymin,ymax !表示領域
DRAW grid(1,5) !左端の目盛り

FOR f=1 TO xmax !ｘ軸が対数
   PLOT TEXT ,AT f-0.3,-0.15: mid$("10  100 1k  10k 100k1M  10M 100M",4*(f-1)+1,4)
NEXT f

FOR xx=0 TO xmax STEP 0.025 !周波数[Hz]
   LET f=10^xx !xx=LOG10(f)
   LET t=ABS(G(j*w))
   PLOT LINES: xx,20*LOG10(t); !利得[dB]
NEXT xx
PLOT LINES


SET TEXT COLOR 2
FOR k=ymax TO ymin STEP -5 !右端の縦軸目盛り
   PLOT TEXT ,AT xmax,k: STR$(k*2)&"°" !※利得のグラフに合わせるために2倍する
NEXT k

SET LINE COLOR 2
FOR xx=0 TO xmax STEP 0.05 !周波数[Hz]
   LET f=10^xx
   LET th=arg(G(j*w))
   IF th>0 THEN LET th=th-2*PI !0〜-2πへ補正する　<----- ※要調整
   PLOT LINES: xx,DEG(th)/2; !位相θ[deg]　※利得のグラフに合わせるために1/2倍する
NEXT xx
PLOT LINES


END


●伝達関数による過渡解析
OPTION ARITHMETIC COMPLEX

DECLARE EXTERNAL SUB IFFT !逆フーリエ変換

DEF C(s)=G(s)*R(s) !応答関数
DEF R(s)=1/s !指令関数　※ステップ関数

LET Vi=1 !1∠0°[V]　※仮の電圧源


!----- ↓↓↓↓↓ -----
LET T=2e-3 !時間区間 [0,T]


!●回路図　CRローパス・フィルタ
!vi・─R1┬─・vo
!　　　　C1
!　　　  │
!　　　　≡
!　参考サイト　http://sim.okawa-denshi.jp/CRlowkeisan.htm

LET R1=1.6e3 !1.6k[Ω]
LET C1=0.1e-6 !0.1μ[F]

DEF G(s)=1/(s*C1*R1+1) !入出力システムの伝達関数　G(s)=Vo/Vi=(1/(C1*R1))/(s+1/(C1*R1))
!----- ↑↑↑↑↑ -----


!逆ラプラス変換
! f(t)=lim [ω→∞] { 1/(2π*j)∫F(s)*Exp(s*t)ds [γ-j*ω,γ+j*ω] }、jは虚数単位、γ>0とωは実数。
!s=γ+j*2πωとすると、ds=j*2πdω。
!これを上式に代入して、変形すると、
! f(t)=Exp(γt)∫F(γ,ω)*Exp(j*2πω)dω [-∞,∞]
!右辺の積分部分は逆フーリエ変換。

LET N=1024*8 !データ総数　※２のべき乗、大きいほど精度がよい
DIM d(0 TO N-1) !入出力用配列

LET Gamma=5 !※3〜7
!γを大きくすれば精度は上がりそうだが、
!あとでExp(γt)をかけるので、tが大きいところで発散する。

LET rr=Gamma/T !γを決める

FOR k=0 TO N/2 !変換データの作成
   LET Cs=C( COMPLEX(rr, 2*PI*k/T) ) !sk=γ+j*2π*k/T、k=0〜n-1
   LET Hw=(COS(2*PI*k/N)+1)/2 !データは離散なため、ハニング関数をかけて平滑化する　※精度の向上
   LET d(k)=N/T*Cs*Hw !n/T*Y(k) * Hw　0〜N/2

   IF NOT(k=0 OR k=N/2) THEN LET d(N-k)=COMPLEX(Re(d(k)),-Im(d(k))) !N-1〜N/2+1は、共役複素数
NEXT k


CALL IFFT(d) !高速逆フーリエ変換


SET WINDOW -T/8,T,-Vi*1.2,Vi*1.2 !表示領域
DRAW grid(T/4,Vi/5)

PLOT TEXT ,AT T*7/8,0: "[秒]"

LET dt=T/N !時間刻み幅 ��t

FOR k=0 TO N-1 STEP 8 !結果の表示 [0,T]
   LET tt=k*dt !経過時間
   PLOT LINES: tt, Re(d(k))*EXP(rr*tt); !Exp(γt)をかける　※Exp(γ*k*T/n)、k=0〜n-1
   PRINT Re(d(k))*EXP(rr*tt) !debug
NEXT k


END



EXTERNAL SUB IFFT(x()) !高速逆フーリエ変換　x() : 入力/出力データ
OPTION ARITHMETIC COMPLEX
DECLARE EXTERNAL SUB FFTMAIN
LET nx=SIZE(x)
LET theta=2*PI/nx ! W = Exp(-j * 2π/N * -1) = Exp(j * theta)とする
CALL FFTMAIN(x, theta)
MAT x=(1/nx)*x
END SUB

EXTERNAL SUB FFTMAIN(x(), theta)
OPTION ARITHMETIC COMPLEX
LET nx=SIZE(x)
IF MOD(nx, 2)<>0 THEN !DFTの計算
   DIM w(0 TO nx-1), xtmp(0 TO nx-1)
   MAT xtmp=x
   FOR k=0 TO nx-1
      LET tmp=theta*k
      FOR n=0 TO nx-1
         LET w(n)=EXP( COMPLEX(0, tmp*n) )
      NEXT n
      LET x(k)=DOT(w, xtmp)
   NEXT k
ELSE !２分して再帰呼出し
   LET hnx=nx/2
   DIM x0(0 TO hnx-1), x1(0 TO hnx-1)
   FOR k=0 TO hnx-1
      LET x0(k)=x(k)+x(k+hnx)
      LET wk=EXP( COMPLEX(0, theta*k) )
      LET x1(k)=wk*(x(k)-x(k+hnx))
   NEXT k
   CALL FFTMAIN(x0, 2*theta)
   CALL FFTMAIN(x1, 2*theta)
   FOR k=0 TO hnx-1
      LET x(2*k)=x0(k)
      LET x(2*k+1)=x1(k)
   NEXT k
END IF
END SUB
 

Re: 伝達関数によるフィルタ回路の周波数解析、過渡解析

 投稿者：山中和義  投稿日：2009年 2月16日(月)14時51分17秒 		返信・引用 　編集済
  > No.278[元記事へ]

伝達関数は、閉路方程式や節点方程式などで記述された連立方程式から導かれる。

差し替え
!●回路図　CRローパス・フィルタ
!vi・─R1┬─・vo
!　　　　C1
!　　　  │
!　　　　≡
!　参考サイト　http://sim.okawa-denshi.jp/CRlowkeisan.htm

LET R1=1.6e3 !1.6k[Ω]
LET C1=0.1e-6 !0.1μ[F]

DEF G(s)=1/(s*C1*R1+1) !入出力システムの伝達関数　G(s)=Vo/Vi=(1/(C1*R1))/(s+1/(C1*R1))
!---------- ↑↑↑↑↑ ----------


この箇所を下記のプログラムに置き換える。

LET Vi=1 !1∠0°[V]　※仮の電圧源

FUNCTION Laplace(e$,Z,s) !ラプラス変換
   SELECT CASE UCASE$(e$)
   CASE "R"
      LET Laplace=Z !R*i(t)
   CASE "L"
      LET Laplace=s*Z !L*d{i(t)}/dt
   CASE "C"
      LET Laplace=1/(s*Z) !1/C*∫{i(t)}dt
   CASE ELSE
      PRINT "未サポートの素子です。"
      STOP
   END SELECT
END FUNCTION


!●回路図　CRローパス・フィルタ
!　　　　a
!vi・─R1┬─・vo
!　　　　C2
!　　　  │
!　　　　≡
!　参考サイト　http://sim.okawa-denshi.jp/CRlowkeisan.htm

!----- ↓↓↓↓↓ -----
LET M=2 !素子の数
!----- ↑↑↑↑↑ -----

DIM A(M,M),x(M),b(M) !A*x=b　※Z(s)*I(s)=E(s)
DIM iA(M,M)

FUNCTION G(s) !伝達関数
   MAT A=ZER !A(式の番号,素子の番号)　※下記の設定で０は省略するため、あらかじめ０を入れておく
   MAT b=ZER !b(式の番号)　※電流または電圧の和

   !---------- ↓↓↓↓↓ ----------
   LET R1=Laplace("R",1.6e3,s) !1.6k[Ω]
   LET C2=Laplace("C",0.1e-6,s) !0.1μ[F]


   !キルヒホッフの電流則
   LET A(1,1)=1 !節点a　i1(t)-i2(t)=0　⇒　I1(s)-I2(s)=0
   LET A(1,2)=-1

   !キルヒホッフの電圧則
   LET A(2,1)=R1 !網目　R1*i1(t) +1/C2*∫i2(t)dt =Vi(t)　⇒　R1*I1(s)+1/(s*C2)*I2(s)=Vi(s)
   LET A(2,2)=C2
   LET b(2)=Vi
   !---------- ↑↑↑↑↑ ----------

   MAT iA=INV(A)
   MAT x=iA*b !各素子の電流I(s)を求める
   !!!mat print x


   !---------- ↓↓↓↓↓ ----------
   LET Vo=C2*x(2) ! Vo(t)=1/C2*∫i2(t)dt　⇒　Vo(s)=1/(s*C2)*I2(s)
   !---------- ↑↑↑↑↑ ----------

   LET G=Vo/Vi
END FUNCTION
!---------- ↑↑↑↑↑ ----------
 

Re: コンデンサと、抵抗だけ？（２）

 投稿者：SECOND  投稿日：2009年 2月17日(火)03時16分38秒 		返信・引用 　編集済
  > No.273[元記事へ]

＜＜補足事項＞＞
”計算上は、１周ループの伝達関数（出力／入力）を複素数で求め、
（実数部＝１、虚数部＝０）になる条件で、解としている・・・　”について、

自分で計算したものでは、ありませんが、
該当の３段型ＣＲ昇圧回路の伝達関数です。( R =R1=R2=R3, C =C1=C2=C3 )

ZT(s)=(1+5*R*C*s+6*R^2*C^2*s^2)/(1+5*R*C*s+6*R^2*C^2*s^2 + R^3*C^3*c^3)←誤り
ZT(s)=(1+5*R*C*s+6*R^2*C^2*s^2)/(1+5*R*C*s+6*R^2*C^2*s^2 + R^3*C^3*s^3)←正(09/2/25)

-----------------------------------
以下は、我流の理解なため、間違いがあるかもしれません。参考程度に御容赦。

電圧で考える場合の、
伝達関数( 出力電圧／入力電圧 ) を求める時、ＬＣＲ素子のインピーダンスを、
sL, 1／sC , R
jωL, 1／jωC, R　　のどちらを用いて表現すると、何が解るかを、考えます。

sL　1／sC　 R　とする意味。（s=σ+jω の複素数）

　・・・回路電流を、I'(t)=(初期位相電流)*exp(st) に前提したときの、電圧降下の係数。

L の電圧降下＝　 L * dI'(t)/dt　=L*s*I'(t)　　　　　=　sL * I'(t)
C の電圧降下＝(1/C)* ∫ I'(t)dt　=(1/C)*(1/s )*I'(t) =(1/sC) * I'(t)
R の電圧降下＝　 R * I'(t)

jωL　1／jωC　R　とする意味。

　・・・回路電流を、I(t)=(初期位相電流)*exp(jωt) に前提したときの、電圧降下の係数。

L の電圧降下＝　 L * dI(t)/dt　=L*jω*I(t)　　　　 =　jωL * I(t)
C の電圧降下＝(1/C)* ∫ I(t)dt　=(1/C)*(1/jω)*I(t) =(1/jωC) * I(t)
R の電圧降下＝　 R * I(t)


-------- 発振回路の場合 -----------
これらのインピーダンスを用いて、電圧入出力の比（伝達関数）を作り、

伝達関数ZT() の入出力を接続し、ループを作ったときの状態を、次の式で表現します。
（ＯＰアンプも中に含めておく）
伝達関数ZT(s)=1
伝達関数ZT(jω)=1

この方程式から出てくる根ｓや、解のjωは、どんな意味を持つか。

外部入力の無い状態で、内部に回路電流
I'(t)=(初期位相電流)*exp(st)　又は、I(t)=(初期位相電流)*exp(jωt)

なる電流が、自立できる事を、意味します。ｓの実数部が正なら、角速度ωで発振です
伝達関数ZT()=1 の解 ｓ、jωは、(初期位相電流)については、何らの制限もしていません。

ここで、伝達関数ZT(jω)=1 の方は、解が無い可能性があります。

I(t)=(初期位相電流)*exp(jωt) なる
定常的な回路内電流を前提しているため、伝達関数ZT(jω)=1 は、初期値の自由度を除くと、
その解の電流は、１つの定常的な、波形電流だけです。

発振器のように、ループ内に、成長する振動電流が、時間と伴に発達しているなら、
ループ内電流を、(初期位相電流)*exp(jωt) 形式で、表現出来ないためでしょう。

-------------------------------------
１つの波形は、定常的な複数の単振動、(初期位相電流)*exp(jωt) が集まる合成波
ですから、
jωを、σ＋jωの様な、実数部σを持つ複素数ｓを用いて、
回路内電流を、I'(t)=(初期位相電流)*exp(st) に、前提すると、

各スペクトルは、独立にその振幅も変化させる事が出来、スペクトラムの時間変化を表現
する事が可能となり、２つの異なる波形への変遷が、記述出来るでしょう。
即ち、過渡的な電流波形をも、伝達関数ZT(s)=1 は、解として持てる事を、意味します。

これが、ｓを使用するインピーダンス概念が、ｊωより好まれ、優れている点です。
-------------------------------------

※現在、時間がキツイために、以上についての質問は、しないで下さい。すみません。 		 

Re: 伝達関数によるフィルタ回路の周波数解析、過渡解析

 投稿者：大熊　正  投稿日：2009年 2月17日(火)12時23分48秒 		返信・引用
  > No.279[元記事へ]

山中和義さんへのお返事です。

> 伝達関数は、閉路方程式や節点方程式などで記述された連立方程式から導かれる。
>
> 差し替え
>
> <PRE>
>
> !●回路図　CRローパス・フィルタ
> !vi・─R1┬─・vo
> !　　　　C1
> !　　　  │
> !　　　　≡
> !　参考サイト　http://sim.okawa-denshi.jp/CRlowkeisan.htm
>
> LET R1=1.6e3 !1.6k[Ω]
> LET C1=0.1e-6 !0.1μ[F]
>
> DEF G(s)=1/(s*C1*R1+1) !入出力システムの伝達関数　G(s)=Vo/Vi=(1/(C1*R1))/(s+1/(C1*R1))
> !---------- ↑↑↑↑↑ ----------
> </PRE>
>
>
> この箇所を下記のプログラムに置き換える。
>
>
> <PRE>
>
> LET Vi=1 !1∠0°[V]　※仮の電圧源
>
> FUNCTION Laplace(e$,Z,s) !ラプラス変換
>    SELECT CASE UCASE$(e$)
>    CASE "R"
>       LET Laplace=Z !R*i(t)
>    CASE "L"
>
> !●回路図　CRローパス・フィルタ
> !　　　　a
> !vi・─R1┬─・vo
> !　　　　C2
> !　　　  │
> !　　　　≡
> !　参考サイト　http://sim.okawa-denshi.jp/CRlowkeisan.htm
>
> !----- ↓↓↓↓↓ -----
> LET M=2 !素子の数
> !----- ↑↑↑↑↑ -----
>
> DIM A(M,M),x(M),b(M) !A*x=b　※Z(s)*I(s)=E(s)
> DIM iA(M,M)
>
>    !---------- ↓↓↓↓↓ ----------
>    LET Vo=C2*x(2) ! Vo(t)=1/C2*∫i2(t)dt　⇒　Vo(s)=1/(s*C2)*I2(s)
>    !---------- ↑↑↑↑↑ ----------
>
>    LET G=Vo/Vi
> END FUNCTION
> !---------- ↑↑↑↑↑ ----------

＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊

大熊です。
コピーして差し替えましたが最後の下記の部分
    LET G=Vo/Vi
END FUNCTION
!---------- ↑↑↑↑↑ ----------


LET G=Vo/Vi　で「Ｇは関数名　文法上の誤り」と出て動きません。

敬具 		 

Re: 伝達関数によるフィルタ回路の周波数解析、過渡解析

 投稿者：山中和義  投稿日：2009年 2月17日(火)13時09分15秒 		返信・引用
  > No.281[元記事へ]

大熊　正さんへのお返事です。

> LET G=Vo/Vi　で「Ｇは関数名　文法上の誤り」と出て動きません。

うまく切り貼りができていないようなので、最初のプログラムに差し替えたものを掲載します。
OPTION ARITHMETIC COMPLEX

LET j=SQR(-1) !虚数単位

LET f=60 !周波数[Hz]
DEF w=2*PI*f !角周波数ω

SUB DispS(z) !複素数をS表示する　※スタインメッツ（Steinmetz）
   PRINT ABS(z);
   IF ABS(z)<>0 THEN
      IF arg(z)<>0 THEN PRINT "∠";DEG(arg(z));"°";
   END IF
   PRINT
END SUB
!-------------------- ここまでがサブルーチン


!---------- ↓↓↓↓↓ ----------
LET xmax=6 !<----- ※要調整
LET ymin=-50
LET ymax=5


LET Vi=1 !1∠0°[V]　※仮の電圧源

FUNCTION Laplace(e$,Z,s) !ラプラス変換
   SELECT CASE UCASE$(e$)
   CASE "R"
      LET Laplace=Z !R*i(t)
   CASE "L"
      LET Laplace=s*Z !L*d{i(t)}/dt
   CASE "C"
      LET Laplace=1/(s*Z) !1/C*∫{i(t)}dt
   CASE ELSE
      PRINT "未サポートの素子です。"
      STOP
   END SELECT
END FUNCTION


!●回路図　CRローパス・フィルタ
!　　　　a
!vi・─R1┬─・vo
!　　　　C2
!　　　  │
!　　　　≡
!　参考サイト　http://sim.okawa-denshi.jp/CRlowkeisan.htm

!----- ↓↓↓↓↓ -----
LET M=2 !素子の数
!----- ↑↑↑↑↑ -----

DIM A(M,M),x(M),b(M) !A*x=b　※Z(s)*I(s)=E(s)
DIM iA(M,M)

FUNCTION G(s) !伝達関数
   MAT A=ZER !A(式の番号,素子の番号)　※下記の設定で０は省略するため、あらかじめ０を入れておく
   MAT b=ZER !b(式の番号)　※電流または電圧の和

   !---------- ↓↓↓↓↓ ----------
   LET R1=Laplace("R",1.6e3,s) !1.6k[Ω]
   LET C2=Laplace("C",0.1e-6,s) !0.1μ[F]


   !キルヒホッフの電流則
   LET A(1,1)=1 !節点a　i1(t)-i2(t)=0　⇒　I1(s)-I2(s)=0
   LET A(1,2)=-1

   !キルヒホッフの電圧則
   LET A(2,1)=R1 !網目　R1*i1(t) +1/C2*∫i2(t)dt =Vi(t)　⇒　R1*I1(s)+1/(s*C2)*I2(s)=Vi(s)
   LET A(2,2)=C2
   LET b(2)=Vi
   !---------- ↑↑↑↑↑ ----------

   MAT iA=INV(A)
   MAT x=iA*b !各素子の電流I(s)を求める
   !!!mat print x


   !---------- ↓↓↓↓↓ ----------
   LET Vo=C2*x(2) ! Vo(t)=1/C2*∫i2(t)dt　⇒　Vo(s)=1/(s*C2)*I2(s)
   !---------- ↑↑↑↑↑ ----------

   LET G=Vo/Vi
END FUNCTION
!---------- ↑↑↑↑↑ ----------


!!!SET bitmap SIZE 600,600 !画面を大きくする
SET WINDOW -0.5,xmax+0.5, ymin,ymax !表示領域
DRAW grid(1,5) !左端の目盛り

FOR f=1 TO xmax !ｘ軸が対数
   PLOT TEXT ,AT f-0.3,-0.15: mid$("10  100 1k  10k 100k1M  10M 100M",4*(f-1)+1,4)
NEXT f

FOR xx=0 TO xmax STEP 0.025 !周波数[Hz]
   LET f=10^xx !xx=LOG10(f)
   LET t=ABS(G(j*w))
   PLOT LINES: xx,20*LOG10(t); !利得[dB]
NEXT xx
PLOT LINES


SET TEXT COLOR 2
FOR k=ymax TO ymin STEP -5 !右端の縦軸目盛り
   PLOT TEXT ,AT xmax,k: STR$(k*2)&"°" !※利得のグラフに合わせるために2倍する
NEXT k

SET LINE COLOR 2
FOR xx=0 TO xmax STEP 0.05 !周波数[Hz]
   LET f=10^xx
   LET th=arg(G(j*w))
   IF th>0 THEN LET th=th-2*PI !0〜-2πへ補正する　<----- ※要調整
   PLOT LINES: xx,DEG(th)/2; !位相θ[deg]　※利得のグラフに合わせるために1/2倍する
NEXT xx
PLOT LINES


END
 

Re: 伝達関数によるフィルタ回路の周波数解析、過渡解析

 投稿者：大熊　正  投稿日：2009年 2月18日(水)10時54分41秒 		返信・引用
  > No.282[元記事へ]

山中和義さんへのお返事です。

> 大熊　正さんへのお返事です。
>
> > LET G=Vo/Vi　で「Ｇは関数名　文法上の誤り」と出て動きません。
>
> うまく切り貼りができていないようなので、最初のプログラムに差し替えたものを掲載します。
>
>

大熊です。
今度はすぐ上手く動きました。お忙しい中、有難うございました。

過渡特性のプログラムも、こういうのが在ったらいいな・・・
と思っていた矢先でした。今後も大事に使わせていただきます。

敬具 		 

Re: 節点解析法について　（３）

 投稿者：SECOND  投稿日：2009年 2月19日(木)11時24分57秒 		返信・引用 　編集済
  > No.267[元記事へ]

大熊　正さんへのお返事です。

! Rsを付加するのは、良くありません。
! 下の２つの回路は、同じものです。テブナンの定理を。
!                             ┌─C2─┬──────┐
!                             │      │  ┌──┐  │
!                             │      └─┤-   │  │
!                             │          │    ├─�エ�
!             ┌─R1─�；�R2─�※�R3─��─┤+   │  ↑ V5
!             ↑      ↑V1    ↑V2    ↑V3└──┘  │
!             Vin     C1              C3     K=1    │
!             │      │              │            │
!             ０───┴───────┴──────┴─
!
! |(1/R1)+(1/R2)+ω*C1*j -(1/R2)               0                | |V1| |Vin/R1|
! |-(1/R2)               (1/R2)+(1/R3)+ω*C2*j -(1/R3)-K*ω*C2*j| |V2|=| 0    |
! |0                     -(1/R3)               (1/R3)+ω*C3*j   | |V3| | 0    |
!
!