新年のご挨拶

 投稿者:GAI  投稿日:2010年 1月 1日(金)07時37分59秒
  明けまして、おめでとうございます。
新年を迎え、皆様方と共に今年が良き年でありますように願いたいと思います。

さっそくではありますが、ここによくこられる方々は、貴重なコミュケーションの宝庫であります。
そこで、皆様を”刎頚の仲”と呼ばせていただいて、次の創作パズルに挑戦していただきたくご案内いたします。

刎頚の仲(フンケイノナカ)
の7文字”ふ”、”ん”、”け”、”い”、”の”、”な”、”か”
を並び替えて単語を作りました。
これを全て作り出し、辞書式に並べた時、今年(2010年)に当たる
2010番目に来る単語は何でしょう?

これを是非漢字に変換され返信されたし。


正解者多数の場合は先着1名様に、豪華景品(この7文字で作る品物)を差し上げます。

<研究熱心な方に>
0、1,2,3,4,5,6,7,8,9
から作られる全ての順列(3628800通り)を小さいほうから並べていった時
1417386番目にくる順列の並びは何になりますか?
実はこの並びを持つ整数はある特別な性質を持ちます。
可能な限りその特徴を発見して下さい。

また、その並びを見つけ出すために有効となるアイデアや計算手順をお聞かせ下さい。
 

Re: 新年のご挨拶

 投稿者:山中和義  投稿日:2010年 1月 1日(金)14時22分5秒
  > No.959[元記事へ]

GAIさんへのお返事です。

> 0、1,2,3,4,5,6,7,8,9
> から作られる全ての順列(3628800通り)を小さいほうから並べていった時
> 1417386番目にくる順列の並びは何になりますか?

3,912,657,840

・0から9までの数字を一度ずつ使っている
  ⇒ すべての順列(10!通り)を生成する
・0を除く全ての一桁の数(1,2,3,4,5,6,7,8,9)で割り切れる
  ⇒ 2^3*3^2*5*7の倍数
・この数に含まれる隣り合う二桁の数(39、91、12、26など)で割り切れる
  ⇒ ?
・この数(数列)にまだ名前がない(円周率、~の定数など)


また9桁(0~8)の場合、384,572,160 と 728,451,360 があります。
 

新年の驚き

 投稿者:GAI  投稿日:2010年 1月 1日(金)15時21分45秒
  > No.960[元記事へ]

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

.................................
............TenN.................
............E..i.................
............l..n.................
............e..e.................
............v..EightS............
............e.......e............
............nTwelve.v............
..................T.e............
..................h.n............
..................i.SixF.........
..................r....i.........
..................t....v.........
..................e....e.........
..................e....FourT.....
..................nFourteenh.....
..........................Fr.....
..........................ie.....
..........................fe.....
..........................tTwoO..
..........................e...n..
..........................e...e..
..........................nZero..
.................................


...................................
.................TenN..............
.................E..i..............
.................l..n..............
.................e..e..............
.................v..EightS.........
.................e.......e.........
...........Twelven.......v.........
...........T.............e.........
...........h.............n.........
...........i..........FSix.........
...........r..........i............
...........t..........v............
...........e..........e............
...........e..........FourT........
...........nFourteen......h........
...................F......r........
...................i......e........
...................f......e........
...................t...OTwo........
...................e...n...........
...................e...e...........
...................nZero...........
...................................


.....................................
.....................................
.........FourteenT...................
.........F.......h...................
.........i.......i...................
.........f.......r...................
.........t...OTwot...................
.........e...n..Te...................
.........e...e..he...................
.........nZero..rn...................
................eTwelveE.............
............Foure......l.............
............F..........e.............
............i..........v.............
............v..........e.............
............eSix.......n.............
...............S....NTen.............
...............e....i................
...............v....n................
...............e....e................
...............nEight................
.....................................


............................
.......TFourteen............
.......h.......F............
.......i.......i............
.......r.......f............
.......t.......t...OTwo.....
.......e.......e...n..T.....
.......e.......e...e..h.....
.......n.......nZero..r.....
.......TwelveE........e.....
.............l....Foure.....
.............e....F.........
.............v....i.........
.............e....v.........
.............n....eSix......
.............TenN....S......
................i....e......
................n....v......
................e....e......
................Eightn......
............................



..............................
...........TFourteen..........
...........h.......F..........
...........r.......f..........
...........t.......t...OTwo...
...........e.......e...n..T...
...........e.......e...e..h...
...........n.......nZero..r...
...........TwelveE........e...
.................l....Foure...
.................e....F.......
.................v....i.......
.................e....v.......
.................n.Sixe.......
..............NTen.S..........
..............i....e..........
..............n....v..........
..............e....e..........
..............Eightn..........
..............................



.........................................................
..................................555554.................
..................................6....4.................
..................................6....4.................
..................................6....4.................
..................................6.2333.................
..................................6.2....................
...........................77777776G1....................
...........................8.......G.....................
...........................8.......G.....................
...........................8.......G.....................
...........................8.......G.....................
...........................8.......G.....................
...........................8.......G.....................
...........................8.......G.....................
..................9999999998.......G.....................
..................A................G.....................
..................A................G.....................
..................A................G.....................
..................A................G.....................
..................A................G.....................
..................A................G.....................
..................A................G.....................
..................A.EFFFFFFFFFFFFFFF.....................
..................A.E....................................
.......BBBBBBBBBBBA.E....................................
.......C............E....................................
.......C............E....................................
.......C............E....................................
.......C............E....................................
.......C............E....................................
.......C............E....................................
.......C............E....................................
.......C............E....................................
.......C............E....................................
.......C............E....................................
.......C............E....................................
.......CDDDDDDDDDDDDD....................................
.........................................................


などなど


> ・0を除く全ての一桁の数(1,2,3,4,5,6,7,8,9)で割り切れる
>   ⇒ 2^3*3^2*5*7の倍数
はーそうか!!!

> ・この数に含まれる隣り合う二桁の数(39、91、12、26など)で割り切れる
よくこれに気づきましたねー

> また9桁(0~8)の場合、384,572,160 と 728,451,360 があります。
なんと新たな発見

>この数(数列)にまだ名前がない(円周率、~の定数など
ヌード小町ではどうでしょう。


山中さん凄いの一言です。
 

Re: 散歩コースの探索願い

 投稿者:山中和義  投稿日:2010年 1月 4日(月)12時29分28秒
  > No.902[元記事へ]

90°の連結等角多角形(ポリオミノ)による閉路

●閉路の候補
東西(奇数)、南北(偶数)の移動に分けて考えると、それぞれの合計が0になるものである。
この組み合わせ(積)の中で、交差するものを除いたものが求めるもの(答え)である。
 位数 奇数 偶数     積 答え
   7   1   1      1   1
   8   1   1      1   1
  15   4   4      16   1
  16   4   7     28   3
  23  34  35    1190  25
  24  34  62    2108  67
  :(この範囲は未確認)
  32  346  657   227322  ?
  :(未確認)
  40 3965 7636  30276740  ?
  :(未確認)
  48 48396 93846 4541771016  ?
  :(未確認)

先のプログラム(No.958[元記事へ])では、交差判定による枝刈りを行っているが、N=32は相当時間がかかる。
上記のように処理すると、32や40が計算可能になる。


●候補の個数(、符号パターン)を求めるプログラム
LET t0=TIME

LET N=24 !位数

LET w=INT((N-1)/2)+1 !概算
DIM A(w) !1~nまでの奇数列、偶数列

LET m=0
FOR i=1 TO N
   IF MOD(i,2)=1 THEN !奇数なら
   !IF MOD(i,2)=0 THEN !偶数なら ←←←←←
      LET m=m+1
      LET A(m)=i
   END IF
NEXT i
redim A(m)


LET ANSWER_COUNT=0

DIM B(m)
FOR i=0 TO 2^(m-1)-1 !ビットパターンで検証する ※MSB=0
   MAT B=CON
   LET t$=right$(REPEAT$("0",m)&BSTR$(i,2),m) !m桁
   FOR k=1 TO LEN(t$)
      IF t$(k:k)="1" THEN LET B(k)=-1 !0:1、1:-1へ
   NEXT k

   IF DOT(A,B)=0 THEN !±1*1 + ±1*3 + … + ±1*(2*m+1)を計算する
      LET ANSWER_COUNT=ANSWER_COUNT+1
      !!!PRINT "DATA ";CHR$(34);t$;CHR$(34)
   END IF
NEXT i

PRINT "個数=";ANSWER_COUNT !奇数の個数
PRINT


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

END
 

偶然は必然か?

 投稿者:GAI  投稿日:2010年 1月 4日(月)15時48分55秒
  円周率
π=3.1415926535 8979323846 2643383279・・・・

を数字の順番に
1:3
2:1
3:4
4:1
5:5
6:9
7:2
8:6
9:5
10:3
11:5
12:8
13:9
14:7
15:9
16:3
17:2
18:3
19:8
20:4
21:6
22:2
23:6
24:4
25:3
....
としておく。


ここに魔方陣(各和65)
  17      24        1         8        15
  23       5        7        14        16
   4       6       13        20        22
  10      12       19        21         3
  11      18       25         2         9

の数字をπでの数字へ変換してみると
   2        4        3         6         9・・・24
   6        5        2         7         3・・・23
   1        9        9         4         2・・・25
   3        8        8         6         4・・・29
   5        3        3         1         5・・・17
   ・       ・       ・        ・     ・
   ・       ・       ・    ・     ・
   ・       ・       ・    ・     ・
   17       29       25        24        23

こんな偶然ってあり?
 

散歩コースの探索の結果

 投稿者:GAI  投稿日:2010年 1月 5日(火)06時04分40秒
  > No.962[元記事へ]

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


位数24の全パターンを正月3日間動かし続けて探し出しました。
次の32に挑戦しようとしましたが、この時間の必要を思うと途方に暮れていました。
なお位数7、15などのパターンは各辺の長さが1,2,3、・・・
という訳にはいかないので(例えば位数7では出発点と到着点が一直線になるのでここの
ルートの長さが8とみれるので、これは除外することにしましょう。)

>    7   1   1      1   1
>    8   1   1      1   1
>   15   4   4      16   1
>   16   4   7     28   3
>   23  34  35    1190  25
>   24  34  62    2108  67
>   :(この範囲は未確認)
>   32  346  657   227322  ?  →→→→1259
>   40 3965 7636  30276740  ?  →→→→41381
>   48 48396 93846 4541771016  ?  →→→→1651922
 

プログラムの負荷を減らす

 投稿者:SECOND  投稿日:2010年 1月 7日(木)12時02分56秒
  > No.940[元記事へ]

! プログラムの負荷を減らすと、
!同じN角バウンド・ボールであるが、軽くなった余白で、
!動作中のN角数 変更が、できるようになった。
!左クリックで、1角づつ、3~15角( 適当に )何時でも変えられる。
!左クリック押し続けると、早送り。
!--------------------------------------

LET m_=15                      !最大角数
LET ma=3                       !開始角数
LET m0=.23                     !ボールの速さ⊿
DIM x(m_+1),y(m_+1),A(m_+1),ox(m_+1),oy(m_+1)
SET WINDOW -7,7, -7,7
SET DRAW MODE NOTXOR           !2度書きで消える NOTXOR モード
LET r=0.7                      !ボールの半径
LET r0=5.5                     !計算で使用の 多角形、外接円の半径
DO
   CLEAR
   DRAW axes
   LET r1=r0+r/SIN(PI/2-PI/ma) !ボールの当る 多角形、外接円の半径
   LET a0=PI*(1.5-1/ma)        !(x1,y1)の角。
   FOR i=1 TO ma+1
      LET x(i)=r0*COS(a0)
      LET y(i)=r0*SIN(a0)
      IF 1< i THEN
         SET LINE COLOR "silver"
         PLOT LINES: x(i-1),y(i-1); x(i),y(i) !計算外壁
         SET LINE COLOR "black"
         PLOT LINES: r1/r0*x(i-1),r1/r0*y(i-1); r1/r0*x(i),r1/r0*y(i) !ボール外壁
      END IF
      LET a0=a0+2*PI/ma
   NEXT i
   !                      A3         A4  4  A3
   !       3          4──3      5/  \3
   !  A3 /  \ A2   A4│    │A2   A5\    /A2   ・・・
   !   1───2      1──2        1─2
   !       A1             A1             A1
   !
   FOR i=1 TO ma
      LET A(i)=(y(i+1)-y(i))/(x(i+1)-x(i))   !直線i~i+1 の勾配
      LET oy(i)= (x(i+1)-x(i))/SQR((y(i+1)-y(i))^2+(x(i+1)-x(i))^2)
      LET ox(i)=-(y(i+1)-y(i))/SQR((y(i+1)-y(i))^2+(x(i+1)-x(i))^2)
   NEXT i                   !直線i~i+1 に垂直な単位ベクトル(左回転)
   CALL play00
   LET ma=MOD(ma-2,m_-2)+3  !次々角数 3,4,5,6,,,3,4,,
LOOP UNTIL 0< mrb

SUB play00
   PLOT TEXT,AT -6.7, 6.4: "左クリック:角数の選択= "& STR$(ma)
   PLOT TEXT,AT  3.2, 6.4: "右クリック:停止"
   LET i=ANGLE(x(2)-x(1),y(2)-y(1))+SQR(2)*PI/ma/1.1313 !ボールの初期角度
   LET mx=m0*COS(i)                                     !ボールの初期⊿X
   LET my=m0*SIN(i)                                     !ボールの初期⊿Y
   LET i=ANGLE(x(1),y(1))
   LET bx=r0*COS(i)*0.999  !ボールの初期位置X
   LET by=r0*SIN(i)*0.999  !ボールの初期位置Y
   LET nb=0
   DO
      DRAW disk WITH SCALE(r)*SHIFT(bx,by) !ボールを書く
      WAIT DELAY 0.02                      !省電力効果と、速度
      DRAW disk WITH SCALE(r)*SHIFT(bx,by) !ボールだけを消す
      PLOT LINES : bx,by;                  !履歴線を(書く・消す)
      LET bx=bx+mx
      LET by=by+my
      FOR n=1 TO ma
         IF n<>nb THEN
            CALL Sensor                    !辺の内外検出と反射(同じ辺の呼出抑制)
            IF n=nb THEN EXIT FOR
         END IF
      NEXT n
      IF mlbk=0 OR mlb=0 THEN LET mlbk=2*mlb ELSE LET mlbk=mlbk-1.001/13
      MOUSE POLL mox,moy,mlb,mrb
   LOOP UNTIL 0< mrb OR  mlbk< mlb         !左クリックは、Leading Edge 検出
   PLOT LINES                              !do~loop13回でオートリピートへ入る
END SUB

SUB Sensor
   IF ABS(A(n))< 1 THEN  !境界勾配1
      LET xc=(x(n)*A(n)-y(n)-bx*my/mx+by)/(A(n)-my/mx)   !交点 xc 優先< 45°
      LET yc=(xc-x(n))*A(n)+y(n)
      IF SGN(yc-by)<>SGN(my) AND SGN(x(n)-xc)<>SGN(x(n+1)-xc) THEN CALL Mirror
   ELSE
      LET yc=(y(n)/A(n)-x(n)-by*mx/my+bx)/(1/A(n)-mx/my) !交点 yc 優先 >=45°
      LET xc=(yc-y(n))/A(n)+x(n)
      IF SGN(xc-bx)<>SGN(mx) AND SGN(y(n)-yc)<>SGN(y(n+1)-yc) THEN CALL Mirror
   END IF
END SUB

SUB Mirror
   LET i=mx*ox(n)+my*oy(n) !ox,oy: 辺に垂直で内向き 単位vector
   IF 0<=i THEN EXIT SUB   !後向きの交点
   LET mx=mx-2*i*ox(n)
   LET my=my-2*i*oy(n)     !反射速度
   LET bx=xc
   LET by=yc
   LET nb=n                !反射辺 履歴
END SUB

END
 

お願いです!

 投稿者:angel  投稿日:2010年 1月 8日(金)10時21分15秒
  十進basicを使ってn以下の素数の数を数えるプログラムを作りたいのですが、どのように作成したらよろしいでしょうか?
全くの初心者なので分かりません。
よろしくお願いします。
 

Re: お願いです!

 投稿者:白石 和夫メール  投稿日:2010年 1月 8日(金)10時53分17秒
  > No.966[元記事へ]

エラトステネスの篩のプログラムを少し修正すれば可能です。
エラトステネスの篩は,サンプルプログラム
MATH\ERATOS.BAS
として収録しています。
具体的にいえば,配列s中の1の個数を添字がn以下の範囲で数えるだけです。
ただし,配列sの大きさは入力を予定するnより大きくとっておく必要があります。
 

Re: グラフ の一部の文字の大きさ

 投稿者:白石 和夫  投稿日:2010年 1月 8日(金)16時09分1秒
  > No.968[元記事へ]

SET TEXT FONT "Courier New",12
PLOT TEXT,   AT  3,0.4,USING "a=#.#  k=#.# ": A,k
SET TEXT FONT "MS ゴシック",18
PLOT TEXT,   AT  2,0.8:"インパルス応答 "
みたいな感じでどうでしょうか。
 

Re: お願いです!

 投稿者:山中和義  投稿日:2010年 1月 8日(金)19時51分35秒
  > No.966[元記事へ]

angelさんへのお返事です。
100 LET N=100
110 LET c=0
120 FOR i=2 TO N
130    FOR k=2 TO i-1 !約数を確認する
140       IF MOD(i,k)=0 THEN GOTO 170 !ひとつでも割り切れるなら、素数でない
150    NEXT k
160    LET c=c+1 !素数
170 NEXT i
180 PRINT c !結果を表示する
190 END
 

Re: グラフ の一部の文字の大きさ

 投稿者:山中和義  投稿日:2010年 1月 9日(土)11時46分59秒
  > No.968[元記事へ]

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


書体に太字(Bold)や斜体(Italic)がある場合
SET TEXT font "Courier New Bold Italic",24
PLOT TEXT ,AT 0.3,0.2: "ABCabc"

とすると、きれいな文字が描けると思います。


通常の書体には、「標準」文字しか用意されていないため、システムでは
PLOT TEXT ,AT 0.1,0.8: "ABCabcあいう漢字" !元の書体と大きさ

DRAW PlotText("MS 明朝","",24,"ABCabcあいう漢字") WITH SHIFT(0.1,0.7)
DRAW PlotText("MS 明朝","太字",0,"ABCabcあいう漢字") WITH SHIFT(0.1,0.6)
DRAW PlotText("","斜体",0,"ABCabcあいう漢字") WITH SHIFT(0.1,0.5)
DRAW PlotText("MS 明朝","太字 斜体",24,"ABCabcあいう漢字") WITH SHIFT(0.1,0.4)

END

EXTERNAL PICTURE PlotText(f$,a$,s,s$) !原点を基準に、太字(Bold)や斜体(Italic)で文字を描く
IF f$<>"" OR s<>0 THEN SET TEXT font f$,s

IF POS(a$,"斜体")>0 THEN LET a=0.5 ELSE LET a=0
DRAW TEXT(s$) WITH SHEAR(a)

LET dx=worldx(pixelx(0)+1) !1ドットずらす
LET dy=worldy(pixely(0)+1)
IF POS(a$,"太字")>0 THEN DRAW TEXT(s$) WITH SHEAR(a)*SHIFT(dx,0)
!IF POS(a$,"太字")>0 THEN DRAW TEXT(s$) WITH SHEAR(a)*SHIFT(0,dy) !※必要に応じて
!IF POS(a$,"太字")>0 THEN DRAW TEXT(s$) WITH SHEAR(a)*SHIFT(dx,dy) !※必要に応じて
END PICTURE

EXTERNAL PICTURE TEXT(s$) !原点を基準に文字を描く
PLOT TEXT ,AT 0,0: s$
END PICTURE

と文字の射影変換を使って表示できます。高速描画には向きません。
 

SET COLOR MIX

 投稿者:SECOND  投稿日:2010年 1月12日(火)07時12分30秒
  SET COLOR MIX(3) 0, .5, 0 !3緑→暗緑(明度50% 10:濃い緑と同色に。)

SET AREA COLOR "red"
SET AREA COLOR "GREEN" !set color mix(3) で、GREEN が 無効になります。
PLOT AREA:0,0;.5,0;.5,.5;0,.5

SET AREA COLOR 3
PLOT AREA:1,1;.5,1;.5,.5;1,.5

END
 

Re: SET COLOR MIX

 投稿者:白石 和夫メール  投稿日:2010年 1月12日(火)08時06分1秒
  > No.973[元記事へ]

SET AREA COLOR "GREEN"
を実行すると256個の色指標のなから指定された色を探します。
存在しないときは,何もしません。
 

Re: SET COLOR MIX

 投稿者:SECOND  投稿日:2010年 1月12日(火)08時11分13秒
  > No.974[元記事へ]

わかりました。色指標3のシンボルだと思っていました。
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 1月20日(水)09時55分16秒
  > No.947[元記事へ]

前回に続きベクトルの計算をなるべく数学表記に近いように行います。
さあ、このシリーズ、2年目のスタートです!
!平面上のベクトル方程式とそのグラフ

OPTION ARITHMETIC COMPLEX

DEF v(a,b)=COMPLEX(a,b) !複素数の和差、実数倍の計算を対応させる

DEF fnDOT(a,b)=( a*conj(b) + conj(a)*b ) / 2 !内積 a1*b1+a2*b2
!絶対値 ベクトル |a|^2=a・a  複素数 |z|^2=z*conj(z)


SET WINDOW -8,8,-8,8 !表示領域を設定する
DRAW grid !XY座標
ASK PIXEL SIZE (-8,-8; 8,8) w,h !画像の縦横の大きさ(ドット単位)を調べる

LET cEps=0.1 !精度 ※調整が必要である

SET POINT STYLE 1 !点の形状


!例 点A(1,0)を通り、方向ベクトル(2,3)である直線の方程式を求めよ。
!参考 複素数による表現
! 点A(α=a+b*i)、d(β=c+d*i)とすると
! conj(β)*z-β*conj(z)=conj(β)*α-β*conj(α)

LET OA=v(1,0)
LET d=v(2,3)

FOR t=-3 TO 3 !t=[-∞,∞] ※範囲は調整が必要である
   LET OP=OA+t*d !(x,y)=(1,0)+t*(2,3)=(1+2*t,3*t)
   PLOT LINES: Re(OP),Im(OP);
NEXT t
PLOT LINES


!例 2点A(2,5)、B(-1,3)を結ぶ線分ABの方程式を求めよ。
!参考 複素数による表現
! 点A(α=a+b*i)、点B(β=c+d*i)とすると、直線ABは
! (conj(β)-conj(α))*z+(β-α)*conj(z)=conj(β)*α-β*conj(α)

LET OA=v(2,5)
LET OB=v(-1,3)

FOR t=0 TO 1 !t=[0,1]
   LET OP=(1-t)*OA+t*OB !(x,y)=(1-t)*(2,5)+t*(-1,3)
   PLOT LINES: Re(OP),Im(OP);
NEXT t
PLOT LINES


!例 点A(2,5)、ベクトルn=(4,3)に垂直な直線の方程式を求めよ。(内積を用いた表現)
!参考 複素数による表現
! 点A(α=a+b*i)、n(β=c+d*i)とすると
! conj(β)*z+β*conj(z)=conj(β)*α+β*conj(α)

LET a=v(2,5)
LET n=v(4,3)

FOR j=0 TO h !画面全体を走査する
   LET y=worldy(j) !ドットをxy座標に変換する
   FOR i=0 TO w
      LET x=worldx(i)

      LET p=v(x,y) !n・(p-a)=0となる点Pの軌跡
      IF ABS( fnDOT(n,p-a) )<cEps THEN PLOT POINTS: x,y

   NEXT i
NEXT j


!例 点C(-1,1)を中心とする半径3の円の方程式を求めよ。
!参考 複素数による表現
! 点C(α=a+b*i)とすると、|z-α|=r

LET OC=v(-1,1)
LET r=3

FOR j=0 TO h !画面全体を走査する
   LET y=worldy(j) !ドットをxy座標に変換する
   FOR i=0 TO w
      LET x=worldx(i)

      LET OP=v(x,y) !|p-c|=rとなる点Pの軌跡
      IF ABS( ABS(OP-OC)-r )<cEps THEN PLOT POINTS: x,y

   NEXT i
NEXT j



!例 2点A(-5,-3)、B(2,4)を直径とする円の方程式を求めよ。(内積を用いた表現)
!参考 複素数による表現
! 点A(α=a+b*i)、点B(β=c+d*i)とすると
! arg((z-α)/(z-β))=±PI/2 または |z-(α+β)/2|=|α-β|/2

LET OA=v(-5,-3)
LET OB=v(2,4)

FOR j=0 TO h !画面全体を走査する
   LET y=worldy(j) !ドットをxy座標に変換する
   FOR i=0 TO w
      LET x=worldx(i)

      LET OP=v(x,y) !PA・PB=0(円周角の定理)となる点Pの軌跡
      IF ABS( fnDOT(OA-OP,OB-OP) )<cEps THEN PLOT POINTS: x,y

   NEXT i
NEXT j


!例 点O(0,0)、A(2,0)、B(1,2)として、点PをOP=s*OA+t*OB、実数s,tとする。
! ①1≦s+t≦3、0≦s、0≦tの範囲を動くとき、点Pの存在範囲を図示せよ。
! ②2*s+t=1を満たすとき、点Pの存在範囲を図示せよ。

LET OA=v(2,0)
LET OB=v(1,2)

FOR s=0 TO 3 STEP 2^(-6) !s≦3 ※刻みは調整が必要である
   FOR t=0 TO 3 STEP 2^(-6) !0≦sより、s+t≦3≦3+sとなる。これより、t≦3
      IF 1<=s+t AND s+t<=3 THEN !①
         LET OP=s*OA+t*OB
         PLOT POINTS: Re(OP),Im(OP)
      END IF
   NEXT t
NEXT s

FOR s=-4 TO 4 STEP 2^(-6) !t=[-∞,∞] ※範囲と刻みは調整が必要である
   LET t=1-2*s !2*s+t=1より
   LET OP=s*OA+t*OB
   PLOT POINTS: Re(OP),Im(OP) !②
NEXT s


!例 X軸上を転がる半径1の円の円周上の点Pの軌跡(サイクロイド)

LET r=1
FOR t=-3*PI TO 3*PI STEP 0.1 !※範囲と刻みは調整が必要である
   LET OA=v(r*t,r) !中心A、X軸との接点Bとすると、OB=弧BPより
   LET AP=v(-r*SIN(t),-r*COS(t))
   LET OP=OA+AP !点Pの軌跡
   PLOT LINES: Re(OP),Im(OP);
NEXT t
PLOT LINES


END
 

テキストアートの作成依頼

 投稿者:GAI  投稿日:2010年 1月22日(金)10時34分41秒
  写真をスキャナーで読み取り、そのビットに対応する濃淡からこれに対応する”文字”(漢字を含む)を割り当て、元のイメージをすべて文字の羅列にてその画を作ることはできませんでしょうか?
できたら横70文字、縦75文字ほどの大きさが欲しいです。
 

Re: テキストアートの作成依頼

 投稿者:山中和義  投稿日:2010年 1月22日(金)11時09分48秒
  > No.977[元記事へ]

GAIさんへのお返事です。

>写真をスキャナーで読み取り、そのビットに対応する濃淡から

直接スキャナからは不可能ですが、画像ファイルを読み込むのなら可能です。

「カラー画像の各1ピクセルをモノトーン(濃淡)に変換して、1文字で表現する」なら
過去掲示板「画像をテキストアートにする」(元記事)を参照のこと。
ドライブ C のフォルダ My Documents に、TEXTART.HTM が作成されます。


>できたら横70文字、縦75文字ほどの大きさが欲しいです。

モザイク処理になるのでしょうか?
 

Re: テキストアートの作成依頼

 投稿者:GAI  投稿日:2010年 1月23日(土)06時28分45秒
  > No.978[元記事へ]

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

> ドライブ C のフォルダ My Documents に、TEXTART.HTM が作成されます。

すばらしいの一言です。
ただこれを見ると画面一面になり、全体像を見るのに苦労します。
これをテキスト編集や、大きさを変更できたりすることはできませんか?



> モザイク処理になるのでしょうか?
B5版やA4版の用紙で全体を印刷する位の大きさがいいのですが・・・
なお、上記の画面をコピーしてメモ帳に貼り付けようとしたらうまくいかないのですがどうしたらいいのですか?
 

Re: テキストアートの作成依頼

 投稿者:山中和義  投稿日:2010年 1月23日(土)09時39分55秒
  > No.979[元記事へ]

GAIさんへのお返事です。

> ただこれを見ると画面一面になり、全体像を見るのに苦労します。

ドット・を文字■に拡大表示するので大きくなるのは、、、


> これをテキスト編集や、大きさを変更できたりすることはできませんか?

HTML文書(拡張子.HTM)ですので、(インターネット)ブラウザで表示していると思います。
したがって、ブラウザの表示や印字機能(文字を小さくしたり、印字プレビューなど)で
対処してください。
元画像が200×150ピクセルなら、文字サイズを最小にすれば、ほぼ全体が表示できると思います。


> 上記の画面をコピーしてメモ帳に貼り付けようとしたら

メモ帳はファイルサイズが32KBまでなので、ワードパッドかワープロソフトで扱います。


> モザイク処理になるのでしょうか?(自答)

テキストアート
 モノトーン画像の1ピクセル(ドット)を1文字に置き換える
  濃い● →  ● や ◎
  淡い● →  ○ や 0 や O

  たとえば、256階調(濃淡)なら256文字(線の密度パターン)を用意する


アスキーアート
 2値画像のたとえば4×4ピクセル(ドット)を1文字に置き換える
  ■□□■
  □■■□ → X や K
  ■■■□
  ■□□■    高々2^16通りの文字(線の形状パターン)を用意する
 

多倍長LOG(5)を求める

 投稿者:しばっち  投稿日:2010年 1月23日(土)19時18分26秒
  多倍長 LOG(5)を求める

(旧掲示板、投稿ネタからの掘り起しです)

T=1-X/2^N (0<T<=1) として
  LOG(1-T)=-(T+T^2/2+T^3/3+T^4/4+...)
  LOG(X)=LOG(T)+N*LOG(2)

又は

T=X/2^(N-1) (1<T<=2) として
  LOG((1+U)/(1-U))=2*(U+U^3/3+U^5/5...) U=(T-1)/(T+1)
  LOG(X)=LOG(T)+(N-1)*LOG(2)

として求める。
   なお、LOG(2)は予め、用意しておく

実行には、2進モードをご使用ください。

PUBLIC NUMERIC BIAS, KETA, SIGN, EPS
INPUT  PROMPT "桁数=":KETA !' 2000桁まで
LET  KETA = INT(KETA/4)
LET  EPS = 5  !'計算誤差分(4*EPS 桁)
LET  BIAS = 0 !'10000 ^ (BIAS+1) まで
LET  KETA = KETA + EPS !'10000 ^ (-KETA) まで
LET  SIGN = -BIAS - 1  !'多倍長数符号 A(SIGN)=1... 正  A(SIGN)=-1...負
DIM A(-BIAS-1 TO KETA)
LET X=5
!'INPUT  PROMPT "LOG(X) X=":X
CALL SLOG(X,A)
CALL DISPLAY2(A)
END

EXTERNAL  SUB SLOG(X,S())
DIM A(-BIAS-1 TO KETA)
FOR I=1 TO 32
   IF X<=2^I THEN EXIT FOR
NEXT I
IF (2^I-X)/2^I<(X-2^(I-1))/2^(I-1) THEN
   CALL SLOG2(X,S)
ELSE
   CALL SLOG3(X,S)
END IF
END SUB

EXTERNAL  SUB SLOG2(AX, X()) !'LOG(1-T) T=1-X/2^N (0<T<=1) → LOG((2^N-X)/2^N)
IF AX < 0 THEN
   PRINT "ERROR in SLOG2"
   STOP
END IF
DIM U(-BIAS - 1 TO KETA), V(-BIAS - 1 TO KETA), S(-BIAS - 1 TO KETA), N(-BIAS - 1 TO KETA)
LET NN= 1
LET U(0) = 1
LET U(SIGN) = 1
LET S(SIGN) = 1
LET  F = 1
DO WHILE 2 ^ F < AX
   LET  F = F + 1
LOOP
LET XX = 2 ^ F - AX
LET XA = 2 ^ F
CALL LN2(N)
CALL SMUL(N,F)
IF XX=0 THEN
   CALL LCOPY(X,N)
   EXIT SUB
END IF
DO
   CALL SMUL(U,XX)
   CALL SDIV(U,XA)
   CALL LCOPY(V, U)
   CALL SDIV(V, NN)
   CALL LADD2(S, V)
   LET  NN = NN+ 1
LOOP UNTIL ZERO(V)<>0
CALL LSUB (N, S, X)
END SUB

EXTERNAL  SUB SLOG3(XA, X()) !'LOG((T-1)/(T+1)) T=X/2^N (1<T<=2) → LOG((X-2^N)/(X+2^N))
IF XA < 0 THEN
   PRINT "ERROR in SLOG3"
   STOP
END IF
DIM D(-BIAS - 1 TO KETA)
DIM M(-BIAS - 1 TO KETA), S(-BIAS - 1 TO KETA)
DO
   LET K=K+1
LOOP WHILE 2 ^ (K+1) < XA
IF XA - 2 ^ (K+1) = 0  THEN
   CALL LN2(X)
   CALL SMUL(X,K+1)
   EXIT SUB
END IF
LET  N = 1
CALL LCLR (X)
LET  X(0) = XA - 2^K
LET  X(SIGN) = 1
CALL SDIV(X,XA+2^K)
CALL LCOPY(S, X)
DO
   CALL LCOPY(M, S)
   CALL SMUL(X,(XA-2^K)^2)
   CALL SDIV(X,(XA+2^K)^2)
   CALL LCOPY(D, X)
   LET  N = N + 2
   CALL SDIV(D, N)
   CALL LADD2(S, D)
LOOP UNTIL EQUAL(M, S)<>0
CALL SMUL(S,2)
CALL LN2(D)
CALL SMUL(D,K)
CALL LADD(D,S,X)
END SUB

EXTERNAL  SUB LN2(X()) !' LOG(2) (2000桁分)
CALL LCLR (X)
LET X(SIGN)=1
FOR I = 1 TO KETA
   READ IF MISSING THEN EXIT FOR:X(I)
NEXT I
DATA 6931,4718,0559,9453,0941,7232,1214,5817,6568,0755,0013,4360,2552,5412,0680,0094,9339,3621,9696,9471,5605,8633,2699,6418,6875
DATA 4200,1481,0205,7068,5733,6855,2023,5758,1305,5703,2670,7516,3507,5961,9307,2757,0828,3714,3519,0307,0386,2389,1673,4711,2335
DATA 0115,3644,9795,5239,1204,7517,2681,5749,3206,5155,5247,3413,9525,8829,5045,3007,0953,2636,6642,6541,0423,9157,8149,5204,3740
DATA 4303,8550,0801,9441,7064,1671,5186,4471,2839,9681,7178,4546,9570,2627,1631,0645,4615,0257,2074,0248,1637,7733,8963,8550,6952
DATA 6066,8341,1372,7387,3722,9289,5649,3547,0257,6265,2098,8596,9320,1965,0585,5476,4703,3067,9365,4432,5476,3274,4951,2504,0606
DATA 9438,1471,0468,9946,5062,2016,7720,4245,2452,9612,6879,4654,6193,1651,7468,1392,6725,0410,3802,5462,5965,6869,1441,9287,1608
DATA 2938,0317,2714,3677,8265,4877,5664,8508,5674,0776,4845,1464,4399,4046,1422,6031,9309,6735,4025,7444,6070,3080,9608,5047,4866
DATA 3852,3138,1816,7675,1438,6674,7664,7890,8814,3714,1985,4942,3151,9973,5488,0375,1658,6127,5352,9166,1000,7105,3558,2498,7941
DATA 4729,5092,9311,3897,1559,9820,5654,3928,7170,0072,1808,5761,0252,3688,9213,2449,7138,9320,3784,3935,3088,7748,2597,0171,5591
DATA 0708,8236,8362,7589,8425,8918,5353,0243,6342,1436,7061,1892,3678,9192,3723,1467,2321,7205,3401,6492,5687,2747,7823,4453,5347
DATA 6481,1494,1864,2386,7767,7440,6069,5626,5737,9600,8670,7625,7199,1847,3402,2651,4628,3790,4883,0620,3306,1144,6300,7371,9489
DATA 0027,4364,3965,0025,8093,6519,4430,4119,1150,6080,9487,9306,7865,1588,7090,0605,2034,6842,9736,1938,4128,9652,5565,3968,6022
DATA 1941,2292,4207,5743,2175,7489,0977,0675,2687,1158,1705,1137,0091,5894,2665,4785,9596,4890,6530,5846,0258,6683,8294,0022,8330
DATA 0538,2074,0056,7705,3046,7870,0184,1624,0441,8833,2327,9838,6349,0015,6312,1889,5606,5055,3151,2721,9939,8332,0307,5140,8426
DATA 0914,7900,1265,1682,4344,3893,5724,7278,8205,4862,7155,2741,8772,4300,2489,7945,4019,6187,2339,8086,0831,6648,1149,0930,6675
DATA 1933,9312,8904,3164,1370,6813,9777,6498,1769,7486,8903,8877,8999,1296,5036,1927,0710,8892,6410,5230,9247,8391,7373,5012,2984
DATA 2420,4995,6893,5992,2066,0220,4654,9415,1061,3918,7885,7442,4557,7510,2068,3703,0866,6194,8089,6412,1868,0779,0208,1815,8858
DATA 0001,6881,1597,3056,1866,7619,9187,3952,0076,6719,2145,9223,6720,6025,3959,5436,5416,5531,1295,1759,8994,0056,0003,6651,3567
DATA 5690,5124,5926,8257,4394,6483,1683,3262,4901,8038,2424,0824,2314,5230,6140,9638,0570,0702,5513,8770,2681,7851,6306,9025,5137
DATA 0323,4053,8021,4501,9015,3740,2950,9942,2629,9577,9647,4271,3815,7363,8017,2987,3940,7042,4217,9972,2669,6297,9939,3127,0693
DATA 5747,2404,9338,6530,8797
END SUB

!'以下、多倍長計算共通ルーチン  (多倍長LOG(π)を求める、でも使用)

EXTERNAL  SUB DISPLAY2(X()) !'表示
FOR K=-BIAS TO 0
   IF X(K)<>0 THEN EXIT FOR
NEXT K
IF X(SIGN) = -1 THEN PRINT "- ";
IF K>=0 THEN
   LET K=0
   PRINT STR$(X(0));"."
ELSE
   PRINT STR$(X(K));
   FOR I=K+1 TO 0
      LET A$=A$ & RIGHT$("000"&STR$(X(I)),4)
      IF LEN(A$) = 100 THEN
         PRINT A$
         LET A$=""
      END IF
   NEXT I
   IF LEN(A$) > 0 THEN
      PRINT A$;"."
      LET A$=""
   END IF
END IF
LET S=0
FOR I=1 TO KETA-EPS
   LET A$=A$ & RIGHT$("000"&STR$(X(I)),4)
   IF LEN(A$) = 100 THEN
      LET S=S+100
      FOR J=1 TO 10
         PRINT LEFT$(A$,10);" ";
         IF J=5 THEN PRINT "   ";
         LET A$=RIGHT$(A$,LEN(A$)-10)
      NEXT J
      PRINT ":";S
      LET A$=""
      IF MOD(S,1000)=0 THEN PRINT
   END IF
NEXT I
IF LEN(A$) > 0 THEN
   LET S=S+LEN(A$)
   LET A$=A$ & REPEAT$(" ",10)
   FOR J=1 TO 9
      PRINT RTRIM$(LEFT$(A$,10));" ";
      IF J=5 THEN PRINT "   ";
      LET A$=RIGHT$(A$,LEN(A$)-10)
      IF RTRIM$(A$)="" THEN EXIT FOR
   NEXT J
   !'  PRINT ":";S
END IF
END SUB

EXTERNAL  FUNCTION EQUAL(A(), B()) !'等しいかどうか
FOR I = -BIAS - 1 TO KETA-EPS
   IF A(I)<>B(I) THEN
      LET EQUAL=0
      EXIT FUNCTION
   END IF
NEXT I
LET EQUAL=-1
END FUNCTION

EXTERNAL  FUNCTION ZERO(A()) !'0値かどうか
FOR I=-BIAS TO KETA-EPS
   IF A(I)<>0 THEN
      LET ZERO=0
      EXIT FUNCTION
   END IF
NEXT I
LET ZERO=-1
END FUNCTION

EXTERNAL  FUNCTION GREAT(A(), B()) !'多倍長数A > 多倍長数B なら真
LET  SIGNA = A(SIGN)
LET  SIGNB = B(SIGN)
IF SIGNA = -1 AND SIGNB = 1 THEN
   LET  GREAT = 0
   EXIT FUNCTION
END IF
IF SIGNA = 1 AND SIGNB = -1 THEN
   LET  GREAT = -1
   EXIT FUNCTION
END IF
FOR I = -BIAS TO KETA
   IF SIGNA = -1 AND SIGNB = -1 THEN
      IF A(I) < B(I) THEN
         LET  GREAT = -1
         EXIT FUNCTION
      END IF
      IF A(I) > B(I) THEN
         LET  GREAT = 0
         EXIT FUNCTION
      END IF
   ELSE
      IF A(I) > B(I) THEN
         LET  GREAT = -1
         EXIT FUNCTION
      END IF
      IF A(I) < B(I) THEN
         LET  GREAT = 0
         EXIT FUNCTION
      END IF
   END IF
NEXT I
END FUNCTION
 

Re: 多倍長LOG(5)を求める

 投稿者:しばっち  投稿日:2010年 1月23日(土)19時19分36秒
  > No.981[元記事へ]

続き

EXTERNAL  SUB LCLR(A()) !'0値セット
MAT A=ZER
LET  A(SIGN) = 1
END SUB

EXTERNAL  SUB LCOPY(A(), B()) !'値コピー
MAT A=B
END SUB

EXTERNAL  SUB LADD(A(), B(), C()) !'多倍長同士の加算 C=A+B
LET  SIGNA = A(SIGN)
LET  SIGNB = B(SIGN)
IF SIGNA = 1 AND SIGNB = -1 THEN
   LET  B(SIGN) = 1
   CALL LSUB (A, B, C)
   LET  B(SIGN) = -1
   EXIT SUB
ELSEIF SIGNA = -1 AND SIGNB = 1 THEN
   LET  A(SIGN) = 1
   CALL LSUB (B, A, C)
   LET  A(SIGN) = -1
   EXIT SUB
END IF
MAT C=A+B
FOR I = KETA TO -BIAS + 1 STEP -1
   IF C(I) >= 10000 THEN
      LET  C(I) = C(I) - 10000
      LET  C(I - 1) = C(I - 1) + 1
   END IF
NEXT I
IF C(-BIAS) >= 10000 THEN
   PRINT "OVER FLOW in LADD"
   STOP
END IF
IF SIGNA = -1 AND SIGNB = -1 THEN LET  C(SIGN) = -1 ELSE LET  C(SIGN) = 1
END SUB

EXTERNAL  SUB LADD2(A(),B()) !'多倍長同士の加算 A=A+B
DIM C(-BIAS-1 TO KETA)
CALL LADD(A,B,C)
CALL LCOPY(A,C)
END SUB

EXTERNAL  SUB LSUB (A(), B(), C())!'多倍長同士の減算 C=A-B
LET  SIGNA = A(SIGN)
LET  SIGNB = B(SIGN)
LET  A(SIGN) = 1
LET  B(SIGN) = 1
IF SIGNA * SIGNB = -1 THEN
   CALL LADD (A, B, C)
   LET  C(SIGN) = SIGNA
   LET  A(SIGN) = SIGNA
   LET  B(SIGN) = SIGNB
   EXIT SUB
END IF
LET  GR = GREAT(A, B)
IF SIGNA = 1 AND SIGNB = 1 THEN
   IF GR<>0 THEN
      MAT C=A-B
      LET  C(SIGN) = 1
   ELSE
      MAT C=B-A
      LET  C(SIGN) = -1
   END IF
ELSE
   IF GR<>0 THEN
      MAT C=B-A
      LET  C(SIGN) = 1
   ELSE
      MAT C=A-B
      LET  C(SIGN) = -1
   END IF
END IF
FOR I = KETA TO -BIAS + 1 STEP -1
   IF C(I) < 0 THEN
      LET  C(I) = C(I) + 10000
      LET  C(I - 1) = C(I - 1) - 1
   END IF
NEXT I
LET  A(SIGN) = SIGNA
LET  B(SIGN) = SIGNB
END SUB

EXTERNAL  SUB LSUB2(A(),B()) !'多倍長同士の減算 A=A-B
DIM C(-BIAS-1 TO KETA)
CALL LSUB(A,B,C)
CALL LCOPY(A,C)
END SUB

EXTERNAL  SUB SDIV (A(), XA) !'割り算  多倍長数A = 多倍長数A / 整数XA (1E+10程度まで)
IF XA=0 THEN
   PRINT "ERROR in SDIV"
   STOP
END IF
LET  SIGNA = A(SIGN)
LET  SG = SGN(XA)
LET  XX = ABS(XA)
FOR I = -BIAS TO KETA - 1
   LET  R = A(I) - INT(A(I) / XX) * XX
   LET  A(I) = INT(A(I) / XX)
   LET  A(I + 1) = A(I + 1) + R * 10000
NEXT I
LET  A(KETA) = INT(A(KETA) / XX)
LET  A(SIGN) = SIGNA * SG
END SUB

EXTERNAL  SUB SMUL (A(), XA)!'掛け算  多倍長数A = 多倍長数A * 整数XA (1E+10程度まで)
LET  SIGNA = A(SIGN)
IF XA >= 0 THEN LET SG=1 ELSE LET SG=-1
LET  XX = ABS(XA)
MAT A=(XX)*A
FOR I = KETA TO -BIAS + 1 STEP -1
   IF A(I) >= 10000 THEN
      LET  R = INT(A(I) / 10000)
      LET  A(I) = A(I) - 10000 * R
      LET  A(I - 1) = A(I - 1) + R
   END IF
NEXT I
IF A(-BIAS) >= 10000 THEN
   PRINT "OVER FLOW in SMUL"
   STOP
END IF
LET  A(SIGN) = SIGNA * SG
END SUB
 

多倍長LOG(2)を求める

 投稿者:しばっち  投稿日:2010年 1月23日(土)19時21分2秒
  多倍長 LOG(2)を求める

前述の計算方法では別途、LOG(2)値が必要となる

計算式に

    LOG((1+1/X)/(1-1/X))=LOG((X+1)/(X-1)=2*(1/X+1/(3*X^3)+1/(5*X^5)+1/(7*X^7)+...)

を使用し、以下の関係式

    LOG(2) = 3 * LOG(81/80) + 5 * LOG(25/24) + 7 * LOG(16/15)

を使ってLOG(2)を求める。

なお、LOG(5)を直接求めるのなら、上の計算式と関係式

    LOG(5) = 7 * LOG(81/80) + 4 * LOG(16/15) + 12 * LOG(10/9)

を使って求めることができる。

PUBLIC NUMERIC KETA,BIAS,EPS
INPUT  PROMPT "桁数=":KETA
LET  KETA=INT(KETA/4)
LET  EPS=2
LET  BIAS=0
LET  KETA=KETA+EPS
OPTION BASE 0
DIM S(KETA),A(KETA),B(KETA),C(KETA),AA(KETA),BB(KETA),CC(KETA),M(KETA)
LET  N = 1
LET A(0)=3
LET B(0)=5
LET C(0)=7
FOR I = 0 TO KETA - 1
   LET  R = A(I) - INT(A(I) / 161) * 161
   LET  A(I) = INT(A(I) / 161)
   LET  A(I + 1) = A(I + 1) + R * 10000
   LET  R = B(I) - INT(B(I) / 49) * 49
   LET  B(I) = INT(B(I) / 49)
   LET  B(I + 1) = B(I + 1) + R * 10000
   LET  R = C(I) - INT(C(I) / 31) * 31
   LET  C(I) = INT(C(I) / 31)
   LET  C(I + 1) = C(I + 1) + R * 10000
NEXT I
LET  A(KETA) = INT(A(KETA) / 161)
LET  B(KETA) = INT(B(KETA) / 49)
LET  C(KETA) = INT(C(KETA) / 31)
MAT S=S+A
MAT S=S+B
MAT S=S+C
FOR I = KETA TO 0 STEP -1
   IF S(I) >= 10000 THEN
      LET  R = INT(S(I) / 10000)
      LET S(I)=S(I)-R*10000
      LET  S(I - 1) = S(I - 1) + R
   END IF
NEXT I
DO
   FOR I = 0 TO KETA - 1
      LET  R = A(I) - INT(A(I) / 25921) * 25921
      LET  A(I) = INT(A(I) / 25921)
      LET  A(I + 1) = A(I + 1) + R * 10000
      LET  R = B(I) - INT(B(I) / 2401) * 2401
      LET  B(I) = INT(B(I) / 2401)
      LET  B(I + 1) = B(I + 1) + R * 10000
      LET  R = C(I) - INT(C(I) / 961) * 961
      LET  C(I) = INT(C(I) / 961)
      LET  C(I + 1) = C(I + 1) + R * 10000
   NEXT I
   LET  A(KETA) = INT(A(KETA) / 25921)
   LET  B(KETA) = INT(B(KETA) / 2401)
   LET  C(KETA) = INT(C(KETA) / 961)
   MAT AA=A
   MAT BB=B
   MAT CC=C
   LET N=N+2
   FOR I = 0 TO KETA - 1
      LET  R = AA(I) - INT(AA(I) / N) * N
      LET  AA(I) = INT(AA(I) / N)
      LET  AA(I + 1) = AA(I + 1) + R * 10000
      LET  R = BB(I) - INT(BB(I) / N) * N
      LET  BB(I) = INT(BB(I) / N)
      LET  BB(I + 1) = BB(I + 1) + R * 10000
      LET  R = CC(I) - INT(CC(I) / N) * N
      LET  CC(I) = INT(CC(I) / N)
      LET  CC(I + 1) = CC(I + 1) + R * 10000
   NEXT I
   LET  AA(KETA) = INT(AA(KETA) / N)
   LET  BB(KETA) = INT(BB(KETA) / N)
   LET  CC(KETA) = INT(CC(KETA) / N)
   MAT S=S+AA
   MAT S=S+BB
   MAT S=S+CC
   FOR I = KETA TO 0 STEP -1
      IF S(I) >= 10000 THEN
         LET  R = INT(S(I) / 10000)
         LET  S(I)=S(I)-R*10000
         LET  S(I - 1) = S(I - 1) + R
      END IF
   NEXT I
   FOR J = 0 TO KETA
      IF S(J)<>M(J) THEN
         MAT  M = S
         LET K=J
         EXIT FOR
      END IF
   NEXT J
LOOP WHILE J<=KETA-EPS
MAT S=2*S
FOR I = KETA TO 0 STEP -1
   IF S(I) >= 10000 THEN
      LET  S(I) = S(I) - 10000
      LET  S(I - 1) = S(I - 1) + 1
   END IF
NEXT I
CALL WRITEDATA(S,"")
END

EXTERNAL  SUB WRITEDATA(X(),Z$)
IF Z$="" THEN OPEN #1:TextWindow1 ELSE OPEN #1:NAME Z$
ERASE #1
FOR KK=-BIAS TO KETA
   IF X(KK)<>0 THEN EXIT FOR
NEXT KK
PRINT #1:"SUB LN2(X())"
PRINT #1:"CALL LCLR(X)"
PRINT #1:"LET X(SIGN)=1"
PRINT #1:"FOR I=";STR$(KK);" TO KETA"
PRINT #1:"READ IF MISSING THEN EXIT FOR:X(I)"
PRINT #1:"NEXT"
PRINT #1:"DATA ";
FOR I=KK TO KETA-EPS-1
   LET K=K+1
   IF MOD(K,25)=0  THEN
      PRINT #1:RIGHT$("000"&STR$(X(I)),4)
      PRINT #1:"DATA ";
   ELSE
      PRINT #1:RIGHT$("000"&STR$(X(I)),4);
      IF I<>0 THEN PRINT #1:",";
   END IF
   IF -BIAS<=0 AND I=0 THEN
      PRINT #1
      PRINT #1:"DATA ";
      LET K=0
   END IF
NEXT I
PRINT #1:RIGHT$("000"&STR$(X(KETA-EPS)),4)
PRINT #1:"END SUB"
CLOSE #1
END SUB
 

多倍長LOG(π)を求める

 投稿者:しばっち  投稿日:2010年 1月23日(土)19時22分46秒
  多倍長 LOG(π)を求める (2000桁)

計算式に

    LOG(1 - X) = -(X + X^2/2 + X^3/3 + X^4/4 +...)

を使用した。

X は試行錯誤した結果

     X = 1 - 544482330679994391053312457583 / 1710541690073718870111737129379 * π

とした。計算後に

  LOG(17105416...) - LOG(54448233...)を加算して、LOG(π)を求める。

また、計算時間短縮のため、π、LOG(17105416...)、LOG(54448233...)値は予め用意した。

 共通ルーチンが必要。

PUBLIC NUMERIC BIAS, KETA, SIGN, EPS
LET  EPS=12
LET  N=2^9-EPS
LET  BIAS = 0
LET  KETA =-BIAS+N+EPS
LET  SIGN = -BIAS - 1
DIM X(-BIAS - 1 TO KETA)
CALL LLOGPI(X)
CALL DISPLAY2(X)
END

EXTERNAL  SUB LLOGPI(X())
DIM L(-BIAS - 1 TO KETA)
DIM A(-BIAS - 1 TO KETA), B(-BIAS - 1 TO KETA)
DIM S(-BIAS - 1 TO KETA), C(-BIAS - 1 TO KETA)
CALL PI(L)
CALL SDIV(L,9*31*14699) !'1710541690073718870111737129379 で割る
CALL SDIV(L,304439)
CALL SDIV(L,49368533)
CALL SDIV2(L,27751800277)
CALL SMUL(L,101*1657) !' 544482330679994391053312457583 倍する
CALL SMUL(L,3580259)
CALL SMUL(L,5392007)
CALL SMUL2(L,168529144463)
CALL LCLR(X)
LET X(0)=1
CALL LSUB2(X, L)
CALL LCOPY(B, X)
CALL LCOPY(S, X)
LET  NN = 2
DO
   CALL LMUL2(B, X)
   CALL LCOPY(C, B)
   CALL SDIV(C, NN)
   LET  NN = NN + 1
   CALL LADD2(S, C)
LOOP UNTIL ZERO(B)<>0
LET S(SIGN)=-1
CALL LN1710541690073718870111737129379(L)
CALL LADD2(S,L)
CALL LN544482330679994391053312457583(L)
CALL LSUB(S,L,X)
END SUB

EXTERNAL  SUB SMUL2(X(),XA) !'多倍長数X = 多倍長数X * 整数XA (1E+11~1E+14程度まで)
DIM A(-BIAS*4 TO KETA*4+3)  !'(基数10000 → 基数10 に変換して計算) 精度落ち対策
LET  SIGNA = X(SIGN)
IF XA >= 0 THEN LET SG=1 ELSE LET SG=-1
LET  XX = ABS(XA)
FOR I=-BIAS TO KETA
   LET A(I*4)=MOD(INT(X(I)/1000),10)
   LET A(I*4+1)=MOD(INT(X(I)/100),10)
   LET A(I*4+2)=MOD(INT(X(I)/10),10)
   LET A(I*4+3)=MOD(X(I),10)
NEXT I
MAT A=(XX)*A
FOR I=KETA*4 TO -BIAS*4+1 STEP -1
   IF A(I) >= 10 THEN
      LET  R = INT(A(I) / 10)
      LET  A(I) = MOD(A(I),10)
      LET  A(I - 1) = A(I - 1) + R
   END IF
NEXT I
IF A(-BIAS*4) >= 10 THEN
   PRINT "OVER FLOW in SMUL2"
   STOP
END IF
FOR I=-BIAS TO KETA-1
   LET X(I)=A(I*4)*1000+A(I*4+1)*100+A(I*4+2)*10+A(I*4+3)
NEXT I
LET X(SIGN)= SIGNA * SG
END SUB

EXTERNAL  SUB SDIV2(X(),XA) !'多倍長数X = 多倍長数X / 整数XA (1E+11~1E+14程度まで)
DIM A(-BIAS*4 TO KETA*4+3)  !'(基数10000 → 基数10 に変換して計算) 精度落ち対策
IF XA=0 THEN
   PRINT "ERROR in SDIV2"
   STOP
END IF
LET  SIGNA = X(SIGN)
LET  SG=SGN(XA)
LET  XX = ABS(XA)
FOR I=-BIAS TO KETA
   LET A(I*4)=MOD(INT(X(I)/1000),10)
   LET A(I*4+1)=MOD(INT(X(I)/100),10)
   LET A(I*4+2)=MOD(INT(X(I)/10),10)
   LET A(I*4+3)=MOD(X(I),10)
NEXT I
FOR I=-BIAS*4 TO KETA*4-1
   LET  R = A(I) - INT(A(I) / XX) * XX
   LET  A(I) = INT(A(I) / XX)
   LET  A(I + 1) = A(I + 1) + R * 10
NEXT I
LET A(KETA*4)=INT(A(KETA*4)/XX)
FOR I=-BIAS TO KETA-1
   LET X(I)=A(I*4)*1000+A(I*4+1)*100+A(I*4+2)*10+A(I*4+3)
NEXT I
LET X(SIGN)= SIGNA * SG
END SUB

EXTERNAL  SUB LMUL(A(),B(),C())!'多倍長同士の乗算 C=A*B
LET N=(KETA+BIAS)*2
IF INT(LOG2(N))<>LOG2(N) THEN
   PRINT "ERROR in LMUL"
   STOP
END IF
OPTION BASE 0
DIM AA(N*2),BB(N*2),CC(N*2)
FOR I=0 TO N/2-1
   LET AA(2*I)=A(-BIAS+I)
   LET BB(2*I)=B(-BIAS+I)
NEXT I
CALL CDFT(2*N, COS(PI/N), SIN(PI/N), AA)
CALL CDFT(2*N, COS(PI/N), SIN(PI/N), BB)
FOR I = 0 TO N-1
   LET  CC(2*I) = AA(2*I) * BB(2*I) - AA(2*I+1) * BB(2*I+1)
   LET  CC(2*I+1) = AA(2*I) * BB(2*I+1) + BB(2*I) * AA(2*I+1)
NEXT I
CALL CDFT(2*N, COS(PI/N), -SIN(PI/N), CC)
FOR I=0 TO N/2-1
   IF -2*BIAS+I>=-BIAS AND -2*BIAS+I<=KETA THEN
      LET C(-2*BIAS+I)=INT(CC(2*I)/N+.5)
   END IF
NEXT I
FOR I=KETA TO -BIAS STEP -1
   IF C(I) >=10000 THEN
      LET  R = INT(C(I) / 10000)
      LET  C(I) = C(I) - R * 10000
      LET  C(I - 1) = C(I - 1) + R
   ELSEIF C(I)<0 THEN
      LET C(I)=C(I)+10000
      LET C(I-1)=C(I-1)-1
   END IF
NEXT I
LET C(SIGN)=A(SIGN)*B(SIGN)
END SUB

EXTERNAL  SUB LMUL2 (A(), B()) !'多倍長同士の乗算 A=A*B
DIM C(-BIAS-1 TO KETA)
CALL LMUL(A,B,C)
CALL LCOPY(A,C)
END SUB

EXTERNAL  SUB CDFT(N, WR, WI, A()) !'ネット上から入手した(※原版はFORTRAN)
LET  WMR = WR
LET  WMI = WI
LET  M = N
DO WHILE M > 4
   LET  L = M / 2
   LET  WKR = 1
   LET  WKI = 0
   LET  WDR = 1 - 2 * WMI * WMI
   LET  WDI = 2 * WMI * WMR
   LET  SS = 2 * WDI
   LET  WMR = WDR
   LET  WMI = WDI
   FOR J = 0 TO N - M STEP M
      LET  I = J + L
      LET  XR = A(J) - A(I)
      LET  XI = A(J + 1) - A(I + 1)
      LET  A(J) = A(J) + A(I)
      LET  A(J + 1) = A(J + 1) + A(I + 1)
      LET  A(I) = XR
      LET  A(I + 1) = XI
      LET  XR = A(J + 2) - A(I + 2)
      LET  XI = A(J + 3) - A(I + 3)
      LET  A(J + 2) = A(J + 2) + A(I + 2)
      LET  A(J + 3) = A(J + 3) + A(I + 3)
      LET  A(I + 2) = WDR * XR - WDI * XI
      LET  A(I + 3) = WDR * XI + WDI * XR
   NEXT J
   FOR K = 4 TO L - 4 STEP 4
      LET  WKR = WKR - SS * WDI
      LET  WKI = WKI + SS * WDR
      LET  WDR = WDR - SS * WKI
      LET  WDI = WDI + SS * WKR
      FOR J = K TO N - M + K STEP M
         LET  I = J + L
         LET  XR = A(J) - A(I)
         LET  XI = A(J + 1) - A(I + 1)
         LET  A(J) = A(J) + A(I)
         LET  A(J + 1) = A(J + 1) + A(I + 1)
         LET  A(I) = WKR * XR - WKI * XI
         LET  A(I + 1) = WKR * XI + WKI * XR
         LET  XR = A(J + 2) - A(I + 2)
         LET  XI = A(J + 3) - A(I + 3)
         LET  A(J + 2) = A(J + 2) + A(I + 2)
         LET  A(J + 3) = A(J + 3) + A(I + 3)
         LET  A(I + 2) = WDR * XR - WDI * XI
         LET  A(I + 3) = WDR * XI + WDI * XR
      NEXT J
   NEXT  K
   LET  M = L
LOOP
IF M > 2 THEN
   FOR J = 0 TO N - 4 STEP 4
      LET  XR = A(J) - A(J + 2)
      LET  XI = A(J + 1) - A(J + 3)
      LET  A(J) = A(J) + A(J + 2)
      LET  A(J + 1) = A(J + 1) + A(J + 3)
      LET  A(J + 2) = XR
      LET  A(J + 3) = XI
   NEXT J
END IF
IF N > 4  THEN CALL BITRV2(N, A)
END SUB
 

Re: 多倍長LOG(π)を求める

 投稿者:しばっち  投稿日:2010年 1月23日(土)19時23分47秒
  > No.984[元記事へ]

続き

EXTERNAL  SUB BITRV2(N, A())
LET  M = N / 4
LET  M2 = 2 * M
LET  N2 = N - 2
LET  K = 0
FOR J = 0 TO M2 - 4 STEP 4
   IF J < K THEN
      LET  XR = A(J)
      LET  XI = A(J + 1)
      LET  A(J) = A(K)
      LET  A(J + 1) = A(K + 1)
      LET  A(K) = XR
      LET  A(K + 1) = XI
   ELSEIF J > K THEN
      LET  J1 = N2 - J
      LET  K1 = N2 - K
      LET  XR = A(J1)
      LET  XI = A(J1 + 1)
      LET  A(J1) = A(K1)
      LET  A(J1 + 1) = A(K1 + 1)
      LET  A(K1) = XR
      LET  A(K1 + 1) = XI
   END IF
   LET  K1 = M2 + K
   LET  XR = A(J + 2)
   LET  XI = A(J + 3)
   LET  A(J + 2) = A(K1)
   LET  A(J + 3) = A(K1 + 1)
   LET  A(K1) = XR
   LET  A(K1 + 1) = XI
   LET  L = M
   DO WHILE K >= L
      LET  K = K - L
      LET  L = L / 2
   LOOP
   LET  K = K + L
NEXT J
END SUB

EXTERNAL  SUB PI(X()) !'π値
CALL LCLR (X)
LET X(SIGN)=1
FOR I=0 TO KETA
   READ IF MISSING THEN EXIT FOR:X(I)
NEXT I
DATA 0003
DATA 1415,9265,3589,7932,3846,2643,3832,7950,2884,1971,6939,9375,1058,2097,4944,5923,0781,6406,2862,0899,8628,0348,2534,2117,0679
DATA 8214,8086,5132,8230,6647,0938,4460,9550,5822,3172,5359,4081,2848,1117,4502,8410,2701,9385,2110,5559,6446,2294,8954,9303,8196
DATA 4428,8109,7566,5933,4461,2847,5648,2337,8678,3165,2712,0190,9145,6485,6692,3460,3486,1045,4326,6482,1339,3607,2602,4914,1273
DATA 7245,8700,6606,3155,8817,4881,5209,2096,2829,2540,9171,5364,3678,9259,0360,0113,3053,0548,8204,6652,1384,1469,5194,1511,6094
DATA 3305,7270,3657,5959,1953,0921,8611,7381,9326,1179,3105,1185,4807,4462,3799,6274,9567,3518,8575,2724,8912,2793,8183,0119,4912
DATA 9833,6733,6244,0656,6430,8602,1394,9463,9522,4737,1907,0217,9860,9437,0277,0539,2171,7629,3176,7523,8467,4818,4676,6940,5132
DATA 0005,6812,7145,2635,6082,7785,7713,4275,7789,6091,7363,7178,7214,6844,0901,2249,5343,0146,5495,8537,1050,7922,7968,9258,9235
DATA 4201,9956,1121,2902,1960,8640,3441,8159,8136,2977,4771,3099,6051,8707,2113,4999,9998,3729,7804,9951,0597,3173,2816,0963,1859
DATA 5024,4594,5534,6908,3026,4252,2308,2533,4468,5035,2619,3118,8171,0100,0313,7838,7528,8658,7533,2083,8142,0617,1776,6914,7303
DATA 5982,5349,0428,7554,6873,1159,5628,6388,2353,7875,9375,1957,7818,5778,0532,1712,2680,6613,0019,2787,6611,1959,0921,6420,1989
DATA 3809,5257,2010,6548,5863,2788,6593,6153,3818,2796,8230,3019,5203,5301,8529,6899,5773,6225,9941,3891,2497,2177,5283,4791,3151
DATA 5574,8572,4245,4150,6959,5082,9533,1168,6172,7855,8890,7509,8381,7546,3746,4939,3192,5506,0400,9277,0167,1139,0098,4882,4012
DATA 8583,6160,3563,7076,6010,4710,1819,4295,5596,1989,4676,7837,4494,4825,5379,7747,2684,7104,0475,3464,6208,0466,8425,9069,4912
DATA 9331,3677,0289,8915,2104,7521,6205,6966,0240,5803,8150,1935,1125,3382,4300,3558,7640,2474,9647,3263,9141,9927,2604,2699,2279
DATA 6782,3547,8163,6009,3417,2164,1219,9245,8631,5030,2861,8297,4555,7067,4983,8505,4945,8858,6926,9956,9092,7210,7975,0930,2955
DATA 3211,6534,4987,2027,5596,0236,4806,6549,9119,8818,3479,7753,5663,6980,7426,5425,2786,2551,8184,1757,4672,8909,7777,2793,8000
DATA 8164,7060,0161,4524,9192,1732,1721,4772,3501,4144,1973,5685,4816,1361,1573,5255,2133,4757,4184,9468,4385,2332,3907,3941,4333
DATA 4547,7624,1686,2518,9835,6948,5562,0992,1922,2184,2725,5025,4256,8876,7179,0494,6016,5346,6804,9886,2723,2791,7860,8578,4383
DATA 8279,6797,6681,4541,0095,3883,7863,6095,0680,0642,2512,5205,1173,9298,4896,0841,2848,8626,9456,0424,1965,2850,2221,0661,1863
DATA 0674,4278,6220,3919,4945,0471,2371,3786,9609,5636,4371,9172,8746,7764,6575,7396,2413,8908,6583,2645,9958,1339,0478,0275,9009
DATA 9465,7640,7895,1269,4683,9835,2595,7098,2582,2620,5224,8940
END SUB

EXTERNAL  SUB LN1710541690073718870111737129379(X()) !'LOG(1710..)値
CALL LCLR(X)
LET X(SIGN)=1
FOR I=0 TO KETA
   READ IF MISSING THEN EXIT FOR:X(I)
NEXT I
DATA 0069
DATA 6143,6288,7993,3268,3004,4228,2256,8485,2026,6785,3596,6394,4004,2459,4994,5470,1366,5214,8581,6415,4697,3145,7866,1523,7272
DATA 6551,2059,0127,0534,7351,7820,4920,0008,7989,9541,7800,2163,7623,0895,4887,3922,8357,3520,5004,0375,5683,9209,4332,0242,9540
DATA 1748,4435,3241,8232,0917,6048,6351,8267,6655,4103,1920,3713,6534,2808,6848,0068,3923,2800,1886,4684,2394,0286,5595,7822,8870
DATA 6824,4083,5434,5674,3002,0302,6430,7887,0940,1081,9799,5193,2835,3565,5690,4021,5682,1679,9587,2726,5741,7738,9966,8303,9374
DATA 4065,5626,7370,2317,3186,2152,1129,2984,3621,1141,6888,7106,2708,7294,1105,4881,3419,1360,3002,9792,2275,7776,7209,3100,7189
DATA 1333,2926,5906,5310,6574,2333,0024,4444,6043,7221,5935,4199,0820,3015,5200,1473,4002,4862,2284,7807,2731,8261,8953,2953,7309
DATA 4162,4615,8900,1280,1186,1445,3416,9135,4404,4277,0805,7623,1006,4866,6480,4750,1673,5797,3590,6210,4828,8466,8064,0621,5369
DATA 6822,3112,8752,9922,5756,4306,5244,5723,7782,5053,2215,5848,6850,0720,0010,0839,6060,6790,9162,7960,6519,9616,7812,3819,6481
DATA 2850,4009,5322,6067,3979,0496,8839,2466,5255,0930,4737,8771,8972,6183,6781,6485,6742,6847,7569,0628,3272,4958,9055,0595,1667
DATA 0318,1311,7655,2636,5449,8892,8994,6549,8185,5605,1410,8418,3957,3941,9585,7859,8354,6284,4894,3324,7101,4235,7355,6297,7705
DATA 6284,7948,3668,3827,3890,3916,7911,8682,2761,6156,8577,8088,8066,9387,2851,5278,4084,2809,0879,0882,6939,4694,4014,9549,7450
DATA 2911,5763,0278,3692,1766,1804,8124,9781,4074,8058,6307,1025,2785,0760,5599,0083,4081,9099,0502,6793,1794,6341,6502,0176,2868
DATA 3796,2139,9878,6835,7170,1164,2205,6497,0107,8877,3771,7488,8657,5263,9761,2416,6278,3016,1690,0953,1383,8181,7952,3541,1635
DATA 6891,5224,4409,2332,4874,2319,4524,2884,0889,5022,8222,5650,3677,3971,7593,6214,1500,2361,0686,4206,4017,9737,8034,3987,7461
DATA 5150,7437,9961,5876,6881,2221,9103,9820,1354,6600,2760,3220,1344,0667,5700,0559,0702,6840,8532,2596,9193,2134,9548,5155,8877
DATA 1115,9327,4668,8319,5471,2802,0874,9640,1131,7970,8168,2428,1598,3983,6017,5960,3281,6942,4686,9574,9764,9433,1216,4959,2387
DATA 0873,8907,8785,5093,6238,0367,4603,0384,3624,6755,5657,2459,9473,2847,7735,8517,5154,0299,6744,3440,0577,4508,6886,3276,1136
DATA 3026,8720,1951,3001,5676,9739,1394,0643,7786,6988,0521,2185,7078,9937,0618,4466,8235,0108,8657,3294,3409,0176,9410,4535,3487
DATA 5923,4566,3163,5408,2042,0034,7213,0857,1778,0402,9447,8452,8732,6232,4880,1913,2182,3249,5532,6094,1509,8743,6779,9084,9870
DATA 0148,8381,3012,8627,2066,3865,1370,4664,5664,9339,4367,0190,7057,6215,5163,9757,6009,6007,7540,5813,9957,0761,4465,5132,0577
DATA 5503,8417,6557,8706,8939,7814,1500,5247,4757,4949,9209,4162
END SUB

EXTERNAL  SUB LN544482330679994391053312457583(X()) !'LOG(5444..)値
CALL LCLR(X)
LET X(SIGN)=1
FOR I=0 TO KETA
   READ IF MISSING THEN EXIT FOR:X(I)
NEXT I
DATA 0068
DATA 4696,3300,2143,9266,5590,0800,8743,3179,3315,0312,4115,3479,0888,5308,1371,0786,7772,6582,8354,8087,7911,8425,1658,1624,6863
DATA 3534,2720,9432,7548,7948,6284,7447,1357,2875,4696,1898,3726,1025,5558,4562,0907,4477,6791,4979,6390,9355,8684,7181,2383,6067
DATA 5125,9038,3164,5872,4149,1463,9290,8100,8221,3858,4661,7368,8894,4392,1782,5529,1379,0706,7263,6717,7094,2864,3556,3900,7575
DATA 8220,5281,5426,2279,7293,8843,9725,1183,2375,0876,2708,1484,0473,9670,8817,3223,4819,0068,2413,2727,7063,0621,1175,4750,7107
DATA 8671,3441,3378,9146,9346,1923,8237,0526,7108,5413,6817,1946,4759,6110,2330,5046,3222,6584,6590,6347,9478,9162,1229,8258,0639
DATA 8629,0999,7506,3639,3766,9619,4748,6069,6562,5828,2302,4778,3079,2466,1935,4340,5305,9867,9470,7594,5310,3809,3799,2927,1647
DATA 2356,9062,6748,9596,1245,0147,5975,5100,6274,8333,6949,6146,2909,4481,6231,2366,8112,4857,0275,2529,1010,3037,7042,6637,0392
DATA 1670,0491,9722,4984,9411,3815,8869,2731,5703,6430,4132,8603,8424,8368,8011,9123,4089,8308,1853,8980,8362,2095,2457,1928,3638
DATA 0053,3991,4538,1624,6079,4415,8152,2109,6785,7592,9725,2195,0650,0526,5590,0422,3146,3046,8647,5876,9130,4732,3389,1245,8068
DATA 7812,3293,5439,3929,1890,9399,6703,8878,7077,5335,6941,7431,1782,2323,8457,0834,4553,9586,3123,6397,5711,0712,1356,5910,7625
DATA 2193,7131,0681,5285,6609,1095,4149,6754,7763,2836,8796,8730,4951,2823,6551,9299,6014,9348,6341,1187,0646,7366,9790,3242,0076
DATA 3159,2614,7305,1479,3803,0883,1726,8138,1385,3562,1576,6493,8245,0199,7851,4583,9672,9911,8496,3168,7333,7765,0503,4451,0920
DATA 5090,5214,6787,1314,6772,6862,3736,8572,0251,7508,8096,1615,0470,5139,3677,8073,5561,0597,8884,4253,9075,0348,7834,3251,6913
DATA 6549,9352,6478,6587,3687,6446,5803,7343,1607,6931,6148,2364,8107,6286,4138,6620,4422,4124,9848,5744,8327,3790,8854,9012,5488
DATA 6930,5446,1559,2103,7235,1105,4337,1632,8662,1702,8001,9460,1977,8871,6694,9328,1262,7307,0409,3747,7022,2234,8243,0766,1057
DATA 1794,9925,2660,2292,2678,0591,1757,8530,6030,0003,8275,0990,6180,5366,9308,0990,1612,3368,9265,3857,0729,5854,4739,4278,6728
DATA 2111,2446,8161,9364,0415,6814,3644,1779,3609,4265,9090,3322,2336,7923,4096,4595,1538,1568,3121,3374,7747,7340,2591,1985,8297
DATA 1375,4564,3882,8472,3644,4193,1371,2433,7491,7818,1991,7233,1335,2034,1296,1177,3339,7135,6549,2440,4227,1453,0204,3370,3408
DATA 9449,0546,0281,3840,9872,7548,2470,7503,6138,4063,2497,2268,8601,9381,1855,0714,6065,2571,9613,8541,6472,6325,5532,3632,6764
DATA 0684,0804,6469,2615,3651,3647,2317,6321,2200,3895,4491,6134,5365,5560,5641,2651,0168,7531,0092,4478,8313,3640,3413,7462,9541
DATA 1403,9443,4183,7689,8013,2877,3469,9226,6078,9523,0380,9531
END SUB

以下に共通ルーチンをコピペする(多倍長LOG(5)を求める、より)
 

多倍長黄金比を求める

 投稿者:しばっち  投稿日:2010年 1月23日(土)19時24分40秒
  多倍長黄金比を求める (SQR(5)+1)/2=1.618033...

計算式に

    (1-X)^(-.5)=1+(1/2)*X+(1*3)/(2*4)*X^2+(1*3*5)/(2*4*6)*X^3+...

を使用し、以下の関係式

    SQR(5)= 6460 / 2889 * (1 - 1 / 8346321)^(-.5)

を使って黄金比を求める。

PUBLIC NUMERIC KETA,EPS,SIGN
INPUT  PROMPT "桁数=":KETA
LET KETA=INT(KETA/4)
LET EPS=2
LET BIAS=0
LET KETA=KETA+EPS
LET SIGN=-BIAS-1
DIM A(-BIAS-1 TO KETA),S(-BIAS-1 TO KETA),T(-BIAS-1 TO KETA)
LET A(0)=1
LET S(0)=1
LET N=1
DO
   MAT A=(2*N-1)*A
   FOR I = 0 TO KETA - 1
      LET  R = A(I) - INT(A(I)/16692642/N)*(16692642*N)
      LET  A(I) = INT(A(I) /16692642/N)
      LET  A(I + 1) = A(I + 1) + R * 10000
   NEXT I
   LET  A(KETA) = INT(A(KETA)/16692642/N)
   MAT S=S+A
   FOR I = KETA TO 0 STEP -1
      IF S(I) >= 10000 THEN
         LET  R = INT(S(I) / 10000)
         LET  S(I) = S(I) - R * 10000
         LET  S(I-1) = S(I-1) + R
      END IF
   NEXT I
   LET FL=0
   FOR I=0 TO KETA
      IF S(I)<>T(I) THEN
         LET T(I)=S(I)
         LET FL=1
         LET N=N+1
         EXIT FOR
      END IF
   NEXT I
   IF FL=0 THEN EXIT DO
LOOP
MAT S=6460*S
FOR I = KETA TO 0 STEP -1
   IF S(I) >= 10000 THEN
      LET  R = INT(S(I) / 10000)
      LET  S(I) = S(I) - R * 10000
      LET  S(I-1) = S(I-1) + R
   END IF
NEXT I
FOR I = 0 TO KETA - 1
   LET  R = S(I) - INT(S(I)/2889)*2889
   LET  S(I) = INT(S(I)/2889)
   LET  S(I + 1) = S(I + 1) + R * 10000
NEXT I
LET  S(KETA) = INT(S(KETA)/2889)
LET S(0)=S(0)+1
FOR I = 0 TO KETA - 1
   LET  R = S(I) - INT(S(I)/2)*2
   LET  S(I) = INT(S(I)/2)
   LET  S(I + 1) = S(I + 1) + R * 10000
NEXT I
LET  S(KETA) = INT(S(KETA)/2)
CALL DISPLAY(S)
END

EXTERNAL  SUB DISPLAY(X())
FOR K=-BIAS TO 0
   IF X(K)<>0 THEN EXIT FOR
NEXT K
IF K > 0 THEN LET K=0
IF X(SIGN) = -1 THEN PRINT "- ";
PRINT STR$(X(K));" ";
IF K=0 THEN PRINT "."
FOR I=K+1 TO KETA-EPS
   LET L=L+1
   PRINT RIGHT$("000"&STR$(X(I)),4);" ";
   IF I=0 THEN
      PRINT "."
      LET L=0
   END IF
   IF MOD(L,25)=0 THEN PRINT
NEXT I
PRINT
END SUB
 

お願いです

 投稿者:sukehiroメール  投稿日:2010年 1月24日(日)07時17分32秒
  私も十進BASICの愛用者です。
苦労してァグランジェの方程式と、MuPaDを駆使して、2重振り子の運動方程式c1'',
c2''を導き出し、動作シミュレーションをすることができました。

3重振り子に挑戦したのですが、収拾がつかなくなりました。
どなたか、プログラム作成し掲示していただけると嬉しいです
 

Re: お願いです

 投稿者:山中和義  投稿日:2010年 1月25日(月)10時08分5秒
  > No.987[元記事へ]

sukehiroさんへのお返事です。
!直列多重振り子
!参考サイト http://www.aihara.co.jp/~taiji/pendula-equations/present-node5.html

LET N=3 !振り子の数

DIM m(N) !振り子のおもりの質量
DATA 0.2, 0.3, 0.2
MAT READ m

DIM l(N) !振り子の糸の長さ
DATA 3, 3, 4
MAT READ l

DIM th(N) !振り子のy軸に対する角度
LET th(1)=2*PI/3 !初期値
LET th(2)=-PI/2
LET th(3)=PI/6

!θ[d](d=1,n)に関するラグランジュ運動方程式
!   m[d,n]*l[d]^2*d/dt^2{θ[d]}
! + Σ[i=1,d-1] m[d,n]*l[d]*l[i]*d/dt^2{θ[i]}*C[d,i]
! + Σ[i=d+1,n] m[i,n]*l[d]*l[i]*d/dt^2{θ[i]}*C[d,i]
! + Σ[i=1,d-1] m[d,n]*l[d]*l[i]*(d/dt{θ[i])^2*S[d,i]
! + Σ[i=d+1,n] m[i,n]*l[d]*l[i]*(d/dt{θ[i])^2*S[d,i]
! + m[d,n]*g*l[d]*SIN(θ[d])
! = 0

LET G=9.8 !重力加速度

FUNCTION sm(k,l) !m[k,l]=Σ[j=k,l] mj
   local s,j
   LET s=0
   FOR j=k TO l
      LET s=s+m(j)
   NEXT j
   LET sm=s
END FUNCTION
DEF C(i,j)=COS(th(i)-th(j)) !C[i,j]=COS(θi-θj)
DEF S(i,j)=SIN(th(i)-th(j)) !S[i,j]=SIN(θi-θj)

!2階微分方程式を連立1階微分方程式にする
! ωd=d/dt{θd}とすると、R*d/dt^2{θd}=vよりd/dt{ωd}=[INV(R)*v]d

DIM R(N,N),v(N)
SUB FNC(t,x(), f()) !連立微分方程式 d/dt{Xi}=f(t,Xi)
   FOR d=1 TO N !行
      FOR i=1 TO N !列
         IF i>d THEN !右上部分
            LET R(d,i)=sm(i,N)*l(d)*l(i)*C(d,i)
         ELSEIF i=d THEN !対角線
            LET R(d,i)=sm(d,N)*l(d)^2
         ELSE !左下部分
            LET R(d,i)=sm(d,N)*l(d)*l(i)*C(d,i)
         END IF
      NEXT i
   NEXT d
   !!!MAT PRINT R;

   FOR d=1 TO N !行
      LET ss=0
      FOR i=1 TO d-1
         LET ss=ss-sm(d,N)*l(d)*l(i)*x(i)^2*S(d,i)
      NEXT i
      FOR i=d+1 TO N
         LET ss=ss-sm(i,N)*l(d)*l(i)*x(i)^2*S(d,i)
      NEXT i
      LET ss=ss-sm(d,N)*G*l(d)*SIN(th(d))

      LET v(d)=ss
   NEXT d
   !!!MAT PRINT v;

   MAT R=INV(R)
   MAT f=R*v
END SUB


SET WINDOW -10,10,-12,8 !描画領域

DIM w(N) !振り子のy軸に対する角速度
MAT w=ZER

LET h=0.01 !時間刻み幅 ⊿t
FOR t=0 TO 30 STEP h !※調整すること

   SET DRAW mode hidden !ちらつき防止開始
   CLEAR
   DRAW PendulumN(1) !親から順に描画する
   SET DRAW mode explicit !ちらつき防止終了

   !WAIT DELAY 0.2 !※必要に応じて

   !4次のルンゲ・クッタ法で連立微分方程式 d/dt{Xi}=f(t,Xi)を解く
   DIM k1(N),k2(N),k3(N),k4(N), f(N)

   DIM x(N),TT(N)
   MAT x=w
   CALL FNC(t,x, f)
   MAT k1=h*f

   MAT TT=(1/2)*k1
   MAT x=w+TT
   CALL FNC(t+h/2,x, f)
   MAT k2=h*f

   MAT TT=(1/2)*k2
   MAT x=w+TT
   CALL FNC(t+h/2,x, f)
   MAT k3=h*f

   MAT x=w+k3
   CALL FNC(t+h,x, f)
   MAT k4=h*f

   FOR i=1 TO N
      LET w(i)=w(i)+(k1(i)+2*(k2(i)+k3(i))+k4(i))/6 !x(t+h)=x(t)+(k1+2*k2+2*k3+k4)/6
   NEXT i

   MAT TT=h*w !ωd=d/dt{θd}より
   MAT th=th+TT
   !!!MAT PRINT th;

NEXT t


PICTURE PendulumN(i) !n重の振り子を描く
   LET LL=l(i)
   LET AA=th(i)
   DRAW Pendulum(LL,m(i)) WITH ROTATE(AA) !親
   IF i<N THEN DRAW PendulumN(i+1) WITH SHIFT(LL*SIN(AA),-LL*COS(AA)) !階層関係(子へ)
END PICTURE

PICTURE Pendulum(L,r) !原点を基準に振り子を描く
   PLOT LINES: 0,0; 0,-L !糸
   DRAW disk WITH SCALE(r)*SHIFT(0,-L) !おもり
END PICTURE

END
 

有難うございました

 投稿者:sukehiroメール  投稿日:2010年 1月26日(火)03時48分53秒
  山中和義様、有難うございました。  

3次元 解析ソフト 絵

 投稿者:与坂  昇平メール  投稿日:2010年 1月26日(火)16時09分3秒
  難しい  数学を  使用しないで  マトリックスが  解れば
理解できる  3次元  の  有限要素法での  構造解析ソフトを  作成しています

25要素の  棒を  右端  固定して   左を  持ち上げ
その後  後ろに  押した  グラヒックを  お見せします
full  basic  です

感想は  どうですか  ???
 

3次元の  絵

 投稿者:与坂  昇平メール  投稿日:2010年 1月26日(火)16時11分14秒
  絵が  載らないので  再度  送ります  

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 1月26日(火)19時54分57秒
  > No.976[元記事へ]

三角形の性質をベクトル方程式などで表現してみました。
!図形とベクトル方程式(三角形の心)

!平面の点を「平面のベクトルとみる」と「複素数とみる」と考えられる

OPTION ARITHMETIC COMPLEX

DEF v(a,b)=COMPLEX(a,b) !複素数の和差、実数倍の計算を対応させる

DEF fnDOT(a,b)=( a*conj(b) + conj(a)*b ) / 2 !内積 a1*b1+a2*b2
!絶対値 ベクトル |a|^2=a・a  複素数 |z|^2=z*conj(z)

DEF fnNormalize(a)=a/ABS(a) !正規化

!------------------------------ ここまでがサブルーチン


SET WINDOW -8,8,-8,8 !表示領域を設定する
DRAW grid !XY座標
ASK PIXEL SIZE (-8,-8; 8,8) w,h !画像の縦横の大きさ(ドット単位)を調べる

LET cEps=0.1 !精度 ※調整が必要である

SET POINT STYLE 1 !点の形状


!例 三角形ABCの心
!   C
! b /\ a
! A ── B
!   c

LET OA=v(-4,-5)
LET OB=v(3,-4)
LET OC=v(4,6)

LET AB=OB-OA !辺AB
LET BC=OC-OB !辺BC
LET CA=OA-OC !辺CA

PLOT LINES: Re(OA),Im(OA); Re(OB),Im(OB) !辺ABを描く
PLOT LINES: Re(OB),Im(OB); Re(OC),Im(OC) !辺BC
PLOT LINES: Re(OC),Im(OC); Re(OA),Im(OA) !辺CA


LET a=ABS(BC) !辺BCの長さ
LET b=ABS(CA) !辺CA
LET c=ABS(AB) !辺AB

LET t=(a+b+c)/2 !ヘロンの公式より、面積S
LET S=SQR(t*(t-a)*(t-b)*(t-c))


!------------------------------

LET OI=(a*OA+b*OB+c*OC)/(a+b+c) !内心の位置ベクトル
SET AREA COLOR 4
DRAW disk WITH SCALE(0.2)*SHIFT(OI)

SET LINE COLOR 4
LET R=S/t !S=△IAB+△IBC+△ICA=1/2*c*r+1/2*a*r+1/2*b*r=r*(a+b+c)/2より
DRAW circle WITH SCALE(R)*SHIFT(OI) !内接円を描く |z-α|=r

CALL DrawLine4(OA,OB,OC)
SUB DrawLine4(OA,OB,OC) !④∠BACを二等分する線
   FOR t=0 TO 10 !t=[0,∞] ※範囲は調整が必要である
      LET wAB=OB-OA
      LET wAC=OC-OA
      LET OP=OA+(fnNormalize(wAB)+fnNormalize(wAC))*t !ひし形AbDcの対角線AD
      PLOT LINES: Re(OP),Im(OP);
   NEXT t
   PLOT LINES
END SUB
CALL DrawLine4(OB,OC,OA)
CALL DrawLine4(OC,OA,OB)


!------------------------------

LET OG=(OA+OB+OC)/3 !重心の位置ベクトル
SET AREA COLOR 2
DRAW disk WITH SCALE(0.2)*SHIFT(OG)

SET LINE COLOR 2
CALL DrawLine2(OA,OB,OC)
SUB DrawLine2(OA,OB,OC) !②点Aと辺BCの中点を通る線
   FOR t=0 TO 10 !t=[0,∞] ※範囲は調整が必要である
      LET OP=OA+(OB+OC-2*OA)*t !平行四辺形ABDCの対角線AD
      PLOT LINES: Re(OP),Im(OP);
   NEXT t
   PLOT LINES
END SUB
CALL DrawLine2(OB,OC,OA)
CALL DrawLine2(OC,OA,OB)



!------------------------------

LET sin2A=2*S*(b^2+c^2-a^2)/(b*c)^2 !sin2A=2*cosA*sinA、余弦定理cosA=(b^2+c^2-a^2)/(2*b*c)、面積S=1/2*b*c*sinAより
LET sin2B=2*S*(c^2+a^2-b^2)/(c*a)^2
LET sin2C=2*S*(a^2+b^2-c^2)/(a*b)^2
LET OQ=(sin2A*OA+sin2B*OB+sin2C*OC)/(sin2A+sin2B+sin2C) !外心の位置ベクトル
SET AREA COLOR 3
DRAW disk WITH SCALE(0.2)*SHIFT(OQ)

SET LINE COLOR 3
LET R=a*b*c/(4*S) !正弦定理a/sinA=b/sinB=c/sinC=2*Rと面積S=1/2*b*c*sinAより
DRAW circle WITH SCALE(R)*SHIFT(OQ) !外接円を描く


!------------------------------

LET tanA=2*S/(b^2+c^2-a^2) !tanA=sinA/cosAと余弦定理cosA=(b^2+c^2-a^2)/(2*b*c)と面積S=1/2*b*c*sinAより
LET tanB=2*S/(c^2+a^2-b^2)
LET tanC=2*S/(a^2+b^2-c^2)
LET OH=(tanA*OA+tanB*OB+tanC*OC)/(tanA+tanB+tanC) !垂心の位置ベクトル
SET AREA COLOR 1
DRAW disk WITH SCALE(0.2)*SHIFT(OH)


FOR j=0 TO h !画面全体を走査する
   LET y=worldy(j) !ドットをxy座標に変換する
   FOR i=0 TO w
      LET x=worldx(i)

      LET OP=v(x,y)

      SET POINT COLOR 3 !外心
      IF ABS( fnDOT(OP-(OB+OC)/2,BC) )<cEps THEN PLOT POINTS: x,y !③辺BCの垂直二等分線
      IF ABS( fnDOT(OP-(OC+OA)/2,CA) )<cEps THEN PLOT POINTS: x,y
      IF ABS( fnDOT(OP-(OA+OB)/2,AB) )<cEps THEN PLOT POINTS: x,y

      SET POINT COLOR 1 !垂心
      IF ABS( fnDOT(OP-OA,BC) )<cEps THEN PLOT POINTS: x,y !①点Aから辺BCへの垂線 AP⊥BC
      IF ABS( fnDOT(OP-OB,CA) )<cEps THEN PLOT POINTS: x,y
      IF ABS( fnDOT(OP-OC,AB) )<cEps THEN PLOT POINTS: x,y

   NEXT i
NEXT j


END
 

ゲーム解析のお願い

 投稿者:GAI  投稿日:2010年 1月27日(水)11時42分43秒
  52枚のカードから任意の13枚を抜き出すと、必ず4枚の同じマークのカードが含まれるようになるので、この4枚だけが表向きで終了するような作品を作りたい。
表にしたいカードの位置として考えられる全パターンが13C4=715通り考えられ、これらがすべて可能であるのか知りたい。

<13枚のパケットの操作方法>
裏向きに持ち、上から任意の枚数でひっくり返しパケットに戻す。
この操作を何回かくり返していき、目的の4枚だけが表向きになっている状態にする。

パケットの上から持ち上げる枚数と最終表のカード(*)の例

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


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

最終パターンを達成するための持ち上げる枚数の戦略を知りたい。
 

Re: ゲーム解析のお願い

 投稿者:山中和義  投稿日:2010年 1月27日(水)16時11分19秒
  > No.993[元記事へ]

GAIさんへのお返事です。


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

 枚数列{6,3,4,9}の4手が最少手数のようです。

LET t0=TIME


PUBLIC NUMERIC N !カードの枚数
LET N=13

DIM c(N) !最初のパターン ※
DATA 1,2,3,4,5,6,7,8,9,10,11,12,13
MAT READ c

PUBLIC NUMERIC GOAL(100) !最終のパターン ※
MAT GOAL=ZER(N)
DATA -9,-8,-7,1,2,4,5,6,-3,10,11,12,13
MAT READ GOAL

PUBLIC NUMERIC LIMIT !手数の上限 ※
LET LIMIT=10

DIM A(LIMIT) !枚数
CALL backtrack(c,1,A)


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

END


EXTERNAL SUB reverse(c(),P) !先頭からP枚を裏返す
FOR i=1 TO INT(P/2) !交換
   LET t=c(i)
   LET c(i)=c(P-i+1)
   LET c(P-i+1)=t
NEXT i
FOR i=1 TO P !反転
   LET c(i)=-c(i)
NEXT i
END SUB

EXTERNAL SUB backtrack(c(),K,A()) !バックトラック法で検証する
IF K<=LIMIT THEN !手数の上限内なら
   DIM x(N)
   MAT x=c !save it

   FOR i=1 TO N !枚数を変える
      LET A(K)=i
      CALL reverse(c,i) !反転

      FOR j=1 TO N !最終のパターンかどうか確認する
         IF c(j)<>GOAL(j) THEN EXIT FOR
      NEXT j
      IF j>N THEN !一致したら
         LET LIMIT=K-1 !上限を狭める ※最初に見つかったもの
         PRINT K;"手"
         FOR j=1 TO K
            PRINT A(j); !枚数
         NEXT j
         PRINT
         !!!MAT PRINT c; !debug
      ELSE
         CALL backtrack(c,K+1,A) !次へ
      END IF

      MAT c=x !restore it
   NEXT i
END IF
END SUB
 

Re: ゲーム解析のお願い

 投稿者:GAI  投稿日:2010年 1月27日(水)19時12分53秒
  > No.994[元記事へ]

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

さっそく作って頂きありがとうございます。
自分で少し変更してみようと試みましたが、迷路に入り再びお願いがあります。

カードを任意の枚数でひっくり返していくとき、表が4枚になったならカードの配列を表示し(最終パターンに相当するもの。)
そこまでの、持ち上げる枚数を同時に見てみたい。


この表が4枚となるあらゆるパターン(最初の何番目のカードが表かでの違いについての)は調べることは出来ますか?
 

Re: ゲーム解析のお願い

 投稿者:山中和義  投稿日:2010年 1月27日(水)20時26分9秒
  > No.995[元記事へ]

GAIさんへのお返事です。
LET t0=TIME


PUBLIC NUMERIC N !カードの枚数
LET N=13

DIM c(N) !最初のパターン ※
DATA 1,2,3,4,5,6,7,8,9,10,11,12,13
MAT READ c

PUBLIC NUMERIC LIMIT !手数の上限 ※
LET LIMIT=4

PUBLIC NUMERIC cMIN !最少手数
LET cMIN=LIMIT+1

DIM A(LIMIT) !枚数
CALL backtrack(c,0,A)

IF cMIN<=LIMIT THEN PRINT "最少手数=";cMIN


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

END


EXTERNAL SUB reverse(c(),P) !先頭からP枚を裏返す
FOR i=1 TO INT(P/2) !交換
   LET t=c(i)
   LET c(i)=c(P-i+1)
   LET c(P-i+1)=t
NEXT i
FOR i=1 TO P !反転
   LET c(i)=-c(i)
NEXT i
END SUB

EXTERNAL SUB backtrack(c(),K,A()) !バックトラック法で検証する
LET s=0
FOR j=1 TO N !表の枚数を確認する
   IF c(j)<0 THEN LET s=s+1
NEXT j
IF s=4 THEN !一致したら
   IF K<cMIN THEN LET cMIN=K !最少手数を記録する
   PRINT K;"手"
   FOR j=1 TO K
      PRINT A(j); !枚数列
   NEXT j
   PRINT
   MAT PRINT c; !最終のパターン
ELSE
   IF K<LIMIT THEN !手数の上限内なら
      DIM x(N)
      MAT x=c !save it

      FOR i=1 TO N !枚数を変える
         IF K>=1 AND i=A(K) THEN !同じ手が続く場合は無効!
         ELSE
            LET A(K+1)=i
            CALL reverse(c,i) !反転

            CALL backtrack(c,K+1,A) !次へ

            MAT c=x !restore it
         END IF
      NEXT i
   END IF
END IF
END SUB
 

分析して分かったこと

 投稿者:GAI  投稿日:2010年 1月30日(土)16時10分20秒
  山中さんから作って頂いたプログラムを動かしてその結果を整理していたら、次の原理が見えてきました。
表にしたいカードの最初の位置が上から例えば3,7,8,11番目であったとすると
一回目:2枚(これは3の手前までの枚数)
二回目:3枚(これは最初のカードの位置3に対応する)
三回目:6枚(次の7の手前までの枚数)
四回目:8枚(7,8と連続しているから8までの枚数)
五回目:10枚(最後の11の手前までの枚数)
六回目:11枚(最後の11に対応する)

分かってみると当たり前に感じるが、最初からこのことにはなかなか気がつかない。
従ってカードがどこに何枚あろうがこの原則さえ熟知しておけばちょっとしたゲームやパズルに応用が利く。
 

Re: 分析して分かったこと

 投稿者:山中和義  投稿日:2010年 1月30日(土)20時24分52秒
  > No.997[元記事へ]

GAIさんへのお返事です。

(p-1)枚、p枚とめくると、-p,1,2,3,…,p-1 の順に並ぶ。

これは、「p番目のカードのみを表向きで先頭へ。以降の順番は変わらず」を意味する。

参考
 反転操作によるブロック移動(No.716 [元記事へ]
 の2分割の特殊形(前半部分(p-1)個と後半部分1個より、前半と全体の反転)となります。
 

小作品

 投稿者:GAI  投稿日:2010年 1月31日(日)08時40分56秒
  1~10の番号(同一マークで)のカードを準備し

1.客に電話番号を何気に聞く。(ただし4つの数字はすべて異なってなければならない。
そうでないなら、他の数字を考えてもらう。)
<例>
客の番号:9265
これを小さい順に並べ、基準数とする。
基準数 :2569

2.10枚のカードを上からすべて裏向きで
2番目に9
5番目に2
6番目に6
9番目に5
のカードが位置するように(0はカード10で作業する。)何気にセットしておく。
他の位置のカードは何でもよい。
<頭の中で電話番号と基準数を対応させて作業する。>

3.このパケットをフォールスシャッフルし
先の方法で基準数の数字が表向きに出現する操作をやる。
演技的には、如何にも無造作にやっていると感じさせるように・・・
「これらをよーく混ぜます。」などの口上と共に作業する。
この例では
1回目:上から1枚持ち上げひっくり返して元に戻す
2回目:2枚持ち上げ同じく返して戻す
3回目:4枚
4回目:6枚
5回目:8枚
6回目:9枚

このとき最後の操作でトップに4枚の表向きカード(5,6,2,9の順番)
が来るから、最後の時にパケットをひっくり返しながらこれがボトム側へ来るように持ち替える。

4.上から5枚を数え取り(すべて表向きカード)右手に持つ。

5.残った左手のパケットとパーフェト・リフル・シャッフルをする。
 (右手から先ず1枚落とし、次に左手から1枚、次に右手より1枚、・・・と交互にパラパラとテーブルにカードを噛み合わせながら落としていく。:慣れると簡単です。)

6.カードを揃え、パケットをすべてひっくり返して右手に持つ。
  「電話番号は何でしたっけ?」と確認をとり
  テーブルへパケットをリボンスプレッドして下さい。
  **9*2*6*5*    (*は裏向きカード)
  で並びます。


客を驚かせるようにするのは大変です。
 

この問いはプログラム可能ですか?

 投稿者:GAI  投稿日:2010年 1月31日(日)09時44分45秒
  1^3+2^3+3^3+・・・・+n^3
=1*1^2+2*2^2+3*3^2+・・・・n*n^2
=(1+2+3+・・・・+n)^2(={n(n+1)/2}^2)

のよく知られた関係式は

一辺が1の正方形が1個
一辺が2の正方形が2個
一辺が3の正方形が3個
・・・・・・・・・・
一辺がnの正方形がn個
を使って、一辺がn(n+1)/2 の正方形を敷き詰める可能性を示唆する。

さて本当にこのことを実現できるのはnがいくつのときでしょうか?
その最小値を調べてください。(n>1の条件で)
またこの時の敷き詰め図は?
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 2月 3日(水)09時16分53秒
  > No.992[元記事へ]

問題
 2辺が47と65の長方形がある。
 これに10個の正方形を敷き詰めるには、どうすればよいか。

攻略法 「ユークリッドの互除法」

最大公約数を求める過程が「正方形で分割していく」に相当する。
!長方形を正方形で分割する
!例
! ┌──┬┬┐
! │  ├┴┤
! │  │ │
! └──┴─┘

LET a=65
LET b=47

IF a< b THEN !a≧bとする
   LET t=a !swap it
   LET a=b
   LET b=t
END IF

DO UNTIL b=0 !ユークリッドの互除法、連分数展開
   LET q=INT(a/b) !商
   PRINT "一辺";b;"の正方形が";q;"個"
   LET r=a-q*b !余り ※長方形をすべて正方形に分割できれば0となる
   LET a=b
   LET b=r
LOOP

PRINT "最大公約数=";a

END

実行結果
一辺 47 の正方形が 1 個
一辺 18 の正方形が 2 個
一辺 11 の正方形が 1 個
一辺 7 の正方形が 1 個
一辺 4 の正方形が 1 個
一辺 3 の正方形が 1 個
一辺 1 の正方形が 3 個
最大公約数= 1


問題
 2辺が32と33の長方形がある。
 これに9個の正方形を敷き詰めるには、どうすればよいか。

攻略法 「約数」

33=1*33 一辺1の正方形が33個と解釈すると、9個を超えているので不適となる。
33=3*11 一辺3の正方形が11個、同様に不適となる。
33=11*3 一辺11の正方形が3個、OK。
33=33*1 一辺33の正方形が1個、縦の長さを超えているので不適となる。

  11*3
11┌┬┬┐
 ├┴┴┤
21│  │
 └──┘

21×33の長方形を6個に分割することになる。
これに「ユークリッドの互除法」を適用すると、運良くうまくいく。
一辺 21 の正方形が 1 個
一辺 12 の正方形が 1 個
一辺 9 の正方形が 1 個
一辺 3 の正方形が 3 個

同様に
32=1*32 不適。
32=2*16 不適。
32=4*8  (33-4)*32の長方形。残りを1個で埋めることはできない。不適。
32=8*4  (33-8)*32の長方形。同様に不適。
32=16*2 (33-16)*32の長方形。同様に不適。
32=32*1 (33-32)*32の長方形。同様に不適。


また、1,4,7,8,9,10,14,15,18のすべて大きさの異なる9個の正方形で敷き詰めることができる。
前問の47と65の長方形の場合は、3,5,6,11,17,19,22,23,24,25の10個となる。

攻略法 「バックトラック法」

順列に従って配置する。perm(32,9)通りをすべて検証する。
!長方形(正方形)の正方形分割

LET t0=TIME

PUBLIC NUMERIC a,b !長方形の縦、横の長さ
LET a=33
LET b=32

PUBLIC NUMERIC M !相異なる大きさの正方形
LET M=MIN(a,b)
DIM S(M) !未使用の個数
MAT S=CON


PRINT a;"×";b

DIM R(a,b) !元の長方形
MAT R=ZER

PUBLIC NUMERIC ANSWER_COUNT !解答数
LET ANSWER_COUNT=0

CALL backtrack(R,S,0,1,1)

IF ANSWER_COUNT=0 THEN PRINT "解なし"


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

END


EXTERNAL SUB backtrack(R(,),S(),W,x0,y0) !バックトラック法で検証する
!IF W>9 THEN EXIT SUB !個数の制限 ※←←←←← ①

CALL serach(R,x0,y0,x,y) !配置位置
IF x>b AND y>a THEN !すべて埋め尽くされたら
   LET ANSWER_COUNT=ANSWER_COUNT+1
   PRINT "No.";ANSWER_COUNT; "個数=";W
   MAT PRINT USING(REPEAT$(" ##",b)): R

ELSE
   FOR i=M TO 1 STEP -1 !一辺iの正方形
      IF S(i)>0 THEN !未使用なら ※←←←←← ②

         CALL check(R,x,y,i, ok)
         IF ok=1 THEN !配置可能なら

            LET S(i)=S(i)-1 !使用中
            FOR dy=0 TO i-1 !置いてみる
               LET t=y+dy
               FOR dx=0 TO i-1
                  LET R(t,x+dx)=i
               NEXT dx
            NEXT dy

            CALL backtrack(R,S,W+1,x,y) !次へ

            LET S(i)=S(i)+1 !未使用
            FOR dy=0 TO i-1 !取り除く
               LET t=y+dy
               FOR dx=0 TO i-1
                  LET R(t,x+dx)=0
               NEXT dx
            NEXT dy

         END IF

      END IF ! ※←←←←←
   NEXT i
END IF
END SUB

EXTERNAL SUB serach(R(,),x0,y0, x,y) !空き位置を探す
LET y=y0 !その行
FOR x=x0 TO b
   IF R(y0,x)=0 THEN EXIT SUB
NEXT x
FOR y=y0+1 TO a !以降の行
   FOR x=1 TO b
      IF R(y,x)=0 THEN EXIT SUB
   NEXT x
NEXT y
END SUB

EXTERNAL SUB check(R(,),x,y,c, ok) !位置(x,y)に一辺cの正方形が配置可能かどうか確認する
LET ok=0
IF x+c-1>b THEN EXIT SUB !はみ出す
IF y+c-1>a THEN EXIT SUB
FOR dy=0 TO c-1
   LET t=y+dy
   FOR dx=0 TO c-1
      IF R(t,x+dx)<>0 THEN EXIT SUB !十分な空きがない
   NEXT dx
NEXT dy
LET ok=1 !可能!
END SUB
 

神の配列

 投稿者:GAI  投稿日:2010年 2月 3日(水)20時20分43秒
  11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08 08
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 09 09 09 09 09 09 09 09 09 06 06 06 06 06 06 06 06 06 06 06 06 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 04 04 04 04 04 04 04 04 03 03 03 02 02 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 04 04 04 04 04 04 04 04 03 03 03 02 02 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 04 04 04 04 04 04 04 04 03 03 03 02 02 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 04 04 04 04 04 04 04 04 03 03 03 02 02 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 04 04 04 04 04 04 04 04 03 03 03 05 05 05 05 05 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 04 04 04 04 04 04 04 04 03 03 03 05 05 05 05 05 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 04 04 04 04 04 04 04 04 03 03 03 05 05 05 05 05 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 08 08 08 08 08 08 08 08 04 04 04 04 04 04 04 04 03 03 03 05 05 05 05 05 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05 01 03 03 03 05 05 05 05 05 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05 09 09 09 09 09 09 09 09 09 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05 09 09 09 09 09 09 09 09 09 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05 09 09 09 09 09 09 09 09 09 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05 09 09 09 09 09 09 09 09 09 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05 09 09 09 09 09 09 09 09 09 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05 09 09 09 09 09 09 09 09 09 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05 09 09 09 09 09 09 09 09 09 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05 09 09 09 09 09 09 09 09 09 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 10 10 10 10 10 10 10 10 10 10 05 05 05 05 05 09 09 09 09 09 09 09 09 09 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 07 07 07 07 07 07 07 11 11 11 11 11 11 11 11 11 11 11
10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09
 

Re: 神の配列

 投稿者:山中和義  投稿日:2010年 2月 4日(木)10時48分23秒
  > No.1003[元記事へ]

作業
 同じものがあるときの順列を生成する。
 これを元に、文書を読むように左上から順序よく、正方形の左上を基準に埋めていく。
 埋まらない(はみ出す、十分な空きがない)場合、次の順列へ。

場合の数
 (1+2+…+11+12)!/(1!*2!*…*11!*12!)
=88947676160040791974346016626050476411997512534477592385407365120000000

作業は単純なのですが、どうやって求めたのでしょうか?(答え かみわざ)
 

Re: 神の配列

 投稿者:GAI  投稿日:2010年 2月 4日(木)19時54分47秒
  > No.1004[元記事へ]

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

> 場合の数
>  (1+2+…+11+12)!/(1!*2!*…*11!*12!)
>  =88947676160040791974346016626050476411997512534477592385407365120000000
>
> 作業は単純なのですが、どうやって求めたのでしょうか?(答え かみわざ)

そうなんです。
これはコンピュータで解析出来るものなのか疑問だったんです。
これを求める人間の直感力の凄さにただただ驚愕するばかりです。(まさに神業)

そこで次に可能なnはとなると深遠なる谷底を見る思いです。

ついでに
3^3+4^3+5^3=6^3
なる関係が成立することから、
一辺が3の立方体と
一辺が4の立方体と
一辺が5の立方体を
幾つかの小部品に分割して(できればすべて異なる形で)、全部を組み直して組み立てると
一辺が6の立方体を構成できる可能性を示唆する。
 

Re: 固有値と「べき乗法」/POWER METHOD

 投稿者:山中和義  投稿日:2010年 2月 4日(木)22時01分20秒
  > No.1006[元記事へ]

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

> 然し、固有値は「絶対最大の固有値」のみです。
> その他の固有値はこの値から出るのでしょうか。

固有ベクトルも同時に求めていると思います。
それと固有値から残差行列を求めて、次に大きいものを求めます。No.162 [元記事へ]
 

次なる疑問

 投稿者:GAI  投稿日:2010年 2月 5日(金)05時54分22秒
  1^2+2^2+3^2+・・・+n^2=1/6*n*(n+1)*(2n+1)
でn=24の時
1^2+2^2+3^2+・・・+24^2=70^2
なので、一辺が70の正方形を
一辺が1,2,3,・・・,24の正方形で敷き詰めることの可能性を含みますが、果たして
これは実現するのでしょうか?

例の 24!=620448401733239439360000
という天文学的調査が必要になるんでしょうか?
 

Re: 次なる疑問

 投稿者:山中和義  投稿日:2010年 2月 5日(金)09時48分6秒
  > No.1008[元記事へ]

GAIさんへのお返事です。

> 例の 24!=620448401733239439360000 という天文学的調査が必要になるんでしょうか?


並びが大きい順から考えると、最初は、24,23,22,21,…,3,2,1 となる。
左上から順に文書を読むように右へ、24,23,22 と置けるが、21を1行80桁目に置けない。
したがって、ここでこの手は終了して、次の24,23,22,21,…,3,1,2 となる。
ここで、同様に21は置けない。

これは、24,23,22,21,20,19,18,…,2,1 から 24,23,22,21,1,2,3,…,19,20 までが置けないことを意味する。
したがって、24,23,22,21,… (20!通り)は検証を省くことができる。(枝刈り)

このような処理をバックトラック法に組込んでいるので、場合の数はベタな値ではありません。
でもスキップされた結果が、まだ天文学的な数値ならお手上げです。

サンプルプログラム No.1001 [元記事へ] 先頭部分を次のように変更する。
(これ以前は略)

PUBLIC NUMERIC a,b !長方形の縦、横の長さ
LET a=70
LET b=70

PUBLIC NUMERIC M !相異なる大きさの正方形
LET M=24
DIM S(M) !未使用の個数
MAT S=CON !すべて1個ずつ

(以下同じ)


逆の問題
 いくつかの長方形(正方形も含む)を並べる。それを囲む最小(面積)の長方形(正方形も含む)は?

  +--------+
  | ┌─┐|
  |┌┤ │|
  |├┴─┤|
  |│  │|
  |│  │|
  |└──┘|
  +--------+


補足
 1^3+2^3+3^3+ … +n^3=1*1^2+2*2^2+3*3^2+ … +n*n^2=(n*(n+1)/2)^2 の場合
(これ以前は略)

PUBLIC NUMERIC a,b !長方形の縦、横の長さ
LET N=12 !←←←←←
LET a=N*(N+1)/2
LET b=a

PUBLIC NUMERIC M !相異なる大きさの正方形
LET M=N
DIM S(M) !未使用の個数
FOR i=1 TO M
   LET S(i)=i
NEXT i

(以下同じ)

何年か後に求まります。(笑い)
 

江戸時代の問題

 投稿者:GAI  投稿日:2010年 2月 6日(土)13時03分33秒
  大きな樽に油が32升入っている。
10升枡3つと7升枡1つで、32升を8升ずつ4つに分けよ。

これは藤岡茂之著「算之記」(1657年)にある問題だそうで、途中まで経過が記してあるが途中の経過が省略されて紹介されていました。
いろいろ試していましたが、根気負けの状態です。
ぜひ最短手数を調べて下さい。


32升枡   10升枡   10升枡   10升枡    7升枡
 32      0      0      0      0
  5     10     10      0      7
  5     10     10      7      0
  5      3     10      7      7
  0      8     10      7      7
・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・
・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・
・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・
  8      8      8      8      0
 

Re: 江戸時代の問題

 投稿者:山中和義  投稿日:2010年 2月 6日(土)20時38分55秒
  > No.1011[元記事へ]

GAIさんへのお返事です。

> ぜひ最短手数を調べて下さい。

分量は32,10,10,10,7の順
解= 26 手
 26:  8  8  8  8  0
 25:  1  8  8  8  7
 24:  1  8  8 10  5
 23: 11  8  8  0  5
 22: 11  8  8  5  0
 21:  4  8  8  5  7
 20:  4  8  8 10  2
 19: 14  8  8  0  2
 18: 14  8  8  2  0
 17:  7  8  8  2  7
 16:  7  8  8  9  0
 15:  0  8  8  9  7
 14:  0  8  8 10  6
 13:  8  8  0 10  6
 12:  8  8  6 10  0
 11:  8  1  6 10  7
 10:  8  7  6  4  7
  9: 15  7  6  4  0
  8: 15  0  6  4  7
  7: 15  0 10  4  3
  6: 15  3 10  4  0
  5: 15  3 10  0  4
  4: 15  3  7  0  7
  3: 15 10  7  0  0
  2: 15 10  0  0  7
  1: 22 10  0  0  0
  0: 32  0  0  0  0
 

Re: 江戸時代の問題

 投稿者:GAI  投稿日:2010年 2月 7日(日)06時27分57秒
  > No.1012[元記事へ]

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


お見事です。!!!
これはどうやって探せるんですか?
もしプログラムでやられたら是非拝見させて下さい。
 

Re: 江戸時代の問題

 投稿者:山中和義  投稿日:2010年 2月 7日(日)09時43分40秒
  > No.1013[元記事へ]

GAIさんへのお返事です。

> これはどうやって探せるんですか?
> もしプログラムでやられたら是非拝見させて下さい。


手作業と同様に手を重ねて、樹形図を作成します。
1つ前の手から、今回の手20通り(Perm(5,2))をすべて展開していきます。
ただ、「元に戻る」、「以前の手」などの展開はしません。

樹形図の例
(32,0,0,0,0)
  →(22,10,0,0,0)
    →(12,10,10,0,0)
    →(12,10,0,10,0)
    →(15,10,0,0,7)
    →(22,3,0,0,7)
  →(22,0,10,0,0)
    →(12,0,10,10,0)
    →(15,0,10,0,7)
    →(22,0,3,0,7)
  →(22,0,0,10,0)
      :
  →(25,0,0,0,7)
      :

この樹形図は、「(単方向)リスト」と呼ばれるデータ構造で、BASICにはありません。
そこで、配列変数Q(,)を使って実装しています。

終了パターンが見つかると、この矢印を遡りその過程を表示します。

サンプル・プログラム ※2進モードで実行のこと
!油分け算
! 32リットルの容器に水が一杯に満たされている。
! この容器とは別に、10リットルの空の容器が3つ、7リットルの空の容器が1つある。
! これらの容器を用いて、8リットルずつに分けたい。どうしたらよいか?

LET C=5 !容器の数 ※←←←←←
!LET C=4
!LET C=3

DIM B(C) !容器の容量 ※←←←←←
DATA 32,10,10,10,7
!DATA 21,11,8,5
!DATA 10,7,3
MAT READ B

! 1. 容器いっぱいに水を満たす
! 2. 容器を空にする
! 3. 他の容器に水を移す
DIM W(C)
SUB move(x,y) !xからyへ移動する
   LET t=MIN(W(x),B(y)-W(y)) !分量を算出する
   LET W(x)=W(x)-t
   LET W(y)=W(y)+t
END SUB

DIM Q(0 TO 8000,0 TO C) !配分のパターン(局面) ※樹形図
MAT Q=ZER
DATA 32,0,0,0,0 !容器の初期状態 ※←←←←←
!DATA 21,0,0,0
!DATA 10,0,0
FOR i=1 TO C
   READ Q(0,i)
NEXT i
LET Q(0,0)=-1 !単方向リスト ※番兵

DIM G(C) !最終パターン ※←←←←←
DATA 8,8,8,8,0
!DATA 7,7,7,0
!DATA 5,5,0
MAT READ G

LET top=0 !n手目の展開
LET btm=0
LET n=0
DO WHILE n<=30 !手の上限 ※幅優先探索
   PRINT n; top;btm !debug

   LET new_btm=btm

   FOR i=top TO btm !(n+1)手目へと展開する
      DIM M(C)
      FOR k=1 TO C !元パターンを復元する
         LET M(k)=Q(i,k)
      NEXT k

      FOR h=0 TO Perm(C,2)-1 !移動は高々20通り
         DIM P(2)
         CALL Num2Perm(h,P,C,2)
         MAT W=M !restore it
         CALL move(P(1),P(2)) !移動してみる

         FOR x=new_btm TO 0 STEP -1 !最新のものから順に、既出のパターンかどうか確認する
            FOR k=1 TO C
               IF W(k)<>Q(x,k) THEN EXIT FOR
            NEXT k
            IF k>C THEN EXIT FOR !一致する
         NEXT x
         IF x<0 THEN !新しい局面なら、登録する

            LET new_btm=new_btm+1 !登録位置を算出する
            FOR k=1 TO C !パターン
               LET Q(new_btm,k)=W(k)
            NEXT k
            LET Q(new_btm,0)=i !リンクする


            FOR k=1 TO C !終了パターンかどうか確認する
               IF W(k)<>G(k) THEN EXIT FOR
            NEXT k
            IF k>C THEN !解を表示する

               LET d=n+1
               PRINT "解=";d;"手"
               LET x=new_btm !記録を元に「手」を遡る
               DO UNTIL x<0
                  PRINT USING "###:": d;
                  FOR k=1 TO C
                     PRINT USING "###": Q(x,k);
                  NEXT k
                  PRINT

                  LET x=Q(x,0) !後方へ
                  LET d=d-1
               LOOP

               LET new_btm=new_btm-1 !他を探すため登録しない
               !!!STOP

            END IF

         END IF
      NEXT h

   NEXT i

   LET n=n+1 !次へ
   LET top=btm+1
   LET btm=new_btm
LOOP

END


EXTERNAL SUB Num2Perm(h, A(),N,R) !番号から順列パターンを生成する ※辞書式順序
LET v=h !非負の10進数整数を(階乗)進数へ
FOR j=1 TO R
   LET w=N-R+j
   LET t=INT(v/w)
   LET A(R-j+1)=v-t*w +1 !(階乗)進数の各桁の値+1 A[1..R]=PERM(N-1,R-1) … PERM(N-j,R-j) … PERM(N-R,0)
   LET v=t
NEXT j
FOR j=R-1 TO 1 STEP -1 !順列パターンへ
   FOR k=j+1 TO R
      IF A(k)>=A(j) THEN LET A(k)=A(k)+1
   NEXT k
NEXT j
END SUB


!アルゴリズム、パズル、幅優先探索、単方向リスト
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 2月 8日(月)14時40分55秒
  > No.1001[元記事へ]

容器が2つの場合には、このような手法がある。

●水をはかる問題、水差し問題


容積が7リットルと3リットルの容器を使って、5リットルの水を汲むには、どうしたらよいか?

攻略法 合同式、一次不定方程式
 3リットルの容器で汲み、その後7リットルの容器に移し替える。いっぱいになれば捨てる。
  3*x≡5 (mod 7)より、x≡4 (mod 7)、4段階。
 7リットルの容器では
  7*x≡5 (mod 3)より、x≡2 (mod 3)、2段階。
!水を計る問題、水差し問題

LET a=3 !容器の容量 3*x≡5 (mod 7)の意
LET b=7
!LET a=7 !7*x≡5 (mod 3)
!LET b=3

LET v=5 !計りたい容量

IF (v>a AND v>b) OR MOD(v,GCD(a,b))<>0 THEN
   PRINT "計れません。"
   STOP
END IF

LET x=0 !容器Aの状態
LET y=0 !容器Bの状態

LET n=1 !手
DO
   IF x=0 THEN
      PRINT
      PRINT "Aに水を満たす。"
      LET x=a
   ELSEIF y=b THEN
      PRINT "Bを空にする。"
      LET y=0
   ELSEIF x<b-y THEN
      PRINT "Aの水をすべてBに移す。"
      LET y=y+x
      LET x=0
   ELSE
      PRINT "Aの水をBがいっぱいになるまでBに移す。"
      LET x=x-(b-y)
      LET y=b
   END IF

   PRINT n;"手:"; x;y


   LET n=n+1 !次へ

LOOP UNTIL x=v OR y=v !条件を満たすまで

PRINT
IF x=v THEN
   PRINT "Aに計れました。"
ELSE
   PRINT "Bに計れました。"
END IF

END


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


同様に

●油分け算

塵劫記より
 問(1桶2枡)
 10升の油が桶に入っている。
 7升枡と3升枡を使って、半分の5升の油に分けたいが、どうしたらよいか。

小学生向けに変更すると
 問
 1リットル入りボトルに入ったジュースを
 7デシリットルと3デシリットルのコップを使って二等分しなさい。

攻略法 グラフ
!油分け算
! 10リットルの容器に油が一杯に満たされている。
! この容器とは別に、7リットルと3リットルの空の容器が1つずつある。
! これらの容器を用いて、5リットルずつに分けたい。どうしたらよいか?

DIM B(3) !容器の容量
DATA 10,7,3
MAT READ B

! 1. 容器いっぱいに水を満たす
! 2. 容器を空にする
! 3. 他の容器に水を移す
DIM W(3)
SUB move(x,y) !xからyへ移動する
   LET t=MIN(W(x),B(y)-W(y)) !分量を算出する
   LET W(x)=W(x)-t
   LET W(y)=W(y)+t
END SUB

DATA 10,0,0 !容器の初期状態
MAT READ W

SET WINDOW -1,8,-1,8 !表示領域
DRAW grid

LET xx=0
LET yy=0

FOR n=0 TO 2*(B(2)+B(3))/GCD(B(2),B(3))-1 !手の上限 ※反復深化
   PRINT n;"手目"
   MAT PRINT W;

   !ツィーディー(M.C.K.Tweedie)のグラフによる解法の図式化
   DRAW disk WITH SCALE(0.1)*SHIFT(W(2),W(3))
   SET TEXT HEIGHT 0.3
   PLOT TEXT ,AT W(2)+0.2,W(3): STR$(n)
   PLOT LINES: xx,yy; W(2),W(3);
   LET xx=W(2) !save it
   LET yy=W(3)


   !容器の容量は、容器1>容器2>容器3とする。
   !1→2→3→1 →2→3→1 … と順に「油の移動」をみていく。
   !この順で移し替えを行うとき、既出のパターンと同じになるときは「一回飛ばし」を行う。

   IF W(2)=0 THEN !容器2は空か?
      CALL move(1,2) !容器1からいっぱいに注ぐ(汲む)
   ELSE
      IF W(3)=B(3) THEN !容器3はいっぱいか?
         CALL move(3,1) !容器1に戻す(戻す)
      ELSE
         CALL move(2,3) !容器2からいっぱいに注ぐ(移す)
      END IF
   END IF

NEXT n

END


EXTERNAL FUNCTION GCD(a,b) !最大公約数を求める
DO UNTIL b=0
   LET r=MOD(a,b)
   LET a=b
   LET b=r
LOOP
LET GCD=a
END FUNCTION

一般的な解法では、

攻略法 樹形図
 手を重ねていく(幅優先探索) No.1014 [元記事へ]
 

Re: センター試験程度のプログラム演習

 投稿者:GAI  投稿日:2010年 2月 9日(火)05時57分32秒
  > No.1015[元記事へ]

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

> 容器が2つの場合には、このような手法がある。
>
>    !ツィーディー(M.C.K.Tweedie)のグラフによる解法の図式化

この図解がわかりやすかったです。
この人は塵劫記を読んだんでしょうかね?

山中さんが作られたプログラムでいろいろ遊んでいたら、
40リットルの容器に満タンにある油を
11リットルの容器3つと9リットル容器1つを使って
10リットルずつ4つに分ける手数が38手もかかることが、面白かったです。
(1リットルの差は大きい。)

一般に2つの容器A,Bでその容積が互いに素なら、1~max(A,B) の体積が1単位毎に計れると考えていいんですかね?(ただし中のものは捨るのを許す。)


これらに使われる数学的構造は、天秤や砂時計での重さや時間を計るパズルに通じるものがあるような気がします。
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 2月 9日(火)09時27分28秒
  > No.1016[元記事へ]

GAIさんへのお返事です。

> 一般に2つの容器A,Bでその容積が互いに素なら、1~max(A,B) の体積が1単位毎に計れると考えていいんですかね?

2つの容器を「両方を使う」とすると、

 容器Aで汲み、その後容器Bに移す。いっぱいになれば捨てる。合同式 A*x≡C (mod B)

これは、1*A,2*A,3*A, … , (B-1)*A,B*A をBで割った余りCを考えることになります。
AとBは互いに素なので、Cは0,1,2,3, … , B-1が1つずつ現れます。

したがって、0~A+Bまで1刻みで計れると思います。

参考
 「ツィーディー(M.C.K.Tweedie)のグラフによる解法」のグラフで
 3×7の長方形の格子点でのA+Bを表示する。

 手の番号を表示する箇所
  PLOT TEXT ,AT W(2)+0.2,W(3): STR$(n)
 を
  PLOT TEXT ,AT W(2)+0.2,W(3): STR$(W(2)+W(3))
 と変更する。

ところで

 問い
 7リットルと3リットルの容器を使って、5リットルの水を汲むには、どうしたらよいか?

の別解として
 容器が升みたいな直方体なら、斜めに傾けて水を半分捨てると、7/2+3/2=5 より

 7リットルの容器に水を汲み、斜めに傾けて半分捨てる。
 3リットルの容器に水を汲み、斜めに傾けて半分捨てる。

このようなトンチもありますが、、、 そこで

> 40リットルの容器に満タンにある油を
> 11リットルの容器3つと9リットル容器1つを使って
> 10リットルずつ4つに分ける手数が38手もかかることが、面白かったです。

11/2+9/2=10
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 2月 9日(火)10時43分52秒
  > No.1016[元記事へ]

GAIさんへのお返事です。

追伸

> 40リットルの容器に満タンにある油を
> 11リットルの容器3つと9リットル容器1つを使って
> 10リットルずつ4つに分ける手数が38手もかかることが、面白かったです。
> (1リットルの差は大きい。)

「11リットルの容器と9リットル容器を1つずつで10リットルを計る」で
2容器問題に帰着できます。(前回の問題も同様)

最適解ではないですが、残り2つの11リットルの容器に対して、
繰り返すことで求めることもできます。
 

なんて俺の頭は石頭か!

 投稿者:GAI  投稿日:2010年 2月 9日(火)13時04分38秒
  目から鱗が剥がれました。
二度と鱗が着かないように毎日目薬をさします。
 

石頭からの疑問

 投稿者:GAI  投稿日:2010年 2月10日(水)17時06分8秒
  自然数nの分割方法で
5=1+1+1+1+1
 =1+1+1+2
 =1+1+3
 =1+2+2
 =1+4
 =2+3
 =5
と7通りの方法が存在する。

一般に自然数nの分割方法をp(n)とするとき
nをk個に分割する方法をp(k,n)で表せば

p(n)=Σk=1~n p(k,n)


p(1,n)=p(n,n)=1
p(k,n)=p(k-1,n-1)+p(k,n-k)

なる漸化式もどきが成立するが(2番目の式がなにかがよく掴めないが・・・)
p(n)の一般式を表す式は存在しないと書かれていた。
また一方で

n:p(n)
0 1
1 1
2 2
3 3
4 5
5 7
6 11
7 15
8 22
9 30
10 42
11 56
12 77
13 101
14 135
15 176
16 231
17 297
18 385
19 490
20 627
21 792
22 1002
23 1255
24 1575
25 1958
26 2436
27 3010
28 3718
29 4565
30 5604
31 6842
32 8349
33 10143
34 12310
35 14883
36 17977
37 21637
38 26015
39 31185
40 37338
41 44583
42 53174
43 63261
44 75175
45 89134
46 105558
47 124754
48 147273
49 173525
50 204226
51 239943
52 281589
53 329931
54 386155
55 451276
56 526823
57 614154
58 715220
59 831820
60 966467
61 1121505
62 1300156
63 1505499
64 1741630
65 2012558
66 2323520
67 2679689
68 3087735
69 3554345
70 4087968
71 4697205
72 5392783
73 6185689
74 7089500
75 8118264
76 9289091
77 10619863
78 12132164
79 13848650
80 15796476
81 18004327
82 20506255
83 23338469
84 26543660
85 30167357
86 34262962
87 38887673
88 44108109
89 49995925
90 56634173
91 64112359
92 72533807
93 82010177
94 92669720
95 104651419
96 118114304
97 133230930
98 150198136
99 169229875
100 190569292
・・・・・・・・
(以下すごい数まで調べられている。)
なる表も存在している。
じゃーこれは一体どのようにして計算されたものであるのか?
という疑問が湧いてくる。

ネットで調べるとオイラーの五角数定理だの母関数だのと解説されているが、私一人では解読に至りません。
もしこれに精通された方がおられましたら、プログラムはどう組み、どんな手順でこんな手作業では不可能なところまでの値が求められていくのか解説をお願いします。
 

Re: 石頭からの疑問

 投稿者:山中和義  投稿日:2010年 2月10日(水)19時48分20秒
  > No.1020[元記事へ]

GAIさんへのお返事です。

> じゃーこれは一体どのようにして計算されたものであるのか?

漸化式をそのまま記述すれば
!分割数(partition number)

FUNCTION p(n,k)
   IF k=1 OR k=n THEN !p(n,1)=p(n,n)=1
      LET p=1
   ELSEIF n<k THEN !p(n,k)=p(n-k,k)+p(n-1,k-1)
      LET p=0
   ELSE
      LET p=p(n-k,k)+p(n-1,k-1)
   END IF
END FUNCTION

FOR i=1 TO 30 !1~30まで

   LET pn=0
   FOR k=1 TO i !p(n)=Σ[k=1,n]p(n,k)
      LET pn=pn+p(i,k)
   NEXT k
   PRINT i; pn

NEXT i

END

組合せ(comb(n,r))やフィボナッチ数列なども再帰関数で計算できます。
ただ、毎回最初に戻って値を確定するので、nが多くなると負荷がかかります。
(遅くなるし、システム領域がなくなる(スタックオーバーフローが発生する)


表計算のように結果を残しながら、nを1から順に求めるのがいいでしょう。
(計算は速いが、メモリは浪費する)

参考 パスカルの三角形
!分割数(partition number)

LET N=30

DIM p(N,N) !左下充填の行列をつくる
MAT p=ZER !n<kならp(n,k)=0
FOR i=1 TO N
   LET p(i,1)=1 !p(n,1)=1
   LET p(i,i)=1 !p(n,n)=1
NEXT i
FOR i=1 TO N !左上から順に計算していく
   FOR k=2 TO i-1
      LET p(i,k)=p(i-k,k)+p(i-1,k-1) ! !p(n,k)=p(n-k,k)+p(n-1,k-1)
   NEXT k
NEXT i
MAT PRINT USING(REPEAT$(" ####",N)): p !debug

FOR i=1 TO N !1~Nまで

   LET pn=0 !p(n)=Σ[k=1,n]p(n,k)
   FOR k=1 TO i
      LET pn=pn+p(i,k) !列の和
   NEXT k
   PRINT i; pn

NEXT i

END

※計算の都合上、提示された漸化式の行と列を入れ替えています。(転置)



> オイラーの五角数定理だの母関数だのと解説されているが、
!分割数(オイラーの五角数定理)

LET N=30

DIM a(0 TO N),p(0 TO N)
MAT a=ZER
MAT p=ZER

LET i=0
LET j=i*(3*i-1)/2
DO
   IF MOD(i,2)=1 THEN !奇数なら
      LET a(j)=a(j)-1
   ELSE !偶数なら
      LET a(j)=a(j)+1
   END IF
   LET i=i+1
   LET j=i*(3*i-1)/2
LOOP WHILE j<=N

LET i=0
LET j=i*(3*i+1)/2
DO
   IF MOD(i,2)=1 THEN !奇数なら
      LET a(j)=a(j)-1
   ELSE !偶数なら
      LET a(j)=a(j)+1
   END IF
   LET i=i+1
   LET j=i*(3*i+1)/2
LOOP WHILE j<=N

LET p(0)=1
FOR i=1 TO N
   FOR j=0 TO i-1
      LET p(i)=p(i)-p(j)*a(i-j)
   NEXT j
NEXT i

FOR i=0 TO N !結果を表示する
   PRINT i; a(i); p(i)
NEXT i

END
 

Re: 固有ベクトルの求め方。

 投稿者:山中和義  投稿日:2010年 2月11日(木)15時04分56秒
  > No.1022[元記事へ]

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

> 直接法で固有値がわかってから固有ベクトルをどう求めるのでしょうか。
!直接法による行列の固有値と固有ベクトルを求める

OPTION ARITHMETIC COMPLEX

LET cEps=1e-8 !誤差 ※単精度


LET N=3 !N次正方行列

FUNCTION tr(A(,)) !行列Aのトレース
   LET t=0
   FOR i=1 TO N
      LET t=t+A(i,i)
   NEXT i
   LET tr=t
END FUNCTION


SUB DKA_00(N,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*COMPLEX(0,1)/N *(j-3/4) ) !アーバスの初期値
   NEXT j

   FOR m=0 TO 100 !反復 ※調整要
      LET mfx=0
      LET maj=0
      FOR j=1 TO N
         LET fx=1
         LET Xk=1
         FOR w=1 TO N
            LET fx=fx*Xr(j)+A(w) !分子 f(zj) ※ホーナー法
            IF w<>j THEN LET Xk=Xk*(Xr(j)-Xr(w)) !分母 Π(zw-zj)
         NEXT w
         LET Xr(j)=Xr(j)-fx/Xk !k回目の近似根
         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

SUB poly_divByLin(A(),v, Q(),R) !多項式a(x)をx-αで割ったときの商q(x)と余りrを求める
   MAT Q=ZER
   LET s=0
   FOR i=0 TO N !ホーナーの方法
      LET Q(i)=s !※「係数にxを掛けて次の係数を加える」が組立除法になる
      LET s=s*v+A(i) !(…(((A0*X+A1)*X+A2)*X+A3)*X+…+An-1)*X+An
   NEXT i
   LET R=s
END SUB
!-------------------- ここまでがサブルーチン


DIM A(N,N) !n次正方行列A
DATA 1,1,0 !λ=5,1,0
DATA 1,2,1
DATA 2,5,3

MAT READ A
MAT PRINT A;


!n次正方行列Aの固有多項式(eigenpolynomial) ΦA(t)=det(tE-A)=t^n+c1*t^(n-1)+ … + cn を求める。
DIM c(N) !多項式 X^N+c(1)*X^(N-1)+c(2)*X^(N-2)+ … +c(N-1)*X+c(N) の係数
DIM X(N,N),cE(N,N) !作業用

!Frame法、Leverrir-Faddeev法
! adj(s*I-A)=s^(n-1)*I+s^(n-2)*β1+ … +s*βn-2+βn-1
! det(s*I-A)=s^n+α1*s^(n-1)+ … + αn-1*s+αn
!のとき
! β0=I、k=1~nについて
!  Xk=A*βk-1
!  αk=-trace(Xk)/k
!  βk=Xk+αk*I
!の逐次計算でαk、βkが求まる。

MAT X=IDN !adj(s*I-A)
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; !det(s*I-A) 係数 1,c(1),c(2), …

!固有方程式(proper equation)ΦA(t)=0 をニュートン法などで解く。解が固有値になる。
DIM lambda(N)
CALL DKA_00(N,c,lambda) !ここではDKA法

!上記より、ΦA(t)=t^n+c1*t^(n-1)+ … + cn=(t-λ1)*(t-λ2)* … *(t-λn)

DIM P(0 TO N),Q(0 TO N) !固有ベクトルを求める
FOR i=1 TO N
   LET P(i)=c(i)
NEXT i
LET P(0)=1

FOR k=1 TO N
   PRINT "固有値=";lambda(k)

   CALL poly_divByLin(P,lambda(k), Q,R) !(t-λ1)で割った商(t-λ2)* … *(t-λn)を求める
   !!!MAT PRINT Q; !debug
   !!!PRINT "R=";R !debug 0になる!

   !行列 (A-λ2*E)* … *(A-λn*E)=q1*A^(n-1)+q2*A^(n-2)+ … +qn-1*A+qn*E を計算する
   MAT X=ZER
   FOR i=1 TO N !ホーナー法
      MAT X=X*A
      MAT cE=(Q(i))*IDN
      MAT X=X+cE
   NEXT i
   !!!MAT PRINT X; !debug

   DIM v(N)
   FOR i=1 TO N !これを列ベクトルでみる。k列目を採用する。
      LET v(i)=X(i,k)
   NEXT i
   LET s=SQR(DOT(v,v)) !正規化する
   IF s<>0 THEN MAT v=(1/s)*v

   PRINT "固有ベクトル="
   MAT PRINT v;

NEXT k


END


他に、逆反復法で求めることもできます。(調査中)
 

Spigot algorithms

 投稿者:M.N  投稿日:2010年 2月12日(金)10時29分16秒
  (Spigot algorithms こつこつ方法)
こつこつ方法で定数を数値展開すると1桁ずつ生成できます。
繰り上がりを考える必要がないので、eに対してはこれが
特に簡単です。.....中略......次のアルゴリズムは、eの
数値展開を作り出します。

長さn+1の配列Aを1に初期化します。そして、次をn-1回
繰り返します。

(a) Aの各要素に10を掛けます。
(b) 右から始めて、Aの第i要素をi+1を法として導き、
割り算の商を左隣の桁へ持って行きます。作り出された
最後の商がeの次の桁の数になります。

このアルゴリズムは高速に収束する級数e=Σ(n=0 to ∞)(1/n!)
を単純に書き直した次の式に基づいています。

e=1+1/1(1+1/2(1+1/3(1+1/4(1+1/5(1+......)))))
--------------------------------------------------------
以上 数学を生み出す魔法のるつぼ(Jonathan Borwein
Keith Devlin 伊知地 宏 訳  オライリ-ジャパン)より

以上のアルゴリズムでプログラムを作るとどうなるでしょうか。
どなたかわかる方ご教示お願いします。言語はできるだけBASIC
でお願いします。
(数学愛好者/質問者)
 

Re: Spigot algorithms

 投稿者:山中和義  投稿日:2010年 2月12日(金)11時50分14秒
  > No.1025[元記事へ]

M.Nさんへのお返事です。

> 長さn+1の配列Aを1に初期化します。そして、次をn-1回
> 繰り返します。
>
> (a) Aの各要素に10を掛けます。
> (b) 右から始めて、Aの第i要素をi+1を法として導き、
> 割り算の商を左隣の桁へ持って行きます。作り出された
> 最後の商がeの次の桁の数になります。

そのままコード化すると、、、
LET N=20
DIM A(0 TO N) !長さn+1の配列Aを1に初期化します。
MAT A=CON
FOR k=1 TO N-1 !そして、次をn-1回繰り返します。
!!!MAT PRINT A; !trace
   MAT A=10*A !(a) Aの各要素に10を掛けます。
   FOR i=N TO 1 STEP -1 !(b) 右から始めて、
      LET Q=INT(A(i)/(i+1)) !Aの第i要素をi+1を法として導き、
      LET A(i)=A(i)-Q*(i+1)
      LET A(i-1)=A(i-1)+Q !割り算の商を左隣の桁へ持って行きます。
   NEXT i
   PRINT Q !作り出された最後の商がeの次の桁の数になります。
   LET A(0)=0 !※累積されるので、オーバーフローとなる。これを防ぐ!
NEXT k
END
 

Spigot algorithms

 投稿者:M.N  投稿日:2010年 2月12日(金)11時56分1秒
  すばやい対応に感謝します。ありがとうございました。  

Spigot algorithms

 投稿者:M.N  投稿日:2010年 2月12日(金)14時48分36秒
  M.Nです。たびたびお邪魔して申し訳ございません。Spigot algorithms を用いて
SIN(20)の値などをたとえば10000桁求めることなどできるのでしょうか。
できるならプログラムをどう書き換えたらよろしいでしょうか。
 

Re: Spigot algorithms

 投稿者:山中和義  投稿日:2010年 2月12日(金)18時55分35秒
  > No.1028[元記事へ]

M.Nさんへのお返事です。

> Spigot algorithms を用いて
> SIN(20)の値などをたとえば10000桁求めることなどできるのでしょうか。

順に求まる下位桁からの「桁上り」(1桁にならない場合のこと)を考慮すればできると思います。

以下は、その心配がない範囲の改修です。
!テイラー展開より
!   e^x=1+x/1!+x^2/2!+x^3/3!+x^4/4!+x^5/5!+ …
! sin(x)=  x/1!       -x^3/3!       +x^5/5!  …
!
!xのべき乗の係数A(i)を比較すると、
!   e^xは、1,1,1, 1,1,1,…
! sin(x)は、0,1,0,-1,0,1,…
!
!計算手順
! e^x=((((( … +1)*x/5+1)*x/4+1)*x/3+1)*x/2+1)*x/1+1

!x=1、すなわちsin(1)なら
LET x=1

LET N=15
DIM A(0 TO N) !長さn+1の配列Aを0,1,-1に初期化します。
FOR i=0 TO N
   IF MOD(i,2)=1 THEN LET A(i)=(-1)^INT(i/2)
NEXT i
FOR k=1 TO N-1 !そして、次をn-1回繰り返します。
!!!MAT PRINT A; !trace
   MAT A=10*A !(a) Aの各要素に10を掛けます。
   FOR i=N TO 1 STEP -1 !(b) 右から始めて、
      LET Q=INT(A(i)*x/i) !Aの第i要素をiを法として導き、
      LET A(i)=A(i)-Q*i/x
      LET A(i-1)=A(i-1)+Q !割り算の商を左隣の桁へ持って行きます。
   NEXT i
   PRINT Q !作り出された最後の商がeの次の桁の数になります。
   LET A(0)=0 !※累積されるので、オーバーフローとなる。これを防ぐ!
NEXT k


PRINT SIN(x) !検算

END
 

Spigot algorithms

 投稿者:M.N  投稿日:2010年 2月13日(土)10時46分16秒
  再三再四のお返事ありがとうございました。大変勉強になりました。
お忙しい中、まことに恐縮ですがもうひとつだけお頼みしたいことがあります。Π(PAI)の値を求める時はどうすればよろしいのでしょうか。自分でやってみたのですが、うまくできませんでした。
PAI=2+1/3(2+2/5(2+3/7(2+....(2+k/(2k+1)+...))))
 

Re: Spigot algorithms

 投稿者:山中和義  投稿日:2010年 2月13日(土)11時55分44秒
  > No.1030[元記事へ]

M.Nさんへのお返事です。

> PAI=2+1/3(2+2/5(2+3/7(2+....(2+k/(2k+1)+...))))

計算手順
 π=((((( … +2)*5/11+2)*4/9+2)*3/7+2)*2/5+2)*1/3+2

  e=((((( … +1)/5+1)/4+1)/3+1)/2+1)/1+1

ここでeの場合、プログラム(前出)の意味は

式の「+1」の部分
 MAT A=CON !長さn+1の配列Aを1に初期化します。

式の「/5,/4,…,/2,/1」の部分
 LET Q=INT(A(i)/i) !Aの第i要素をiを法として導き
 LET A(i)=A(i)-Q*i

ですので、πの方に比較対応させると良いでしょう。

実験数学ですから、プログラムで試行錯誤すればよいかと思います。


途中の計算は割り切れない可能性があるので、有理数(分数)で計算する必要があります。
 LET A(i)=A(i)-Q* (2*i+1)/i の部分

漸化式の収束の関係で、精度は先頭から3分の1程度です。

また、2桁で表示されるときは、その前の数値に桁上げする必要があります。(前記載の問題点より)
!漸化式
! a[0]=2
! a[n]=n/(2*n+1)*a[n-1]、n≧1
!とすると
! π=Σ{n=0,∞}a[n]

!計算手順
! π=((((( … +2)*5/11+2)*4/9+2)*3/7+2)*2/5+2)*1/3+2

LET N=20
DIM A(0 TO N) !長さn+1の配列Aを2に初期化します。
MAT A=2*CON
FOR k=1 TO N-1 !そして、次をn-1回繰り返します。
!!!MAT PRINT A; !trace
   MAT A=10*A !(a) Aの各要素に10を掛けます。
   FOR i=N TO 1 STEP -1 !(b) 右から始めて、
      LET Q=INT(A(i)* i/(2*i+1) ) !Aの第i要素を(2*i+1)/iを法として導き、
      LET A(i)=A(i)-Q* (2*i+1)/i
      LET A(i-1)=A(i-1)+Q !割り算の商を左隣の桁へ持って行きます。
   NEXT i
   PRINT Q !作り出された最後の商がπの次の桁の数になります。
   LET A(0)=0 !※累積されるので、オーバーフローとなる。これを防ぐ!
NEXT k
END
 

Spigot algorithms

 投稿者:M.N  投稿日:2010年 2月13日(土)12時15分4秒
  度重なる回答に感謝いたします。たいへんお手数をおかけしました。
おかげさまでeもPAIもできました。
ありがとうございました。
 

騎士巡歴

 投稿者:T.T  投稿日:2010年 2月15日(月)12時56分21秒
  騎士巡歴の問題のプログラムを奥村さんの本で見かけました。このプログラムの骨格を変えずに
十進BASICで書き換えるとどうなるのでしょうか。
/***********************************************************
knight.c -- 騎士巡歴の問題
***********************************************************/
#include <stdio.h>
#include <stdlib.h>

#define N  5           /* ${\tt N} \times {\tt N}$ の番面 */

int board[N + 4][N + 4],                /* 番面 */
dx[8] = { 2, 1,-1,-2,-2,-1, 1, 2 }, /* 横変位 */
dy[8] = { 1, 2, 2, 1,-1,-2,-2,-1 }; /* 縦変位 */

void printboard(void)                   /* 番面を出力 */
{
int i, j;
static solution = 0;

printf("\n解 %d\n", ++solution);
for (i = 2; i <= N + 1; i++) {
for (j = 2; j <= N + 1; j++) printf("%4d", board[i][j]);
printf("\n");
}
}

void try(int x, int y)  /* 再帰的に試みる */
{
int i;
static int count = 0;

if (board[x][y] != 0) return;  /* すでに訪れた */
board[x][y] = ++count;
if (count == N * N) printboard();  /* 完成 */
else for (i = 0; i < 8; i++) try(x + dx[i], y + dy[i]);
board[x][y] = 0;  count--;
}

int main()
{
int i, j;

for (i = 0; i <= N + 3; i++)
for (j = 0; j <= N + 3; j++) board[i][j] = 1;
for (i = 2; i <= N + 1; i++)
for (j = 2; j <= N + 1; j++) board[i][j] = 0;
try(2, 2);
return EXIT_SUCCESS;
}
 

Re: 騎士巡歴

 投稿者:山中和義  投稿日:2010年 2月15日(月)13時47分48秒
  > No.1033[元記事へ]

T.Tさんへのお返事です。

> このプログラムの骨格を変えずに十進BASICで書き換えるとどうなるのでしょうか。

Q&Aのコーナー
 CやJavaで書かれた数値計算アルゴリズムの移植
  http://hp.vector.co.jp/authors/VA008683/ImportC.htm
を参考に、書き換えてみました。

これより、機械的に置き換えるパターンが見えてきます。手ごろな例題だと思います。
!「knight.c - 騎士巡歴の問題」の移植

LET N=5 !盤の大きさ

DIM board(0 TO N+3,0 TO N+3) !盤面
DIM dx(0 TO 7) !横変位
DATA 2, 1,-1,-2,-2,-1, 1, 2
MAT READ dx
DIM dy(0 TO 7) !縦変位
DATA 1, 2, 2, 1,-1,-2,-2,-1
MAT READ dy

LET solution=0 !解答数
SUB printboard !盤面を出力
   local i,j
   LET solution=solution+1
   PRINT "解"; solution
   FOR i=2 TO N+1
      FOR j=2 TO N+1
         PRINT USING "####": board(i,j);
      NEXT j
      PRINT
   NEXT i
END SUB

LET count=0 !歩数
SUB try(x,y) !再帰的に試みる
   local i
   IF board(x,y)<>0 THEN EXIT SUB !すでに訪れた
   LET count=count+1 !一歩進める
   LET board(x,y)=count
   IF count=N*N THEN !全部の路を歩いたら
      CALL printboard !完成!
   ELSE
      FOR i=0 TO 7 !8方向の候補を検証する
         CALL try(x+dx(i),y+dy(i))
      NEXT i
   END IF
   LET board(x,y)=0 !元に戻す
   LET count=count-1
END SUB

!main()
FOR i=0 TO N+3 !盤を初期化する(壁)
   FOR j=0 TO N+3
      LET board(i,j)=1
   NEXT j
NEXT i
FOR i=2 TO N+1 !(路)
   FOR j=2 TO N+1
      LET board(i,j)=0
   NEXT j
NEXT i
CALL try(2,2)

END
 

騎士巡歴

 投稿者:T.T  投稿日:2010年 2月15日(月)15時03分20秒
  山中様、丁寧なご回答をありがとうございました。
大変助かりました。
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 2月16日(火)19時45分47秒
  > No.1015[元記事へ]

LU分解による計算 - 逆行列、行列式、連立方程式の解
!LU分解(クラウト(Crout)法)

LET N=3 !n次行列

DIM A(N,N) !行列
DATA  2,-1, 3
DATA -1, 1,-2
DATA  1, 5, 1
MAT READ A

DIM L(N,N),U(N,N) !下三角行列、上三角行列
CALL crout(A,L,U)
MAT PRINT L; !debug
MAT PRINT U; !debug

SUB crout(A(,),L(,),U(,)) !LU分解(クラウト法、Crout法)A=L*U
   FOR i=1 TO N
      LET L(i,1)=A(i,1)
      LET U(1,i)=A(1,i)/L(1,1)
   NEXT i
   FOR k=2 TO N
      FOR i=1 TO k
         LET L(i,k)=0
         LET U(k,i)=0
      NEXT i
      FOR i=k TO N
         LET L(i,k)=A(i,k)
         FOR m=1 TO k-1
            LET L(i,k)=L(i,k)-L(i,m)*U(m,k)
         NEXT m
      NEXT i
      LET U(k,k)=1
      FOR i=k+1 TO N
         LET U(k,i)=A(k,i)
         FOR m=1 TO k-1
            LET U(k,i)=U(k,i)-L(k,m)*U(m,i)
         NEXT m
         LET U(k,i)=U(k,i)/L(k,k)
      NEXT i
   NEXT k
END SUB


DIM T(N,N) !作業用

!------------------------------

DIM iL(N,N)
CALL invL(L,iL)
MAT PRINT iL;

SUB invL(L(,),iL(,)) !下三角行列の逆行列
   MAT iL=ZER
   FOR i=1 TO N
      LET iL(i,i)=1/L(i,i)
      FOR j=i-1 TO 1 STEP -1
         LET s=0
         FOR k=j+1 TO i
            LET s=s+iL(i,k)*L(k,j)
         NEXT k
         LET iL(i,j)=-s/L(j,j)
      NEXT j
   NEXT i
END SUB


MAT T=INV(L) !検算
MAT PRINT T;


!------------------------------

DIM iU(N,N)
CALL invU(U,iU)
MAT PRINT iU;

SUB invU(U(,),iU(,)) !上三角行列の逆行列
   MAT iU=ZER
   FOR j=1 TO N
      LET iU(j,j)=1/U(j,j)
      FOR i=j-1 TO 1 STEP -1
         LET s=0
         FOR k=i+1 TO j
            LET s=s+U(i,k)*iU(k,j)
         NEXT k
         LET iU(i,j)=-s/U(i,i)
      NEXT i
   NEXT j
END SUB


MAT T=INV(U) !検算
MAT PRINT T;


!------------------------------

MAT T=iU*iL !行列Aの逆行列 A=LUより、INV(A)=INV(L*U)=INV(U)*INV(L)
MAT PRINT T;


MAT T=INV(A) !検算
MAT PRINT T;


!------------------------------

PRINT detL(L)*detU(U) !行列Aの行列式 DET(A)=DET(L*U)=DET(L)*DET(U)

FUNCTION detL(L(,)) !下三角行列の行列式
   LET x=1
   FOR i=1 TO N !対角成分の積
      LET x=x*L(i,i)
   NEXT i
   LET detL=x
   !!!PRINT x; DET(L) !debug
END FUNCTION

FUNCTION detU(U(,)) !上三角行列の行列式
   LET y=1
   FOR i=1 TO N !対角成分の積
      LET y=y*U(i,i)
   NEXT i
   LET detU=y
   !!!PRINT y; DET(U) !debug
END FUNCTION


PRINT DET(A) !検算


END

●その2
!クラウト(Crout)法(LU分解)によるN元連立1次方程式 Ax=b の解

LET N=3 !n次行列

DIM A(N,N) !係数行列
DATA  2,-1, 3
DATA -1, 1,-2
DATA  1, 5, 1

!DATA 8,16,24,32
!DATA 2,7,12,17
!DATA 6,17,32,59
!DATA 7,22,46,105
MAT READ A

DIM b(N) !右辺ベクトル
DATA -2,3,6
!DATA 160,70,198,291
MAT READ b

DIM L(N,N),U(N,N) !下三角行列、上三角行列
CALL crout(A,L,U)
MAT PRINT L; !debug
MAT PRINT U; !debug


!A*x=(L*U)*x=L*(U*x)=b、y=U*xより

DIM y(N) !下三角方程式 L*y=b を前進代入で解く
FOR i=1 TO N
   LET s=0
   FOR k=1 TO i-1
      LET s=s+L(i,k)*y(k)
   NEXT k
   LET y(i)=(b(i)-s)/L(i,i)
NEXT i
!!!MAT PRINT y; !debug

DIM x(N) !上三角方程式 U*x=y 後退代入で解く
FOR i=N TO 1 STEP -1
   LET s=0
   FOR k=i+1 TO N
      LET s=s+U(i,k)*x(k)
   NEXT k
   LET x(i)=(y(i)-s)/U(i,i)
NEXT i
MAT PRINT x; !4,1,-3


SUB crout(A(,),L(,),U(,)) !LU分解(クラウト法、Crout法)A=L*U ※ピボット選択なし
   FOR i=1 TO N
      LET L(i,1)=A(i,1)
      LET U(1,i)=A(1,i)/L(1,1)
   NEXT i
   FOR k=2 TO N
      FOR i=1 TO k
         LET L(i,k)=0
         LET U(k,i)=0
      NEXT i
      FOR i=k TO N
         LET L(i,k)=A(i,k)
         FOR m=1 TO k-1
            LET L(i,k)=L(i,k)-L(i,m)*U(m,k)
         NEXT m
      NEXT i
      LET U(k,k)=1
      FOR i=k+1 TO N
         LET U(k,i)=A(k,i)
         FOR m=1 TO k-1
            LET U(k,i)=U(k,i)-L(k,m)*U(m,i)
         NEXT m
         LET U(k,i)=U(k,i)/L(k,k)
      NEXT i
   NEXT k
END SUB

END
 

exe

 投稿者:実行ファイル形式で保存したい人  投稿日:2010年 2月20日(土)15時56分48秒
  十進BASICをexeの拡張子(実行ファイル形式)で保存できないでしょうか。
出来るなら、その方法を教えて下さい。
 

Re: exe

 投稿者:山中和義  投稿日:2010年 2月20日(土)19時31分7秒
  > No.1037[元記事へ]

実行ファイル形式で保存したい人さんへのお返事です。

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

BGM

 投稿者:ポン  投稿日:2010年 2月21日(日)23時03分54秒
  十進BASICでBGM(音)を鳴らせないのでしょうか?
ゲーム作成で、効果音を入れたいのですが
 

Re: BGM

 投稿者:山中和義  投稿日:2010年 2月22日(月)10時47分55秒
  > No.1039[元記事へ]

ポンさんへのお返事です。

> 十進BASICでBGM(音)を鳴らせないのでしょうか?

N88,MSX系でのゲームプログラミング(アニメーション、音楽などの実装)でよく使われる
命令(関数、文など)はありません。

・音楽を演奏する命令(LPLAY文、MUSIC文など)とそれらに記述されるMML
 →FM音源などによるBGMや効果音
・DirectX APIを利用する命令
 →BGM+効果音(同時に2曲以上再生可能)

・カーソル位置を指定する命令(LOCATE文、CURSOR文など)
・画面モードを指定する命令(SCREEN文、CONSOLE文など)
・スプライト機能を使用する命令
・VRAMにアクセスする命令(PEEK関数、POKE文など)
・ビットマップ画像を高速に扱う命令


できるとすれば、、、

同時に再生できる曲(WAVファイル)は1つです。一時停止や音量・音質の変更などはできません。

ヘルプより
・BEEP 数値式1, 数値式2
  Windows NT/2000/XPでは,数値式1は振動数(Hz),数値式2は継続時間(ミリ秒)を意味する。
  Windows 95/98/Meでは,数値式1,数値式2は意味を持たない。
・PLAYSOUND 文字列式
  同期で再生する(再生が終わるまで、BASICの次の命令文は実行しない)
 PLAYSOUND 文字列式 ,ASYNC
  非同期で再生する
 

Re: 昔のbasicの移植

 投稿者:山中和義  投稿日:2010年 2月22日(月)14時31分46秒
  > No.1041[元記事へ]

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

> IF---AND --- THEN   **** ----とあるのが2度続いており

4040 IF PH=2 AND P=<EPS THEN !※THENで改行する。THEN以降を「行番号なし」の行とする。
        PRINT "LAST SOLUTION IS OPTIMAL" !※:(マルチステートメント)は1行にする。
        STOP !※途中のEND文は、STOP文に置き換える。
     END IF
4050 IF PH=1 AND P=<EPS THEN 4380 !行番号のみはそのままでよい。


> この外にも、最後の部分で

5210 B(0,0)=0
5220 IF ABS (BB-W)<EPS THEN
        DD=DD+1
        RETURN
     END IF
5230 DD=0
5240 RETURN


IF THEN ELSEの形も同様に変換できます。

ただ、IF C1 THEN IF C2 THEN A ELSE Bの形式は
 IF C1 THEN
  IF C2 THEN
   A
  ELSE
   B
  END IF
 END IF
または
 IF C1 THEN
  IF C2 THEN
   A
  END IF
 ELSE
  B
 END IF
なのかは不明な場合があります。
 

最小値

 投稿者:しばっち  投稿日:2010年 2月23日(火)20時13分44秒
  最小値を求める


PUBLIC NUMERIC H
LET H=1/256
LET HIGH=10
LET LOW=1
LET EPS=1E-8
DO
   LET M=(HIGH+LOW)/2    !'二分法
   IF DIFF(M,1)*DIFF(HIGH,1)>0 THEN LET HIGH=M ELSE LET LOW=M
LOOP UNTIL ABS(HIGH-LOW)<EPS
PRINT "MIN-X=";M
PRINT "最小値=";FUNC(M)

LET XX=10 !'初期値
DO
   LET X=XX
   LET XX=X-DIFF(X,1)/DIFF(X,2)    !'ニュートン法  X=X-f'(X)/f''(X)
LOOP UNTIL ABS(X-XX)<EPS
PRINT "MIN-X=";XX
PRINT "最小値=";FUNC(XX)
END

EXTERNAL  FUNCTION FUNC(X)
LET FUNC=(X^2-3)^2+3 !' X=SQR(3)の時、最小値 3
!'LET FUNC=X^3/3-2*X^2+3*X+2 !' X=3の時、極小値 2  f'(X)=(X-1)*(X-3)
END FUNCTION

EXTERNAL  FUNCTION DIFF(X,N)  !'n階微分
IF N=0 THEN
   LET DIFF=FUNC(X)
ELSE
   LET DIFF=(-DIFF(X+2*H,N-1)+8*DIFF(X+H,N-1)-8*DIFF(X-H,N-1)+DIFF(X-2*H,N-1))/(12*H)
END IF
END FUNCTION

! EXTERNAL  FUNCTION DIFF(X,N)
! FOR J=0 TO N
!    LET  S=S+(-1)^J*COMB(N,J)*FUNC(X+(N/2-J)*H)
! NEXT J
! LET  DIFF=S/(H^N)
! END FUNCTION
 

最小値 その2

 投稿者:しばっち  投稿日:2010年 2月23日(火)20時15分27秒
  最小値を求める(最急降下法)


PUBLIC NUMERIC H
LET XX=5 !'初期値
LET YY=5
LET ZZ=5
LET H=1/256
LET ALPHA=1/128
LET EPS=1E-8
DO WHILE ABS(DIFF(XX,1,YY,0,ZZ,0))>EPS AND ABS(DIFF(XX,0,YY,1,ZZ,0))>EPS AND DIFF(XX,0,YY,0,ZZ,1)>EPS
   LET X=XX-ALPHA*DIFF(XX,1,YY,0,ZZ,0)
   LET Y=YY-ALPHA*DIFF(XX,0,YY,1,ZZ,0)
   LET Z=ZZ-ALPHA*DIFF(XX,0,YY,0,ZZ,1)
   LET XX=X
   LET YY=Y
   LET ZZ=Z
LOOP
PRINT "MIN-X,Y,Z=";X;Y;Z
PRINT "最小値=";FUNC(X,Y,Z)
END

EXTERNAL  FUNCTION FUNC(X,Y,Z)
LET FUNC=(X^2-2)^2+(X^2-Y)^2+(X*Z-1)^2+1
END FUNCTION

EXTERNAL  FUNCTION DIFF(X,M,Y,N,Z,O)
IF M>0 THEN
   LET DIFF=(-DIFF(X+2*H,M-1,Y,N,Z,O)+8*DIFF(X+H,M-1,Y,N,Z,O)-8*DIFF(X-H,M-1,Y,N,Z,O)+DIFF(X-2*H,M-1,Y,N,Z,O))/(12*H)
   EXIT FUNCTION
END IF
IF N>0 THEN
   LET DIFF=(-DIFF(X,M,Y+2*H,N-1,Z,O)+8*DIFF(X,M,Y+H,N-1,Z,O)-8*DIFF(X,M,Y-H,N-1,Z,O)+DIFF(X,M,Y-2*H,N-1,Z,O))/(12*H)
   EXIT FUNCTION
END IF
IF O>0 THEN
   LET DIFF=(-DIFF(X,M,Y,N,Z+2*H,O-1)+8*DIFF(X,M,Y,N,Z+H,O-1)-8*DIFF(X,M,Y,N,Z-H,O-1)+DIFF(X,M,Y,N,Z-2*H,O-1))/(12*H)
   EXIT FUNCTION
END IF
IF M=0 OR N=0 OR O=0 THEN  LET  DIFF=FUNC(X,Y,Z)
END FUNCTION
 

最小化

 投稿者:しばっち  投稿日:2010年 2月23日(火)20時17分6秒
  最小化 (最小2乗法により回帰式を求める)


PUBLIC NUMERIC X(30),Y(30),N,H
DIM U(2,2),V(2),W(2)
RANDOMIZE
LET N=20 !'データー数
LET H=1/1024
LET AA=RND !'乱数でパラメータを決める
LET BB=RND
LET EPS=1E-6
FOR I=1 TO N !'テスト用データの作成
   LET X(I)=I/5
   LET Y(I)=FF(AA,BB,X(I))
NEXT I
LET A=1 !'初期値
LET B=1
DO !'ニュートン法
   LET  U(1,1)=DIFF(A,2,B,0)
   LET  U(1,2)=DIFF(A,1,B,1)
   LET  U(2,1)=DIFF(A,1,B,1)
   LET  U(2,2)=DIFF(A,0,B,2)
   LET  V(1)=-DIFF(A,1,B,0)
   LET  V(2)=-DIFF(A,0,B,1)
   MAT  U=INV(U)
   MAT  W=U*V
   LET  A=A+W(1)
   LET  B=B+W(2)
   IF W(1)^2+W(2)^2<EPS THEN EXIT DO
   LET L=L+1
   IF L>100 THEN
      PRINT "収束しません"
      EXIT DO
   END IF
LOOP
PRINT "AA=";AA,"BB=";BB
PRINT "A =";A," B =";B
LET P$="###.########"
FOR I=1 TO N
   PRINT "X=";
   PRINT USING P$:X(I);
   PRINT "   Y=";
   PRINT USING P$:Y(I);
   PRINT "   ^Y=";
   PRINT USING P$:FF(A,B,X(I))
NEXT I
END

EXTERNAL  FUNCTION FF(A,B,X) !'回帰式
LET FF=A+B*X
!'LET FF=A*EXP(B*X)
!'LET FF=A+B*LOG(X)
!'LET FF=A+B*SQR(X)
!'LET FF=A*B^X
!'LET FF=A*X^B
!'LET FF=A+B/X
!'LET FF=1/(A+B*X)
!'LET FF=1/(A+B/X)
!'LET FF=1/(A+B*X^(1/3))
!'LET FF=1/(1+A*EXP(-B*X))
!'LET FF=X/(A+B*X^2)
!'LET FF=X/(A+B*LOG(X))
!'LET FF=SQR(X)/(A+B*LOG(X))
!'LET FF=LOG(X)/(A+B*SQR(X))
!'LET FF=EXP(X)/SQR(A+B*X^2)
!'LET FF=X/SQR(A+B*X)
!'LET FF=A^(B^X)
!'LET FF=1/(1+1/EXP(A+B*X))
END FUNCTION

EXTERNAL  FUNCTION FUNC(A,B) !'最小化する関数(A=AA,B=BBの時、最小値 0)
FOR I=1 TO N
   LET S=S+(Y(I)-FF(A,B,X(I)))^2
NEXT I
LET FUNC=S
END FUNCTION

EXTERNAL  FUNCTION DIFF(X,M,Y,N)
IF M>0 THEN
   LET DIFF=(-DIFF(X+2*H,M-1,Y,N)+8*DIFF(X+H,M-1,Y,N)-8*DIFF(X-H,M-1,Y,N)+DIFF(X-2*H,M-1,Y,N))/(12*H)
   EXIT FUNCTION
END IF
IF N>0 THEN
   LET DIFF=(-DIFF(X,M,Y+2*H,N-1)+8*DIFF(X,M,Y+H,N-1)-8*DIFF(X,M,Y-H,N-1)+DIFF(X,M,Y-2*H,N-1))/(12*H)
   EXIT FUNCTION
END IF
IF M=0 OR N=0 THEN LET  DIFF=FUNC(X,Y)
END FUNCTION
 

全組み合わせを生成するには?

 投稿者:ひいらぎ  投稿日:2010年 2月24日(水)13時19分21秒
  はじめまして
つい最近このサイトを知りました。
初歩的なことですみませんが、以下のようにするには
どうすればいいかお教え頂けないでしょうか?

n個のビット列でr個の1を含むパターンの総数nCrに
通し番号をつけて生成する、というものです。

例えば、5桁のうち3個の1がある場合、
 A(1)=00111, A(2)=01011, ……, A(10)=11100
という具合です。または十進にして、
 A(1)=7, A(2)=11, ……, A(10)=28
でもいいです。
大きさの順はランダムでかまいません。
とにかく全ての場合を任意に取り出したいのです。

プログラム初心者の質問で申し訳ないですが、
ご教授よろしくお願い致します。
 

Re: 全組み合わせを生成するには?

 投稿者:山中和義  投稿日:2010年 2月24日(水)14時18分8秒
  > No.1046[元記事へ]

ひいらぎさんへのお返事です。

> n個のビット列でr個の1を含むパターンの総数nCrに
> 通し番号をつけて生成する、というものです。
LET N=5
LET R=3
FOR i=0 TO COMB(N,R)-1 !全パターン
   PRINT i
   CALL Num2Comb(i,A,N,R) !番号は0~
   PRINT BSTR$(A,2); A
NEXT i
END

EXTERNAL SUB Num2Comb(h, A,N,R) !番号から組合せパターンを生成する ※辞書式順序
LET v=COMB(N,R)-h
LET j=R
LET A=0
FOR i=N-1 TO 0 STEP -1 !組合せをビット位置とする
   LET t=COMB(i,j)
   IF v>t THEN
      LET A=A+2^(N-i-1) !ビット位置(N-i-1)を1とする
      LET j=j-1
      LET v=v-t
   END IF
NEXT i
END SUB

集合A={1,2,3,4,5}
 {1,2,3}
 {1,2,4}
  :
 {4,5,6}
では、こちら(No.675 [元記事へ])を参照してください。
 

ありがとうございます!

 投稿者:ひいらぎ  投稿日:2010年 2月24日(水)14時44分20秒
  山中様

早速お返事下さってありがとうございます!

そのままコピペして試してみると、
望んでいた通りのものでした!
せっかく教えて頂いたものですから、
これから先自在に使いこなせるように
充分に内容を検討・勉強しようと思います。

素早いご返答、本当にありがとうございました。
これからもどうぞ宜しくお願い致します。
 

プログラムのお願い。

 投稿者:GAI  投稿日:2010年 2月24日(水)16時17分14秒
  1~8のカードから
2枚ずつ4組を構成するすべてのパターン(8C2×6C2×4C2/4!=105)
を表示させたい。
これのプログラムをお願いします。
 

Re: プログラムのお願い。

 投稿者:山中和義  投稿日:2010年 2月24日(水)19時49分51秒
  > No.1049[元記事へ]

GAIさんへのお返事です。

> 1~8のカードから
> 2枚ずつ4組を構成するすべてのパターン(8C2×6C2×4C2/4!=105)
> を表示させたい。
DIM A$(105) !全パターン 例. 12345678なら、(1,2)(3,4)(5,6)(7,8)と読む
LET C=1
FOR i=2 TO 8 !1組目(1,i) ※comb(8,2)/4=7通り
   LET w$="12345678" !restore it

   LET A$(C)=w$(1:1)&w$(i:i) !その2つを抜き取って、連番を再構成する
   LET w$(i:i)=""
   LET w$(1:1)=""

   FOR j=2 TO 6 !2組目(1,j) ※comb(6,2)/3=5通り
      LET x$=w$ !restore it

      LET A$(C)=A$(C)(1:2)&x$(1:1)&x$(j:j)
      LET x$(j:j)=""
      LET x$(1:1)=""

      FOR k=2 TO 4 !3組目(1,k) ※comb(4,2)/2=3通り
         LET y$=x$ !restore it

         LET A$(C)=A$(C)(1:4)&y$(1:1)&y$(k:k)
         LET y$(k:k)=""
         LET y$(1:1)=""

         LET A$(C)=A$(C)&y$ !4組目 ※comb(2,2)/1=1通り

         PRINT C;": ";A$(C) !結果を表示する

         LET C=C+1
         IF C<=105 THEN LET A$(C)=A$(C-1)(1:4) !copy it
      NEXT k
   NEXT j
NEXT i

END
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 2月24日(水)19時59分47秒
  > No.1036[元記事へ]

(筆算による)2次正方行列のべき乗
!2×2行列Aのn乗

DIM A(2,2)
DATA -2,2
DATA  2,1
MAT READ A


FUNCTION tr(A(,)) !行列Aのトレース
   LET s=0
   FOR k=1 TO 2
      LET s=s+A(k,k)
   NEXT k
   LET tr=s
END FUNCTION

!行列の固有方程式から固有値を求める

LET D=tr(A)^2-4*DET(A) !判別式
IF D<=0 THEN
   PRINT "異なる実数解ではありません。"
   STOP
END IF
LET lambda1=(tr(A)+SQR(D))/2 !固有値
LET lambda2=(tr(A)-SQR(D))/2
PRINT lambda1;lambda2


DIM T(2,2),T1(2,2),T2(2,2)

!●固有値・固有ベクトルによる行列の対角化
!(INV(P)*A*P)^n=INV(P)*A^n*Pより、A^n=P*(INV(P)*A*P)^n*INV(P)

DIM PP(2,2)
MAT T=(lambda2)*IDN !λ1に対する固有ベクトル
MAT T=A-T
!MAT PRINT T; !debug
LET PP(1,1)=T(1,1) !1列目を採用する
LET PP(2,1)=T(2,1)

MAT T=(lambda1)*IDN !λ2に対する固有ベクトル
MAT T=A-T
!MAT PRINT T; !debug
LET PP(1,2)=T(1,1) !1列目を採用する
LET PP(2,2)=T(2,1)

DIM iPP(2,2)
MAT iPP=INV(PP)

!MAT T=iPP*A !INV(P)*A*Pの検算
!MAT T=T*PP
!MAT PRINT T;

FOR i=0 TO 10 !E,A,A^2,A^3,…の計算
   MAT T=ZER
   LET T(1,1)=lambda1^i !対角行列 (INV(P)*A*P)^n
   LET T(2,2)=lambda2^i

   MAT T=PP*T
   MAT T=T*iPP

   PRINT i !結果を表示する
   MAT PRINT T;
NEXT i



!●ハミルトン・ケーリーの定理 A^2-(a+d)*A+(a*d-b*c)*E=(A-λ1*E)*(A-λ2*E)=O

!A^n={(A-λ1*E)*(A-λ2*E)}*Q(A)+x*A+y*E と変形できる。
!連立方程式
! λ1^n=λ1*x+y
! λ2^n=λ2*x+y
!より
! x=(λ1^n-λ2^n)/(λ1-λ2)
! y=(λ1*λ2^n-λ1^n*λ2)/(λ1-λ2)

FOR i=0 TO 10 !E,A,A^2,A^3,…の計算
   LET w1=lambda1^i
   LET w2=lambda2^i
   MAT T1=( (w1-w2)/(lambda1-lambda2) )*A
   MAT T2=( (lambda1*w2-w1*lambda2)/(lambda1-lambda2))*IDN
   MAT T=T1+T2

   PRINT i !結果を表示する
   MAT PRINT T;
NEXT i



!●スペクトル分解 A^n=Σ[k=1,m]λk*Pk、Pkは固有値λkに対する射影子

!行列の固有方程式λ^2-(trA)λ+detA=0の異なる実数解をλ1,λ2とする。
!P=(A-λ2*E)/(λ1-λ2)、Q=(A-λ2*E)/(λ2-λ1)とおくと、A=λ1*P+λ2*Qとなる。
!またP*Q=Q*P=O、P^2=P、Q^2=Q、P+Q=Eとなるので、Aのn乗は、λ1^n*P+λ2^n*Qとなる。

DIM P(2,2),Q(2,2)
MAT T=(lambda2)*IDN
MAT T=A-T
MAT P=(1/(lambda1-lambda2))*T

MAT T=(lambda1)*IDN
MAT T=A-T
MAT Q=(1/(lambda2-lambda1))*T

FOR i=0 TO 10 !E,A,A^2,A^3,…の計算
   MAT T1=(lambda1^i)*P
   MAT T2=(lambda2^i)*Q
   MAT T=T1+T2

   PRINT i !結果を表示する
   MAT PRINT T;
NEXT i



MAT T=IDN !検算
FOR i=1 TO 10 !A,A^2,A^3,…
   MAT T=T*A
   PRINT i
   MAT PRINT T;
NEXT i

END
 

三次関数

 投稿者:ヒエロサロメ  投稿日:2010年 2月26日(金)23時05分32秒
  10 PRINT "x1の値は?"
20 INPUT XI
30 PRINT "y1の値は?"
40 INPUT YI
50 PRINT "x2の値は?"
60 INPUT XII
70 PRINT "y2の値?"
80 INPUT YII
90 PRINT "x3の値?"
100 INPUT XIII
110 PRINT "y3の値?"
120 INPUT YIII
130 PRINT "x4の値は?"
140 INPUT XIV
150 PRINT "y4の値は?"
160 INPUT YIV
170 LET AYI=YI
180 LET AYII=YII
190 LET AYIII=YIII
200 LET AYIV=YIV
210 LET C=(AYII-AYI)/(XII-XI)
220 LET D=AYI-C*XI
230 LET B=(AYIII-(C*XIII+D))/XIII^2
240 LET A=(AYIV-(B*XIV^2+C*XIV+D))/XIV^3
250 LET TYI=A*XI^3+B*XI^2+C*XI+D
260 LET TYII=A*XII^3+B*XII^2+C*XII+D
270 LET TYIII=A*XIII^3+B*XIII^2+C*XIII+D
280 LET TYIV=A*XIV^3+B*XIV^2+C*XIV+D
290 LET AYI=YI/TYI*AYI
300 LET AYII=YII/TYII*AYII
310 LET AYIII=YIII/TYIII*AYIII
320 LET AYIV=YIV/TYIV*AYIV
330 IF YI=TYI AND YII=TYII AND YIII=TYIII AND YIV=TYIV THEN GOTO 340 ELSE GOTO 210
340 PRINT "aは",A
350 PRINT "bは",B
360 PRINT "cは",C
370 PRINT "dは",D
380 PRINT "xの値は?"
390 INPUT X
400 LET Y=A*X^3+B*X^2+C*X+D
410 PRINT "yは",Y
420 GOTO 380
430 END
 

三次関数(C言語)

 投稿者:ヒエロサロメ  投稿日:2010年 2月26日(金)23時06分57秒
  #include <iostream.h>
void main (void)
{
cout<< "三次関数製造機によるグラフの補間です。\n";
cout<< "x1の値は?";

long double x1, x2, x3, x4;
long double y1, y2, y3, y4;

cin>> x1;
cout<<"y1の値は?";
cin>> y1;
cout<<"x2の値は?";
cin>> x2;
cout<<"y2の値は?";
cin>> y2;
cout<<"x3の値は?";
cin>> x3;
cout<<"y3の値は?";
cin>> y3;
cout<<"x4の値は?";
cin>> x4;
cout<<"y4の値は?";
cin>> y4;

long double ay1 = y1;
long double ay2 = y2;
long double ay3 = y3;
long double ay4 = y4;

long double a, b, c, d;
long double ty1, ty2, ty3, ty4;

do{
c = (ay2-ay1)/(x2-x1);
d = ay1-c*x1;
b = (ay3-(c*x3+d))/pow(x3,2);
a = (ay4-(b*pow(x4,2)+c*x4+d))/pow(x4,3);

ty1 = a*pow(x1,3)+b*pow(x1,2)+c*x1+d;
ty2 = a*pow(x2,3)+b*pow(x2,2)+c*x2+d;
ty3 = a*pow(x3,3)+b*pow(x3,2)+c*x3+d;
ty4 = a*pow(x4,3)+b*pow(x4,2)+c*x4+d;

ay1 = (y1/ty1)*ay1;
ay2 = (y2/ty2)*ay2;
ay3 = (y3/ty3)*ay3;
ay4 = (y4/ty4)*ay4;

}while( y1 != ty1 && y2 != ty2 && y3 !=ty3);

cout<<"y=";
cout.precision(20);
cout<< a;
cout<<"x^3+";
cout<< b;
cout<<"x^2+";
cout<< c;
cout<<"x+";
cout<< d;
int i ;

do{
cout<<"\n求めたいxの値を入力してください。\n";
long double x;
cin>> x;
long double y = a*pow(x,3)+b*pow(x,2)+c*x+d;
cout<< y;
cout<<"計算を続けるなら1、\nやめるなら1以外の数を入力してください。";
cin>>i;
}while(i==1);
}
 

三次関数

 投稿者:ヒエロサロメ  投稿日:2010年 2月26日(金)23時11分41秒
  こんばんは。
C言語ならBASICよりも精密な計算が出来ると考えて、
作って試してみたら、
BASICの方がすごかったです。
Cのlong doubleよりもはるかに制度の高い、
16倍か32倍精度浮動少数を、高速で扱う、
何かの秘密があるんですか。
 

辞書式順序で次の組合せを返す

 投稿者:山中和義  投稿日:2010年 2月27日(土)09時27分2秒
  > No.715[元記事へ]

!辞書式順序で次の組合せを返す ※異なるn個からr個を選ぶ組合せ COMB(N,R)

LET N=5
LET R=3

DIM A(R) !パターン
FOR i=1 TO R !初期値 A={1,2,3}
   LET A(i)=i
NEXT i

DO
   MAT PRINT A;
   CALL NextComb(A,N,R, rc)
LOOP WHILE rc<>0
PRINT

DO
   MAT PRINT A;
   CALL PrevComb(A,N,R, rc)
LOOP WHILE rc<>0

END

EXTERNAL SUB PrevComb(A(),N,R, rc) !辞書式順序で前の組合せを返す
LET rc=0 !完了
FOR i=R TO 2 STEP -1 !並びの差が2以上の位置を探す
   IF A(i)-A(i-1)>1 THEN EXIT FOR
NEXT i
IF i>1 OR (i=1 AND A(1)>1) THEN
   LET A(i)=A(i)-1
   FOR j=i+1 TO R !A(2)=N-R+2< … A(R-1)=N-1<A(R)=N 最後の並び
      LET A(j)=N-R+j
   NEXT j
   LET rc=1 !未了
END IF
END SUB

EXTERNAL SUB NextComb(A(),N,R, rc) !辞書式順序で次の組合せを返す
LET rc=0 !完了
FOR i=R TO 1 STEP -1
   IF A(i)<N-R+i THEN !i~N-R+iで更新する
      LET A(i)=A(i)+1
      FOR j=i+1 TO R !A(i)<A(i+1)< … <A(R) 最初の並び
         LET A(j)=A(j-1)+1
      NEXT j
      LET rc=1 !未了
      EXIT SUB
   END IF
NEXT i
END SUB

●その2 「C言語による最新アルゴリズム事典」(奥村晴彦著)gencomb.c -- 組合せの生成
!次の組合せを返す ※辞書式順序でない

LET N=5
LET R=3

FUNCTION NextComb(x) !次の組合せを返す ※組合せをビット位置とする
   LET smallest=searchbit(x)
   LET ripple=x + smallest

   LET new_smallest=searchbit(ripple)
   LET ones=INT((new_smallest/smallest)/2)-1

   LET NextComb=ripple + ones
END FUNCTION

FUNCTION searchbit(x) !C言語の x & -x と同等
   FOR m=0 TO N-2 !最下位ビットから最初に1となる位置を検出する
      IF MOD(INT(x/2^m),2)=1 THEN EXIT FOR
   NEXT m !※0~n-2がすべて0なら、n-1は1のはず
   LET searchbit=2^m
END FUNCTION


LET a=2^R-1 !初期パターン 0…011…1 ※(N-R)個の0、R個の1
FOR i=1 TO comb(N,R) !全パターン
   PRINT BSTR$(a,2); a
   LET a=NextComb(a)
NEXT i

END
 

教えて下さい。

 投稿者:GAI  投稿日:2010年 2月27日(土)13時32分58秒
  1~10の数字を2つずつ5組に分けて、各組の2数の差が1,2,3,4,5
となる組を探すことをしたくて、山中さんから作って頂いたプログラムを参考に次のものを作り調べようと思いました。
ただし0と10の数の違いに作業がうまくいきません。
この点をクリアーするための方法を教えて下さい。
また、プログラム中の数値P,Q,R,S,Tを小さい順に並べて表示させるためにはどうすればいいのでしょうか?
ご教授お願いします。
これを一般化して2n枚のカードに1~2nの数字が書かれているものを2枚ずつのn組に分けて、その2数の差が1,2,3,・・・,nとなれる組がいくつ存在できるか知りたい。


DIM A$(945) !全パターン  例. 1234567890なら、(1,2)(3,4)(5,6)(7,8)(9,10)と読む
LET C=1
FOR i=2 TO 10 !1組目(1,i)  ※comb(10,2)/5=9通り
   LET w$="1234567890" !restore it

   LET A$(C)=w$(1:1)&w$(i:i) !その2つを抜き取って、連番を再構成する
   LET w$(i:i)=""
   LET w$(1:1)=""

   FOR j=2 TO 8 !2組目(1,j)  ※comb(8,2)/4=7通り
      LET x$=w$ !restore it

      LET A$(C)=A$(C)(1:2)&x$(1:1)&x$(j:j)
      LET x$(j:j)=""
      LET x$(1:1)=""

      FOR k=2 TO 6 !3組目(1,k)  ※comb(6,2)/3=5通り
         LET y$=x$ !restore it

         LET A$(C)=A$(C)(1:4)&y$(1:1)&y$(k:k)
         LET y$(k:k)=""
         LET y$(1:1)=""

         FOR l=2 TO 4 !4組目(1,l) ※comb(4,2)/2=3通り
            LET z$=y$  !restore it

            LET A$(c)=A$(C)(1:6)&z$(1:1)&z$(l:l)
            LET z$(l:l)=""
            LET z$(1:1)=""

            LET A$(C)=A$(C)&z$ !5組目  ※comb(2,2)/1=1通り


            PRINT C;": ";A$(C) !結果を表示する

            LET C=C+1
            IF C<=945 THEN LET A$(C)=A$(C-1)(1:6)   !copy it
         NEXT l
      NEXT k
   NEXT j
NEXT i

PRINT
PRINT

FOR C=1 TO 945

   LET P=ABS(VAL(A$(C)(1:1))-VAL(A$(C)(2:2)))
   LET Q=ABS(VAL(A$(C)(3:3))-VAL(A$(C)(4:4)))
   LET R=ABS(VAL(A$(C)(5:5))-VAL(A$(C)(6:6)))
   LET S=ABS(VAL(A$(C)(7:7))-VAL(A$(C)(8:8)))
   LET T=ABS(VAL(A$(C)(9:9))-VAL(A$(C)(10:10)))
   PRINT C;"  ";P;Q;R;S;T

NEXT C

END
 

Re: 教えて下さい。

 投稿者:山中和義  投稿日:2010年 2月27日(土)15時03分3秒
  > No.1056[元記事へ]

GAIさんへのお返事です。

> 1~10の数字を2つずつ5組に分けて、各組の2数の差が1,2,3,4,5となる組を探す
> ただし0と10の数の違いに作業がうまくいきません。

16進法で対応します。


> また、プログラム中の数値P,Q,R,S,Tを小さい順に並べて表示させるためにはどうすればいいのでしょうか?

差1~5を索引番号として、どの組で発生したかを「一意性」と一緒に扱えばいいでしょう。


LET A$="" !全パターン 例. 123456789Aなら、(1,2)(3,4)(5,6)(7,8),(9,10)と読む
LET C=0
FOR i=2 TO 10 !1組目(1,i) ※comb(10,2)/5=9通り
   LET w$="123456789A" !restore it

   LET A$=w$(1:1)&w$(i:i) !その2つを抜き取って、連番を再構成する
   LET w$(i:i)=""
   LET w$(1:1)=""

   FOR j=2 TO 8 !2組目(1,j) ※comb(8,2)/4=7通り
      LET x$=w$ !restore it

      LET A$=A$(1:2)&x$(1:1)&x$(j:j)
      LET x$(j:j)=""
      LET x$(1:1)=""

      FOR k=2 TO 6 !3組目(1,k) ※comb(6,2)/2=5通り
         LET y$=x$ !restore it

         LET A$=A$(1:4)&y$(1:1)&y$(k:k)
         LET y$(k:k)=""
         LET y$(1:1)=""

         FOR L=2 TO 4 !4組目(1,k) ※comb(4,2)/2=3通り
            LET z$=y$ !restore it

            LET A$=A$(1:6)&z$(1:1)&z$(L:L)
            LET z$(L:L)=""
            LET z$(1:1)=""

            LET A$=A$&z$ !5組目 ※comb(2,2)/1=1通り


            DIM P(5) !差1~5の出現度数
            MAT P=ZER
            FOR q=1 TO 5
               LET t=ABS( BVAL(A$(2*q-1:2*q-1),16)-BVAL(A$(2*q:2*q),16) ) !ペアの差を算出する
               IF NOT(t<=5 AND P(t)=0) THEN EXIT FOR !差の範囲「1~5」と「一意性」
               LET P(t)=q !※「表示するときの索引番号」を兼ねる
            NEXT q
            IF q>5 THEN !結果を表示する
               LET C=C+1 !解答数
               PRINT "No.";C
               FOR q=1 TO 5 !索引番号の順に
                  PRINT "(";A$(2*P(q)-1:2*P(q)-1);",";A$(2*P(q):2*P(q));") ";
               NEXT q
               PRINT
            END IF

         NEXT L
      NEXT k
   NEXT j
NEXT i

END
 

Re: 教えて下さい。

 投稿者:山中和義  投稿日:2010年 2月28日(日)09時01分39秒
  > No.1056[元記事へ]

GAIさんへのお返事です。

> これを一般化して2n枚のカード

計算量 O(COMB(2*N,N)*FACT(N)) n=12は無理かな、、、
!問題
! 1~2nの数の記入されたカードで2枚ずつのペアをn組つくるとき、
! カードの数字の差がそれぞれ1、2、3、4、…、nになるような組み合わせを求めよ。

!答え
! n mod 4が0,1のとき、可能性がある。2,3なら、0
!
!n=1,2,3,4, 5,6,7,  8,   9,10,11,12,13,14,15, …
! 1,0,0,6,10,0,0,504,2656, 0, 0,??,??, 0, 0, …
!※パソコンの性能により調査できず

!PentiumⅢ700MHz,WindowsMe,2進モード n=9の場合、計算時間= 218.93 秒

LET t0=TIME


LET N=4 !1~2*Nの数が記入されたカード Ω={1,2,…,N-1,N,N+1,…,2*N-1,2*N}

LET s=1
FOR k=1 TO N !Σ[k=1,N]{COMB(2*k,2)/k}
   LET s=s*COMB(2*k,2)/k
NEXT k
PRINT "場合の数=";s


LET ANSWER_COUNT=0

!●ステップ1
!ペアを適当に作って
! ペアの小さい方の数字P={a,b,c,d,…}の総和をA=a+b+c+d+ …
! ペアの大きい方の数字Q={x,y,z,w,…}の総和をB=x+y+z+w+ …
!とする。

LET w=0 !B+A=(a+b+c+d+ …)+(x+y+z+w+ …)=Σ[k=1,2*n]k …式[1]
FOR k=1 TO 2*N
   LET w=w+k
NEXT k
LET s=0 !B-A=(a+b+c+d+ …)-(x+y+z+w+ …)=Σ[k=1,n]k …式[2]
FOR k=1 TO N
   LET s=s+k
NEXT k

LET B=(w+s)/2 !連立方程式を解く [1]+[2]より
LET A=w-B ![1]に代入
PRINT "A=";A; "B=";B !debug
IF A<>INT(A) OR B<>INT(B) THEN
   PRINT "AまたはBは整数でないので、解なし。"
   STOP
END IF


!●ステップ2 Aに着目して、Pを求める。

DIM E(N) !初期パターン {1,2,3,4,…,N}
FOR k=1 TO N
   LET E(k)=k
NEXT k

DIM P(N) !P={a,b,c,d,…}
MAT P=E
DO !ペアの全パターンから
   LET s=0 !a+b+c+d+ …
   FOR k=1 TO N
      LET s=s+P(k)
   NEXT k
   IF P(1)<>1 THEN EXIT DO !※1∈P
   IF P(N)<>2*N AND s=A THEN !条件を満たすもの ※2*N∈Q
      MAT PRINT USING("P={"&REPEAT$("### ",N)&"}"): P !debug


      !そのPからQは一意に求まる

      DIM Q(2*N) !Q={x,y,z,w,…}=Ω-P
      MAT Q=ZER !未使用とする
      FOR k=1 TO N
         LET Q(P(k))=-1 !使用とする
      NEXT k
      !!!FOR k=1 TO 2*N !Q
      !!!   IF Q(k)=0 THEN PRINT k;
      !!!NEXT k
      !!!PRINT


      !●ステップ3 PとQが差の条件を満たすかどうか確認する

      DIM R(N) !差分列 R={1,2,3,4,…}
      MAT R=E
      DO !Pと差分Rから機械的に、ペア (Pk,Pk+Rk)を生成する
         DIM QQ(2*N)
         MAT QQ=Q !restore it

         FOR k=1 TO N !生成した数がQの要素(Pk+Rk∈Q)となるかどうか確認する
            LET s=P(k)+R(k)
            IF s>2*N THEN EXIT FOR !要素の範囲?
            IF QQ(s)<>0 THEN EXIT FOR !一意性?
            LET QQ(s)=k !使用とする
         NEXT k
         IF k>N THEN !Qと一致するなら、結果を表示する
            LET ANSWER_COUNT=ANSWER_COUNT+1 !解答数
            PRINT "No.";ANSWER_COUNT
            FOR k=1 TO N !ペア (Pk,Pk+Rk)
               PRINT "(";P(k);",";P(k)+R(k);") ";
            NEXT k
            MAT PRINT R; !差分列
         ELSE
            LET h=PermFactorial2Num(R,N) + FACT(N-k)-1 !…,Rk,~をスキップする
            CALL Num2PermFactorial(h, R,N)
         END IF

         CALL NextPermFactorial(R,N, rc) !次へ
      LOOP UNTIL rc=0 !FACT(N)通り

   END IF


   CALL NextComb(P,2*N,N, rc) !次へ
LOOP UNTIL rc=0 !COMB(2*N,N)通り

IF ANSWER_COUNT=0 THEN PRINT "解なし"


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

END


!異なるn個からr個を選ぶ組合せ COMB(N,R)通り

EXTERNAL SUB NextComb(A(),N,R, rc) !辞書式順序で次の組合せを返す
LET rc=0 !完了
FOR i=R TO 1 STEP -1
   IF A(i)<N-R+i THEN !i~N-R+iで更新する
      LET A(i)=A(i)+1
      FOR j=i+1 TO R !A(i)<A(i+1)< … <A(R) 最初の並び
         LET A(j)=A(j-1)+1
      NEXT j
      LET rc=1 !未了
      EXIT SUB
   END IF
NEXT i
END SUB


!異なるn個のものをすべて並べる FACT(n)通り

EXTERNAL FUNCTION PermFactorial2Num(A(),N) !順列パターンに番号を付ける ※辞書式順序
FOR j=1 TO N-1 !階乗進数の各桁の値+1 A[1..N]=(N-1)! … 3! 2! 1! 0!
   FOR k=j+1 TO N
      IF A(k)>=A(j) THEN LET A(k)=A(k)-1
   NEXT k
NEXT j
LET v=0
FOR j=N TO 1 STEP -1 !非負の10進数整数へ
   LET v=v*j+A(N-j+1)-1
NEXT j
LET PermFactorial2Num=v
END FUNCTION

EXTERNAL SUB Num2PermFactorial(h, A(),N) !番号から順列パターンを生成する ※辞書式順序
LET v=h !非負の10進数整数を階乗進数へ
FOR j=1 TO N
   LET t=INT(v/j)
   LET A(N-j+1)=v-t*j +1 !階乗進数の各桁の値+1 A[1..N]=(N-1)! … 3! 2! 1! 0!
   LET v=t
NEXT j
FOR j=N-1 TO 1 STEP -1 !順列パターンへ
   FOR k=j+1 TO N
      IF A(k)>=A(j) THEN LET A(k)=A(k)+1
   NEXT k
NEXT j
END SUB

EXTERNAL SUB NextPermFactorial(A(),N, rc) !辞書式順序で次の順列を返す
LET rc=0 !完了

LET i=N-1 !順列を右から左にみて、増加列から減少列に変わる位置iを探す
DO WHILE i>0 AND A(i)>=A(i+1) !0は番人
!!!DO WHILE i>0 AND A(i)<=A(i+1) !0は番人 ※前の順列 ←←←←←
   LET i=i-1
LOOP
IF i=0 THEN EXIT SUB !A(1)>A(2)>A(3)> … >A(N)なら 例. N=4、4,3,2,1

LET j=N !その位置iより右で、A(i)以上で最小の数A(j)を探す
DO WHILE A(i)>=A(j)
!!!DO WHILE A(i)<=A(j) ! ※前の順列 ←←←←←
   LET j=j-1
LOOP
LET t=A(i) !A(i)とA(j)を交換する
LET A(i)=A(j)
LET A(j)=t

LET i=i+1 !(i+1)からNまでの範囲を逆順にする
LET j=N
DO WHILE i<j
   LET t=A(i) !swap it
   LET A(i)=A(j)
   LET A(j)=t
   LET i=i+1
   LET j=j-1
LOOP
LET rc=1 !未了
END SUB
 

Re: 教えて下さい。

 投稿者:山中和義  投稿日:2010年 2月28日(日)17時00分8秒
  > No.1056[元記事へ]

GAIさんへのお返事です。

> これを一般化して2n枚のカード

別解として、「2nから2枚を選ぶ」を「2枚を2nに置く」として考えてみました。
計算量 O(FACT(N))です。n=13が求まるかも、、、
!1~nの数が記入されたカードが2枚ずつある。
!これを1~2nの位置に置くとき、その配置の「場合の数」を求めよ。
!ただし、番号nのカードどうしはnだけ離れて置く必要がある。
!例 4の場合
! 12345678←位置
! 4***4***
! *4***4**
! **4***4*
! ***4***4

!答え
! n mod 4が0,1のとき、可能性がある。2,3なら、0
!
!n=1,2,3,4, 5,6,7,  8,   9,10,11,    12,13,14,15, …
! 1,0,0,6,10,0,0,504,2656, 0, 0,455936,??, 0, 0, …
!※パソコンの性能により調査できず

!PentiumⅢ700MHz,WindowsMe,2進モード n=9の場合、計算時間= 179.22 秒

LET t0=TIME

LET N=8 !1~nのカード

PUBLIC NUMERIC ANSWER_COUNT
LET ANSWER_COUNT=0

DIM A(2*N) !配置位置
MAT A=ZER
CALL backtrack(N,N,A) !N,…,2,1 計算量O(FACT(N))

IF ANSWER_COUNT=0 THEN PRINT "解なし"

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

END

EXTERNAL SUB backtrack(p,N,A()) !バックトラック法で検証する
FOR i=1 TO 2*N-p !カードpの1枚目を位置iに置く
   IF A(i)=0 AND A(i+p)=0 THEN !2枚とも置けるなら

      IF p=1 THEN !すべて置けたら、結果を表示する
      !!!MAT PRINT A; !debug
         LET ANSWER_COUNT=ANSWER_COUNT+1 !解答数
         PRINT "No.";ANSWER_COUNT
         FOR s=0 TO N-1 !差が1~nの順に
            FOR x=1 TO 2*N
               IF A(x)=s THEN
                  PRINT "(";x;",";x+s+1;") "; !ペア
                  EXIT FOR
               END IF
            NEXT x
         NEXT s
         PRINT
      ELSE
         LET A(i)=p-1 !仮に置いてみる
         LET A(i+p)=p-1

         CALL backtrack(p-1,N,A) !次へ

         LET A(i)=0 !元に戻す
         LET A(i+p)=0
      END IF

   END IF
NEXT i
END SUB
 

この解釈ですか?

 投稿者:GAI  投稿日:2010年 2月28日(日)19時59分22秒
  > No.1059[元記事へ]

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

> 別解として、「2nから2枚を選ぶ」を「2枚を2nに置く」として考えてみました。
> !1~nの数が記入されたカードが2枚ずつある。
> !これを1~2nの位置に置くとき、その配置の「場合の数」を求めよ。
> !ただし、番号nのカードどうしはnだけ離れて置く必要がある。

これは
n=2の時の解を

差:  4    3    2    1  <12345678>

  (1,5)(4,7)(6,8)(2,3)→41134232・・・a

  (1,5)(3,6)(2,4)(7.8)→42324311・・・b

  (2,6)(1,4)(3,5)(7,8)→34232411・・・c

  (3,7)(5,8)(4,6)(1,2)→11423243・・・d

  (4,8)(2,5)(1,3)(6,7)→23243114・・・e

  (4,8)(3,6)(5,7)(1,2)→11342324・・・f

と解釈するという意味ですか?
(すると、a↔e、b↔f、c↔dなる対応が成立するんですね。)

これを理解するのに苦心しました。
よくこんな発想の転換が思いつきますね。感心します。

n=13 なら 3,040,560(種類)でしょうか?
 

Re: この解釈ですか?

 投稿者:山中和義  投稿日:2010年 3月 1日(月)09時11分59秒
  > No.1060[元記事へ]

GAIさんへのお返事です。

> と解釈するという意味ですか?
> (すると、a?e、b?f、c?dなる対応が成立するんですね。)
> n=13 なら 3,040,560(種類)でしょうか?

そうですね。
n=13は、BASICAccで15分で求まりました。
(途中の組の表示はしなくて、ANSWER_COUNTのみ最後に表示させる)


最初のプログラム
・組合せ、順列の数理(A,Bの関係、差分列)からのアプローチ - 人間向き

別解
・総当りの検索 - コンピュータ向き

というプログラム演習の題材(アルゴリズムとそのコード化)になります。

こども向けのパズルと思いましたが、おとなもハマル良質の問題ですね。勉強になりました。
 

Re: 自動行番号付与について

 投稿者:白石 和夫  投稿日:2010年 3月 2日(火)17時34分20秒
  > No.1062[元記事へ]

プログラムをファイルに保存して,
テキストファイルを処理する要領で行番号を付加するプログラムを作ってみてください。

裏技としては,3000番を付与したい行に3000番を振って,たとえば,
100 PRINT "-----"
120 REM
150 REM
200 PRINT "---------"
3000 REM
REM
REM
END
のようにしてから,行番号メニューで行番号の初期値を100,増分を10にして実行するとうまくいきます。(保証はしません)
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 3月 3日(水)13時28分41秒
  > No.1051[元記事へ]

行列の成分の並びを入れ替える。
!問題
! ゲーム「テトリス」のテトロミノの回転の実装
! 例 T型
!   ■
!  ■■ → ■■■
!   ■    ■

!答え
!PxQ行列の成分を定義する

LET P=3 !行
LET Q=2 !列

DIM S$(P*Q) !パターン
DATA " ","■"
DATA "■","■"
DATA " ","■"
MAT READ S$

!PxQ行列の成分を90°回転させる場合、成分の番号付けは
!  1 2    2 4 6
!  3 4 →  1 3 5
!  5 6
!となる。

!成分の並びを入れ替える置換σ、写像fを定義する

DIM T(Q,P) !行列の成分番号
FOR i=1 TO Q !反時計まわりに90°回転
   FOR j=1 TO P
      LET T(i,j)=Q*(j-1)+(Q-i+1)
   NEXT j
NEXT i

CALL PrintOutA(S$,T,Q,P)
SUB PrintOutA(T$(),A(,),P,Q) !並び順AによるP行Q列の行列を表示する
!MAT PRINT A; !成分の番号
   FOR i=1 TO P
      FOR j=1 TO Q
         PRINT S$(A(i,j));
      NEXT j
      PRINT
   NEXT i
END SUB



!次に個々の並べ替えをみていくことにする。

LET P=5 !行
LET Q=3 !列

DIM B(P,Q),tB(Q,P) !行列の成分番号
FOR i=1 TO P
   FOR j=1 TO Q
      LET B(i,j)=Q*(i-1)+j !元の成分(i,j)
   NEXT j
NEXT i
MAT PRINT B;

FOR i=1 TO Q !転置
   FOR j=1 TO P
      LET tB(i,j)=Q*MOD(j-1,P)+i !(MOD(j-1,P)+1,i)
   NEXT j
NEXT i
MAT PRINT tB;


FOR i=1 TO Q !反時計まわりに90°回転
   FOR j=1 TO P
      LET tB(i,j)=Q*(j-1)+(Q-i+1) !(j,Q-i+1)
   NEXT j
NEXT i
MAT PRINT tB;

FOR i=1 TO P !180°
   FOR j=1 TO Q
      LET B(i,j)=Q*(P-i)+(Q-j+1) !(P-i+1,Q-j+1)
   NEXT j
NEXT i
MAT PRINT B;

FOR i=1 TO Q !270°,-90°
   FOR j=1 TO P
      LET tB(i,j)=Q*(P-j)+i !(P-j+1,i)
   NEXT j
NEXT i
MAT PRINT tB;


FOR i=1 TO P !X軸対称
   FOR j=1 TO Q
      LET B(i,j)=Q*(P-i)+j !(P-i+1,j)
   NEXT j
NEXT i
MAT PRINT B;

FOR i=1 TO P !Y軸対称
   FOR j=1 TO Q
      LET B(i,j)=Q*(i-1)+(Q-j+1) !(i,Q-j+1)
   NEXT j
NEXT i
MAT PRINT B;


END
 

「同じものを含む順列」に番号をつける方法

 投稿者:山中和義  投稿日:2010年 3月 7日(日)10時13分12秒
  > No.1055[元記事へ]

!「同じものを含む順列」に番号をつける方法
!例 aabc,aacb,abac,…,caba,cbaa (2+1+1)!/(2!*1!*1!)=12通り


LET M=3 !異なるm種類
DIM B(M) !それぞれの個数
DATA 2,2,1 !※{1,1,2,2,3}の意
MAT READ B

LET N=0 !総数
FOR i=1 TO M
   LET N=N+B(i)
NEXT i


DIM A(N)
DATA 1,1,2,2,3 !最初のパターン
!!!DATA 3,2,2,1,1 !最後のパターン ※前の順列 ←←←←←
MAT READ A

FOR i=0 TO PermFactorialM(B,M)-1
!!!FOR i=PermFactorialM(B,M)-1 TO 0 STEP -1 ! ※前の順列 ←←←←←

   PRINT "No.";i
   MAT PRINT A;
   PRINT PermFactorialM2Num(A,N,B,M) !符号化

   DIM AA(N)
   MAT AA=ZER
   CALL Num2PermFactorialM(i, AA,N,B,M) !復号化
   MAT PRINT AA;

   CALL NextPermFactorial(A,N, rc) !次へ
   PRINT "rc=";rc

NEXT i


END


!●同じものをそれぞれp,q,…,r個ずつ含む総数n個(n=p+q+ … +r)のものをすべて並べる

!(p+q+ … +r)!/(p!*q!* … *r!)通りの順列パターン ⇔ 0~(p+q+ … +r)!/(p!*q!* … *r!)の番号

EXTERNAL FUNCTION PermFactorialM(B(),M) !同じものを含む順列の「場合の数」
LET s=B(1) !総数 p+q+ … +r
LET t=FACT(B(1)) !階乗の積 p!*q!* … *r!
FOR i=2 TO M
   LET s=s+B(i)
   LET t=t*FACT(B(i))
NEXT i
LET PermFactorialM=FACT(s)/t
END FUNCTION


EXTERNAL FUNCTION PermFactorialM2Num(A(),N,B(),M) !順列パターンに番号を付ける ※辞書式順序
DIM w(M)
MAT w=B !copy it
LET v=0
FOR i=1 TO N-1 !左端に着目する
   LET t=A(i)
   FOR j=1 TO t-1 !左端を1~A(i)-1として
      IF w(j)>0 THEN !その左端を除いた残りで最大の順列をつくる
         LET w(j)=w(j)-1
         !!!MAT PRINT w; !debug
         LET v=v+PermFactorialM(w,M) !その順列の番号を求める
         LET w(j)=w(j)+1
      END IF
   NEXT j
   LET w(t)=w(t)-1 !左端を消して、次へ
NEXT i
LET PermFactorialM2Num=v
END FUNCTION

EXTERNAL SUB Num2PermFactorialM(h, A(),N,B(),M) !番号から順列パターンを生成する ※辞書式順序
DIM w(M)
MAT w=B !copy it
LET v=h
FOR i=1 TO N
   FOR j=1 TO M !左端を1~Mとして
      IF w(j)>0 THEN !その左端を除いた残りで最大の順列をつくる
         LET w(j)=w(j)-1
         !!!MAT PRINT w;
         LET t=PermFactorialM(w,M) !その順列の番号を求める
         IF v<t THEN EXIT FOR
         LET v=v-t
         LET w(j)=w(j)+1
      END IF
   NEXT j
   LET A(i)=j !次へ
NEXT i
END SUB


EXTERNAL SUB NextPermFactorial(A(),N, rc) !辞書式順序で次の順列を返す ※「異なるn個のもの」と共通
LET i=N-1 !順列を右から左にみて、増加列から減少列に変わる位置iを探す
DO WHILE i>0 AND A(i)>=A(i+1) !0は番人
!!!DO WHILE i>0 AND A(i)<=A(i+1) !0は番人 ※前の順列 ←←←←←
   LET i=i-1
LOOP
IF i=0 THEN !A(1)>A(2)>A(3)> … >A(N)なら 例. N=4、4,3,2,1
   LET rc=0 !完了
   EXIT SUB
END IF

LET j=N !その位置iより右で、A(i)以上で最小の数A(j)を探す
DO WHILE A(i)>=A(j)
!!!DO WHILE A(i)<=A(j) ! ※前の順列 ←←←←←
   LET j=j-1
LOOP
LET t=A(i) !A(i)とA(j)を交換する
LET A(i)=A(j)
LET A(j)=t

LET i=i+1 !(i+1)からNまでの範囲を逆順にする
LET j=N
DO WHILE i<j
   LET t=A(i) !swap it
   LET A(i)=A(j)
   LET A(j)=t
   LET i=i+1
   LET j=j-1
LOOP
LET rc=1 !未了
END SUB
 

Re: 昔のbasicの移植

 投稿者:大熊 正メール  投稿日:2010年 3月 8日(月)20時42分4秒
  > No.1042[元記事へ]

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

いつも、ご丁寧な御指導を有難うございます。
その後、御指導のように変更、上手く動くようになりました。実は間違っていたのは
この部分ではなく別の所だったのですが、この部分が正しかったので、その間違っ
てる所も見つけることが出来ました。お礼が遅れましたが本当に有難うございます。

所で、今は昔の「BASIC 刀根 薫/倍風館」の本から移植してるのですが、
別途、山中さん の「電脳集団」の550個の膨大なプログラムはコピーしました。
この中で、先の本のOR に関係する、線形計画法や非線形計画法、PERT,最短路探し
のようなORに関連するような参考プログラムといったら、どのあたりを探したら
良いのでしょうか。

敬具



> 大熊 正さんへのお返事です。
>
> > IF---AND --- THEN   **** ----とあるのが2度続いており
>
> 4040 IF PH=2 AND P=<EPS THEN !※THENで改行する。THEN以降を「行番号なし」の行とする。
>         PRINT "LAST SOLUTION IS OPTIMAL" !※:(マルチステートメント)は1行にする。
>         STOP !※途中のEND文は、STOP文に置き換える。
>      END IF
> 4050 IF PH=1 AND P=<EPS THEN 4380 !行番号のみはそのままでよい。
>
>

http://http://

 

Re: 自動行番号付与について

 投稿者:白石 和夫  投稿日:2010年 3月 8日(月)20時55分46秒
  > No.1066[元記事へ]

行番号付加のコマンドは,すでに行番号を持つ行を見つけると,
その番号がその行に付与しようとした番号より大きいかまたは等しければ,その値まで付与する番号を増やします。
たとえば,3000番からの行番号をつけたい行の最初の行にあらかじめ3000と書いておけば,
以後,その番号から順に増やした番号をつけていきます。
たとえば,
100 REM
200 REM
REM
REM
3000 REM
REM
END
に,初期値10,増分10で行番号付加を指定すれば,
100 REM
200 REM
210 REM
220 REM
3000 REM
3010 REM
3020 END
になります。

ただし,システム既定の行番号付加コマンドで我慢できない人は,
プログラムは単なるテキストファイルなので,BASICプログラムの処理対象になりえる,
だから,自分で好きなようにプログラムを作ってくださいということです。
 

Re: 自動行番号付与について

 投稿者:大熊 正メール  投稿日:2010年 3月 9日(火)12時12分18秒
  > No.1068[元記事へ]

白石 和夫さんへのお返事です。

大熊です。
御丁寧な御返事有難うございます。
実は、裏技で 100から10ステップ を 3000から10ステップとやってました。
100から10ステップでやったところ、上手く行きました。有難うございました。

敬具

> 行番号付加のコマンドは,すでに行番号を持つ行を見つけると,
> その番号がその行に付与しようとした番号より大きいかまたは等しければ,その値まで付与する番号を増やします。
> たとえば,3000番からの行番号をつけたい行の最初の行にあらかじめ3000と書いておけば,
> 以後,その番号から順に増やした番号をつけていきます。
> たとえば,
> 100 REM
> 200 REM
> REM
> REM
> 3000 REM
> REM
> END
> に,初期値10,増分10で行番号付加を指定すれば,
> 100 REM
> 200 REM
> 210 REM
> 220 REM
> 3000 REM
> 3010 REM
> 3020 END
> になります。
>
> ただし,システム既定の行番号付加コマンドで我慢できない人は,
> プログラムは単なるテキストファイルなので,BASICプログラムの処理対象になりえる,
> だから,自分で好きなようにプログラムを作ってくださいということです。

http://http://

 

Re: 昔のbasicの移植

 投稿者:山中和義  投稿日:2010年 3月 9日(火)16時53分22秒
  > No.1067[元記事へ]

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

オペレーションズ・リサーチ(OR,Operations Research)の関連はありません。

> 最短路探し

学習分野
 情報
  アルゴリズム
   グラフ
    最短経路(Dijkstra法).BAS、トポロジカル・ソート.BAS


> 線形計画法や非線形計画法、PERT

取り急ぎ一部作成しました。

●手法一覧
数理計画法(Mathematical Programming)
 線形計画法(LP,Linear Programming)
  シンプレックス法(単体法)
  カーマーカー法(内点法)
 非線形計画法(NP,Nonlinear Programming)
  勾配を使う
   最急降下法(method of steepest decent)
    ステップ幅 - 微小な定数、逐次2分割法、黄金分割法、フィボナッチ法
   共役勾配法(conjugate gradient method)
    ステップ幅 ※同上
   ニュートン法
  勾配を使わない
   シンプレックス法
PERT(Program Evaluation and Review Technique、パート)
 クリティカル・パス


●シンプレックス法(単体法)
!制約式
! a11*x1+a12*x2+ … +a1n*xn≧b1 ※≦
! a21*x1+a22*x2+ … +a2n*xn≧b2 ※≦
!   :
! am1*x1+am2*x2+ … +amn*xn≧bm ※≦
!目的関数
! z=c1*x1+c2*x2+ … *cn*xn

!例
!  x1+3*x2≦18
! 2*x1+3*x2≦21
! 3*x1+ x2≦21
!  x1,x2≧0
! z=2*x1+x2の最大値

LET N=2 !変数の数
LET M=3 !制約式の数

LET R=M+1 !行数
LET C=M+N+1 !桁数

DIM A(R,C) !係数行列
DATA  1, 3, 1,0,0, 18
DATA  2, 3, 0,1,0, 21
DATA  3, 1, 0,0,1, 21
DATA -2,-1, 0,0,0,  0
MAT READ A

DO
   LET mn=9999 !列選択
   FOR k=1 TO C-1
      IF A(R,k)<mn THEN
         LET mn=A(R,k)
         LET y=k
      END IF
   NEXT k
   IF mn>=0 THEN EXIT DO
   LET mn=9999 !行選択
   FOR k=1 TO R-1
      LET p=A(k,C)/A(k,y)
      IF A(k,y)>0 AND p<mn THEN
         LET mn=p
         LET x=k
      END IF
   NEXT k
   LET p=A(x,y) !ピボット係数
   FOR k=1 TO C !ピボット行をpで割る
      LET A(x,k)=A(x,k)/p
   NEXT k
   FOR k=1 TO R !ピボット列の掃き出し
      IF k<>x THEN
         LET d=A(k,y)
         FOR j=1 TO C
            LET A(k,j)=A(k,j)-d*A(x,j)
         NEXT j
      END IF
   NEXT k

LOOP
MAT PRINT A; !debug

FOR k=1 TO N
   LET flg=-1
   FOR j=1 TO R
      IF A(j,k)=1 THEN LET flg=j
   NEXT j
   IF flg<>-1 THEN PRINT "x";STR$(k);"=";A(flg,C)
NEXT k
PRINT "z=";A(R,C)

END

●微小な定数による最急降下法(method of steepest decent)
しばっちさんが、5点公式による数値(偏)微分を紹介されています。No.1044 [元記事へ]

●ニュートン法 ※関数の偏微分は直接指定する
DEF f(x1,x2)=x1^2-x1*x2+3*x2^2 !最小化する関数

DEF df1(x1,x2)=2*x1-x2 !∂f/∂x1
DEF df2(x1,x2)=-x1+6*x2 !∂f/∂x2

LET N=2 !変数の数

DIM H(N,N) !ヘッセ行列 ※正則かつ正定値行列(固有値がすべて正の値)
DATA  2,-1
DATA -1, 6
MAT READ H

DIM x(N) !初期値
DATA 1,2
MAT READ x

LET cEPS=1E-8 !精度

DIM iH(N,N)
MAT iH=INV(H)

LET iter=200 !繰り返し回数
FOR i=1 TO iter
   PRINT "x1=";x(1), "x2=";x(2), "f=";f(x(1),x(2))

   DIM df(N) !勾配∇f
   LET df(1)=df1(x(1),x(2))
   LET df(2)=df2(x(1),x(2))
   !!!MAT PRINT df; !debug

   DIM T(N)
   MAT T=iH*df !変位Δx
   MAT T=x-T !近似解x[k+1]=x[k]-Δx
   !!!MAT PRINT T; !debug

   DIM w(N) !近似解x[k+1]とx[k]のノルム
   MAT w=T-x
   IF DOT(w,w)<cEPS*cEPS THEN EXIT FOR !収束したなら、終了!

   MAT x=T !次へ
NEXT i

END
 

Re: 「同じものを含む順列」に番号をつける方法

 投稿者:GAI  投稿日:2010年 3月10日(水)07時47分51秒
  > No.1065[元記事へ]

同じものを含む順列の中に面白いものをみつけました。
(以下1~16の数字がそれぞれ二度使用されています。)

3,7,2,8,3,2,1,15,1,7,11,9,8,13,16,14,12,10,6,4,5,9,11,15,4,6,5,13,10,12,14,16


さて、全部で32!/(2!)^16=4015057936610313875842560000000(通り)
ある中で、この並び(および逆順)でしか達成できないその調和とは?


同じく1~9を三度使用する順列(全部で27!/(3!)^9=1080491954750208000000(通り))
の中で

1,8,1,9,1,5,2,6,7,2,8,5,2,9,6,4,7,5,3,8,4,6,3,9,7,4,3

とは?
 

Re: 「同じものを含む順列」に番号をつける方法

 投稿者:山中和義  投稿日:2010年 3月10日(水)12時46分58秒
  > No.1071[元記事へ]

GAIさんへのお返事です。

> 同じものを含む順列の中に面白いものをみつけました。
> 1~9を三度使用する順列(全部で27!/(3!)^9=1080491954750208000000(通り))の中で
>
> 1,8,1,9,1,5,2,6,7,2,8,5,2,9,6,4,7,5,3,8,4,6,3,9,7,4,3

先の並びは、考えてみると「同じものを含む順列」の一部ですね。No.1059 [元記事へ]

プログラムを拡張して、いくつか調査してみました。
!1~nの数が記入されたカードがm枚ずつある。
!これを1~m*nの位置に置くとき、その配置の「場合の数」を求めよ。
!ただし、番号nのカードどうしはnだけ離れて置く必要がある。
!例 n=4、m=3で、4のカードの場合
! 123456789ABC←位置
! 4++++4++++4+
! +4++++4++++4 2通り

!答え
!m=3
!n=1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, …
! 0,0,0,0,0,0,0,0,6,10, 0, 0, 0,??,??, …
!※パソコンの性能により調査できず

!PentiumⅢ700MHz,WindowsMe,2進モード n=13の場合、計算時間= 175.71 秒

LET t0=TIME

PUBLIC NUMERIC N,M
LET N=9 !1~nのカード
LET M=3 !m枚ずつ

PUBLIC NUMERIC ANSWER_COUNT
LET ANSWER_COUNT=0

DIM A(M*N) !配置位置
MAT A=ZER
CALL backtrack(N,A) !N,…,2,1 計算量O(FACT(N))

IF ANSWER_COUNT=0 THEN PRINT "解なし"

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

END

EXTERNAL SUB backtrack(p,A()) !バックトラック法で検証する
FOR i=1 TO M*N-(p+1)*(M-1) !カードpの1枚目を位置iに置く
   FOR k=0 TO M-1
      IF A(i+(p+1)*k)<>0 THEN EXIT FOR
   NEXT k
   IF k=M THEN !m枚とも置けるなら

      FOR k=0 TO M-1 !仮に置いてみる
         LET A(i+(p+1)*k)=p
      NEXT k

      IF p=1 THEN !すべて置けたら、結果を表示する
         LET ANSWER_COUNT=ANSWER_COUNT+1 !解答数
         PRINT "No.";ANSWER_COUNT
         MAT PRINT A; !debug
      ELSE
         CALL backtrack(p-1,A) !次へ
      END IF

      FOR k=0 TO M-1 !元に戻す
         LET A(i+(p+1)*k)=0
      NEXT k

   END IF
NEXT i
END SUB

実行結果 ※逆の並びを含む
No. 1
 1  9  1  6  1  8  2  5  7  2  6  9  2  5  8  4  7  6  3  5  4  9  3  8  7  4  3

No. 2
 1  9  1  2  1  8  2  4  6  2  7  9  4  5  8  6  3  4  7  5  3  9  6  8  3  5  7

No. 3
 1  8  1  9  1  5  2  6  7  2  8  5  2  9  6  4  7  5  3  8  4  6  3  9  7  4  3

No. 4
 3  4  7  9  3  6  4  8  3  5  7  4  6  9  2  5  8  2  7  6  2  5  1  9  1  8  1

No. 5
 7  5  3  8  6  9  3  5  7  4  3  6  8  5  4  9  7  2  6  4  2  8  1  2  1  9  1

No. 6
 3  4  7  8  3  9  4  5  3  6  7  4  8  5  2  9  6  2  7  5  2  8  1  6  1  9  1

n=16、m=2の場合は、たくさんありますね。

 n=1,2,3,4,5,6, 7,  8,9,10,   11,    12,13,14,15,16, …
  0,0,2,2,0,0,52,300,0, 0,35584,216288,??,??,??,??, …
 

CON、IDNでの定数倍の不具合

 投稿者:山中和義  投稿日:2010年 3月10日(水)22時09分43秒
  設定する行列と同じ行列の要素の1つを使って、CON、IDNで定数倍できません。
DIM A(10)
LET A(5)=5
MAT A=(A(5))*CON
MAT PRINT A;

DIM B(10,10)
LET B(5,5)=5
MAT B=(B(5,5))*IDN
MAT PRINT B;

END
 

データを読み飛ばすことはできますか?

 投稿者:ひいらぎ  投稿日:2010年 3月11日(木)10時03分43秒
  こんにちは
またお世話になります。

18個一組のデータ(個々の数自体は数桁の整数)数十万個をテキスト形式で出力しました。
これを再び読み込み続きの処理をするのですが、18個のうちの3個目を処理内容判断用に設定しました。

そこで、まず(18×数十万)行のうちの3/18番目だけを読み込みたいと思うのですが、
このように、連続データを飛び飛びに読み込ませることはできないものでしょうか?
POINTERを何とかできないものかとあれこれ考えているのですが思い付きません。
やはり空読みさせるしかないのでしょうか?

これもまた初歩的なことかもしれませんが、教えて頂けるとありがたいです。
よろしくお願い致します。
 

Re: データを読み飛ばすことはできますか?

 投稿者:山中和義  投稿日:2010年 3月11日(木)10時29分36秒
  > No.1074[元記事へ]

ひいらぎさんへのお返事です。

> 18個一組のデータ(個々の数自体は数桁の整数)数十万個をテキスト形式で出力しました。
> そこで、まず(18×数十万)行のうちの3/18番目だけを読み込みたいと思うのですが、

(同一プログラムなら)書き出しを3番目だけにすれば読み込みは連続です。
実際、書き出しの17/18は無駄です。


> POINTERを何とかできないものかとあれこれ考えているのですが思い付きません。

先頭か末尾のみに設定できます。途中はありません。
ポインタを動かすというのは「誰(OS、BASIC)が行うか」だけのことです。


> やはり空読みさせるしかないのでしょうか?

そう思います。
 

Re: 昔のbasicの移植

 投稿者:山中和義  投稿日:2010年 3月11日(木)11時21分15秒
  > No.1070[元記事へ]

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

> オペレーションズ・リサーチ(OR,Operations Research)の関連

●共役勾配法(conjugate gradient method)
!非線形関数 f(x1,x2)=(x1-2)^2+(x1-2*x2)^2 の最小値
!初期値を(x1,x2)=(0,0)、ステップ幅α=0.1 とする。

DEF f(x1,x2)=(x1-2)^2+(x1-2*x2)^2 !関数

DEF df1(x1,x2)=2*(x1-2)+2*(x1-2*x2) !∂f/∂x1
DEF df2(x1,x2)=-4*(x1-2*x2) !∂f/∂x2

LET N=2 !変数の数

DIM x(N) !初期値
DATA 1,2
MAT READ x

LET a=0.1 !ステップ幅

LET cEPS=1E-8 !精度

LET iter=200 !繰り返し回数
FOR k=1 TO iter
   PRINT "x1=";x(1), "x2=";x(2), "f=";f(x(1),x(2))

   DIM df(N) !勾配∇f
   LET df(1)=df1(x(1),x(2))
   LET df(2)=df2(x(1),x(2))
   !!!MAT PRINT df; !debug

   LET norm=DOT(df,df)
   IF norm<cEPS*cEPS THEN EXIT FOR !勾配が0なら、終了!

   DIM S(N)
   MAT S=(-1)*df !降下方向 s[k]=-∇f(x[k])

   DIM w(N),s0(N)
   IF k<>1 THEN
   !λ[k]=∥∇f(x[k])∥^2/∥∇f(x[k-1]∥^2 フレッチャー・リーブス(Fletcher-Reeves)の公式
      LET l=norm/norm0

      MAT w=l*s0 !s[k]=-∇f(x[k])+λ[k-1]*s[k-1]
      MAT S=S+w
   END IF
   LET norm0=norm
   MAT s0=S

   MAT w=a*S !近似解 x[k+1]=x[k]+α*s[k]
   MAT x=x+w
NEXT k

END


●PERT(Program Evaluation and Review Technique、パート)
!PERT図(アローダイアグラム)

SET WINDOW -0.5,6,-0.5,6 !作画領域
DRAW grid
SET TEXT JUSTIFY "center","half"

LET N=9 !結合点(ノード)の数

DATA 1,3 !結合点1のx,y座標
DATA 2,4 !2
DATA 2,3 !3
DATA 2,1 !4
DATA 3,1 !5
DATA 3,3 !6
DATA 3,4 !7
DATA 4,3 !8
DATA 5,3 !9

DIM xNd(N),yNd(N) !結合点のx,y座標
FOR i=1 TO N
   READ xNd(i),yNd(i)
NEXT i


LET T=11 !工程の数
DATA 1,2, 5,"A" !工程Aの結合点と日数 ※始端:1、終端:N
DATA 2,7, 2,"B"
DATA 7,8, 1,"D"
DATA 1,3,15,"E"
DATA 3,6, 7,"F"
DATA 6,8, 7,"H"
DATA 1,4,20,"C"
DATA 4,5, 1,"G"
DATA 5,6, 0,""
DATA 5,8, 3,"i"
DATA 8,9, 1,"J"

DIM M(N,N) !有向グラフの隣接行列 ※成分(i,j)は、上三角行列:i→j、下三角行列:j→iの意
MAT M=(-1)*CON
FOR i=1 TO T
   READ n1,n2,d,nm$
   IF n1<1 OR n2<1 OR n1>N OR n2>N THEN
      PRINT "結合点番号が1~";N;"の範囲ではありません。", n1;n2;d;nm$
      STOP
   END IF
   IF d<0 THEN
      PRINT "日数が負です。", n1;n2;d;nm$
      STOP
   END IF
   LET M(n1,n2)=d
   LET M(n2,n1)=d

   IF d<>0 THEN SET LINE STYLE 1 ELSE SET LINE STYLE 3 !実線、破線
   PLOT LINES: xNd(n1),yNd(n1); xNd(n2),yNd(n2) !結線
   PLOT TEXT ,AT (xNd(n1)+xNd(n2))/2,(yNd(n1)+yNd(n2))/2+0.15: nm$&"("&STR$(d)&")" !工程(日数)
NEXT i
MAT PRINT M;


PUBLIC NUMERIC Z(100),ZZ(100) !結合点(ノード)の日数

!最早結合点時刻
DIM R(N),A(N) !経路、日数
MAT A=ZER
MAT R=ZER
LET R(1)=1 !始端1から開始する
MAT Z=ZER(N)
CALL backtrack(1,M,N,A,R,0)
MAT PRINT Z; !結果

PRINT


!最遅結合点時刻
LET mx=Z(N) !終端での日数
MAT A=(mx)*CON
MAT R=ZER
LET R(N)=N !終端Nから開始する
MAT ZZ=A
CALL backtrack2(N,M,N,A,R,(A(N))) !※A(N)は値渡し
MAT PRINT ZZ; !結果


FOR i=1 TO N !結合点を描く
   PLOT TEXT ,AT xNd(i),yNd(i)-0.25: STR$(Z(i))&"/"&STR$(ZZ(i)) !日数

   IF Z(i)=ZZ(i) THEN SET AREA COLOR 4 ELSE SET AREA COLOR 1 !クリティカルパス
   DRAW disk WITH SCALE(0.1)*SHIFT(xNd(i),yNd(i))

   PLOT TEXT, AT xNd(i),yNd(i)+0.25: STR$(i) !番号
NEXT i

END


EXTERNAL SUB backtrack(c,M(,),N,A(),R(),s) !バックトラック法で全経路を調査する
IF c=N THEN !終端Nなら
   MAT PRINT R; !debug
   MAT PRINT A;
   FOR i=1 TO N !各ノードの日数を記録する
      IF A(i)>Z(i) THEN LET Z(i)=A(i) !最大のもの
   NEXT i
ELSE
   FOR j=c TO N !次の経路を探す ※上三角行列
      LET w=M(c,j)
      IF w>=0 THEN !経路c→jがあれば
         LET s=s+w !累計
         LET R(j)=j !経路を記録する
         LET A(j)=s !日数
         CALL backtrack(j,M,N,A,R,s) !次へ
         LET s=s-w !元に戻す
         LET R(j)=0
         LET A(j)=A(1)
      END IF
   NEXT j
END IF
END SUB

EXTERNAL SUB backtrack2(c,M(,),N,A(),R(),s) !バックトラック法で全経路を調査する
IF c=1 THEN !始端1なら
   MAT PRINT R; !debug
   MAT PRINT A;
   FOR i=1 TO N !各ノードの日数を記録する
      IF A(i)<ZZ(i) THEN LET ZZ(i)=A(i) !最小のもの
   NEXT i
ELSE
   FOR j=1 TO c !次の経路を探す ※下三角行列
      LET w=M(c,j)
      IF w>=0 THEN !経路j→cがあれば
         LET s=s-w !累計
         LET R(j)=j !経路を記録する
         LET A(j)=s !日数
         CALL backtrack2(j,M,N,A,R,s) !次へ
         LET s=s+w !元に戻す
         LET R(j)=0
         LET A(j)=A(N)
      END IF
   NEXT j
END IF
END SUB
 

Re: CON、IDNでの定数倍の不具合

 投稿者:白石 和夫  投稿日:2010年 3月11日(木)14時15分33秒
  > No.1073[元記事へ]

> 設定する行列と同じ行列の要素の1つを使って、CON、IDNで定数倍できません。
評価する順番に問題があったようです。
直します。(各数値モードごとにやらないと駄目っぽいので時間がかかると思います)
 

相対参照を使いたい

 投稿者:N.E.  投稿日:2010年 3月11日(木)14時53分5秒
  ファイルの読みこみで相対参照は使えますか?教えて下さい。  

Re: 相対参照を使いたい

 投稿者:山中和義  投稿日:2010年 3月11日(木)15時50分19秒
  > No.1078[元記事へ]

N.E.さんへのお返事です。

> ファイルの読みこみで相対参照は使えますか?教えて下さい。

相対パス
 OSのフォルダ(ディレクトリ)指定で可能です。
 例 OPEN #1: NAME "..\TEST\P.DAT"


相対ファイル(COBOL系)
 ランダムファイル(FULL BASICではバイナリファイル)として扱う。
 N88系のFIELD文、MKI$,CVI関数などはない。

 http://hp.vector.co.jp/authors/VA008683/QA7-1.htm
 http://hp.vector.co.jp/authors/VA008683/QA7.htm
 

Re: 相対参照を使いたい

 投稿者:N.E.  投稿日:2010年 3月11日(木)17時29分15秒
  山中和義さんへのお返事です。 > > ファイルの読みこみで相対参照は使えますか?教えて下さい。
> > 相対パス
>  OSのフォルダ(ディレクトリ)指定で可能です。
>  例 OPEN #1: NAME "..\TEST\P.DAT"
有り難う御座います。出来ました。ドライブ名を書かなければいいのですね。
 

(無題)

 投稿者:N.E.  投稿日:2010年 3月11日(木)17時51分22秒
  INPUT文に対応する書き込み用の文はあるのですか?
それとも、直接メモ帳等で書くのですか?
よく分かりません。教えて下さい。
 

Re: (無題)

 投稿者:山中和義  投稿日:2010年 3月11日(木)19時00分40秒
  > No.1081[元記事へ]

N.E.さんへのお返事です。

> INPUT文に対応する書き込み用の文はあるのですか?
> それとも、直接メモ帳等で書くのですか?

簡単なデータならメモ帳でいいでしょう。
通常のテキスト画面への表示命令に#を付けた命令でファイルにアクセスします。(ヘルプ参照のこと)
書き込み
 PRINT #1
読み込み
 INPUT #1
 LINE INPUT #1
 

Re: データを読み飛ばすことはできますか?

 投稿者:ひいらぎ  投稿日:2010年 3月12日(金)08時32分53秒
  > No.1075[元記事へ]

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

途中のデータを飛ばして読み込むことは、やはりできないのですね。
とりあえず、と思って書き出したのですが、後の処理のことも
もう少し考えておく必要があったようです。

試行錯誤で、思うことをさせるのに時間が掛かっていますが、
こうして素早いご返答を戴けるので、大いに助かっています。
これからもどうぞよろしくお願い致します。
ありがとうございました。
 

Re: 昔のbasicの移植

 投稿者:大熊 正メール  投稿日:2010年 3月12日(金)17時14分4秒
  > No.1070[元記事へ]

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

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

具体的な学習分野とプログラムまで示していただき恐縮しております。
早速、ためし、又勉強したいと考えています。有難うございました。

敬具

>
> 学習分野
>  情報
>   アルゴリズム
>    グラフ
>     最短経路(Dijkstra法).BAS、トポロジカル・ソート.BAS
>
>
> > 線形計画法や非線形計画法、PERT
>
> 取り急ぎ一部作成しました。
>
> ●手法一覧
> 数理計画法(Mathematical Programming)
>  線形計画法(LP,Linear Programming)
>   シンプレックス法(単体法)
>   カーマーカー法(内点法)
>  非線形計画法(NP,Nonlinear Programming)
>   勾配を使う
>    最急降下法(method of steepest decent)
>     ステップ幅 - 微小な定数、逐次2分割法、黄金分割法、フィボナッチ法
>    共役勾配法(conjugate gradient method)
>     ステップ幅 ※同上
>    ニュートン法
>   勾配を使わない
>    シンプレックス法
> PERT(Program Evaluation and Review Technique、パート)
>  クリティカル・パス
>
>

http://http://

 

Re: (無題)

 投稿者:N.E.  投稿日:2010年 3月12日(金)20時49分35秒
  > No.1082[元記事へ]

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

> 簡単なデータならメモ帳でいいでしょう。
> 通常のテキスト画面への表示命令に#を付けた命令でファイルにアクセスします。(ヘルプ参照のこと)
> 書き込み
>  PRINT #1
> 読み込み
>  INPUT #1
>  LINE INPUT #1
大体分かりました。
でも、PRINT文を使って
   LET a=5
   LET b=10
   PRINT #1:a.b
と書くと、内容は
5          10
の様になり、
INPUT文で読みこめません。
   STR$(a)&","STR$(b)
の様にするしかないのでしょうか。
 

Re: (無題)

 投稿者:白石 和夫メール  投稿日:2010年 3月12日(金)21時05分58秒
  > No.1085[元記事へ]

内部形式ファイルを使うところです。

http://www.geocities.jp/thinking_math_education/BASICHelp/html/basi6pgl.htm
 

Re: (無題)

 投稿者:山中和義  投稿日:2010年 3月12日(金)22時10分37秒
  > No.1085[元記事へ]

N.E.さんへのお返事です。

>    LET a=5
>    LET b=10
>    PRINT #1:a.b
> と書くと、内容は
> 5          10
> の様になり、INPUT文で読みこめません。
>    STR$(a)&","STR$(b)
> の様にするしかないのでしょうか。

いわゆるCSV形式(カンマ付き)をつくればいいと思います。
http://hp.vector.co.jp/authors/VA008683/QA_CSV.htm

書き込みプログラム
OPEN #1: NAME "TEST.TXT" ,ACCESS OUTIN
ERASE #1
LET a=7
LET b=15
PRINT #1: a, ","; b !ケース1
!!!PRINT #1: a; ","; b !ケース2
CLOSE #1
END

TEST.TXTの内容
 7                      , 15
ケース2の場合
 7 , 15

読み込みプログラム
OPEN #1: NAME "TEST.TXT" ,ACCESS INPUT
INPUT #1: a,b
PRINT a,b
CLOSE #1
END
 

「順列と組合せ」の符号化・復号化などによる列挙

 投稿者:山中和義  投稿日:2010年 3月13日(土)10時48分8秒
  [関数、手続きの一覧]
順列

●異なるn個のものをすべて並べる ※{1,2,3,…,n}上の全順列(n-順列)

FACT(N) 場合の数 ※組み込み関数
FUNCTION PermFactorial2Num(A(),N) パターンに番号を付ける
SUB Num2PermFactorial(h, A(),N) 番号からパターンを生成する
SUB PrevPermFactorial(A(),N, rc) 辞書式順序で1つ前を返す
SUB NextPermFactorial(A(),N, rc) 辞書式順序で1つ次を返す


●異なるn個のものから重複を許さずr個を取り出して並べる ※{1,2,3,…,n}上のr-順列

PERM(N,R) ※組み込み関数
FUNCTION Perm2Num(A(),N,R)
SUB Num2Perm(h, A(),N,R)
SUB PrevPerm(A(),N,R, rc)
SUB NextPerm(A(),N,R, rc)


●同じものをそれぞれp,q,…,r個ずつ含む総数n個(n=p+q+ … +r)のものをすべて並べる

FUNCTION PermFactorialM(B(),M) ※(p+q+ … +r)!/(p!*q!* … *r!)
FUNCTION PermFactorialM2Num(A(),N,B(),M)
SUB Num2PermFactorialM(h, A(),N,B(),M)
SUB PrevPermFactorial(A(),N, rc) ※全順列と同じ
SUB NextPermFactorial(A(),N, rc) ※全順列と同じ


●異なるn個のものから重複を許してr個を取り出して並べる(重複順列)

N^R
FUNCTION ReptPerm2Num(A(),N,R)
SUB Num2ReptPerm(h, A(),N,R)
SUB PrevReptPerm(A(),N,R, rc)
SUB NextReptPerm(A(),N,R, rc)


●異なるn個のものをすべて円形に並べる(円順列)

FACT(N-1) ※組み込み関数
?
?
?
?


●異なるn個のものをすべて円形に並べる(左右対称なものは除く)(数珠順列)

FACT(N-1)/2 ※組み込み関数
?
?
?
?


組合せ

●異なるn個のものから重複を許さずr個を取り出す組合せ

COMB(N,R) ※組み込み関数
FUNCTION Comb2Num(A(),N,R)
SUB Num2Comb(h, A(),N,R)
SUB PrevComb(A(),N,R, rc)
SUB NextComb(A(),N,R, rc)


●異なるn個のものから重複を許してr個を取り出す組合せ(重複組合せ)

COMB(N+R-1,R) ※組み込み関数
FUNCTION ReptComb2Num(A(),N,R)
SUB Num2ReptComb(h, A(),N,R)
SUB PrevReptComb(A(),N,R, rc)
SUB NextReptComb(A(),N,R, rc)

[サンプル・プログラム]
LET N=5
LET R=3

DIM A(R) !最初のパターン
FOR i=1 TO R !初期値 A={1,1,1,…,1} ※重複組合せ
   LET A(i)=1
NEXT i

LET s=0 !番号付け 0~
DO
   PRINT "No.";s
   MAT PRINT A;

   PRINT ReptComb2Num(A,N,R) !符号化

   DIM AA(R)
   MAT AA=ZER
   CALL Num2ReptComb(s,AA,N,R) !復号化
   MAT PRINT AA;

   CALL NextReptComb(A,N,R, rc) !次へ
   LET s=s+1
LOOP WHILE rc<>0
PRINT


LET s=COMB(N+R-1,R)-1 !場合の数 nHr=n+r-1Cr
DO
   PRINT "No.";s
   MAT PRINT A;
   CALL PrevReptComb(A,N,R, rc)
   LET s=s-1
LOOP WHILE rc<>0


END


!最小完全ハッシュ関数 factoradic

!●異なるn個のものをすべて並べる ※{1,2,3,…,n}上の全順列(n-順列)

!n!通りの順列パターン ⇔ 0~(n!-1)の番号

EXTERNAL FUNCTION PermFactorial2Num(A(),N) !順列パターンに番号を付ける ※辞書式順序
FOR j=1 TO N-1 !階乗進数の各桁の値+1 A[1..N]=(N-1)! … 3! 2! 1! 0!
   FOR k=j+1 TO N
      IF A(k)>=A(j) THEN LET A(k)=A(k)-1
   NEXT k
NEXT j
LET v=0
FOR j=N TO 1 STEP -1 !非負の10進数整数へ
   LET v=v*j+A(N-j+1)-1
NEXT j
LET PermFactorial2Num=v
END FUNCTION

EXTERNAL SUB Num2PermFactorial(h, A(),N) !番号から順列パターンを生成する ※辞書式順序
LET v=h !非負の10進数整数を階乗進数へ
FOR j=1 TO N
   LET t=INT(v/j)
   LET A(N-j+1)=v-t*j +1 !階乗進数の各桁の値+1 A[1..N]=(N-1)! … 3! 2! 1! 0!
   LET v=t
NEXT j
FOR j=N-1 TO 1 STEP -1 !順列パターンへ
   FOR k=j+1 TO N
      IF A(k)>=A(j) THEN LET A(k)=A(k)+1
   NEXT k
NEXT j
END SUB


EXTERNAL SUB PrevPermFactorial(A(),N, rc) !辞書式順序で次の順列を返す
LET rc=0 !完了

LET i=N-1 !順列を右から左にみて、増加列から減少列に変わる位置iを探す
DO WHILE i>0 AND A(i)<=A(i+1) !0は番人
   LET i=i-1
LOOP
IF i=0 THEN EXIT SUB !A(1)>A(2)>A(3)> … >A(N)なら 例. N=4、4,3,2,1

LET j=N !その位置iより右で、A(i)以上で最小の数A(j)を探す
DO WHILE A(i)<=A(j)
   LET j=j-1
LOOP
LET t=A(i) !A(i)とA(j)を交換する
LET A(i)=A(j)
LET A(j)=t

LET i=i+1 !(i+1)からNまでの範囲を逆順にする
LET j=N
DO WHILE i<j
   LET t=A(i) !swap it
   LET A(i)=A(j)
   LET A(j)=t
   LET i=i+1
   LET j=j-1
LOOP
LET rc=1 !未了
END SUB

EXTERNAL SUB NextPermFactorial(A(),N, rc) !辞書式順序で次の順列を返す
LET rc=0 !完了

LET i=N-1 !順列を右から左にみて、増加列から減少列に変わる位置iを探す
DO WHILE i>0 AND A(i)>=A(i+1) !0は番人
!!!DO WHILE i>0 AND A(i)<=A(i+1) !0は番人 ※前の順列 ←←←←←
   LET i=i-1
LOOP
IF i=0 THEN EXIT SUB !A(1)>A(2)>A(3)> … >A(N)なら 例. N=4、4,3,2,1

LET j=N !その位置iより右で、A(i)以上で最小の数A(j)を探す
DO WHILE A(i)>=A(j)
!!!DO WHILE A(i)<=A(j) ! ※前の順列 ←←←←←
   LET j=j-1
LOOP
LET t=A(i) !A(i)とA(j)を交換する
LET A(i)=A(j)
LET A(j)=t

LET i=i+1 !(i+1)からNまでの範囲を逆順にする
LET j=N
DO WHILE i<j
   LET t=A(i) !swap it
   LET A(i)=A(j)
   LET A(j)=t
   LET i=i+1
   LET j=j-1
LOOP
LET rc=1 !未了
END SUB


!●異なるn個のものから重複を許さずr個を取り出して並べる ※{1,2,3,…,n}上のr-順列

!perm(n,r)通りの順列パターン ⇔ 0 ~ perm(n,r)-1 の番号

EXTERNAL FUNCTION Perm2Num(A(),N,R) !順列パターンに番号を付ける ※辞書式順序
FOR j=1 TO R-1 !(階乗)進数の各桁の値+1 A[1..R]=PERM(N-1,R-1) … PERM(N-j,R-j) … PERM(N-R,0)
   FOR k=j+1 TO R
      IF A(k)>=A(j) THEN LET A(k)=A(k)-1
   NEXT k
NEXT j
LET v=0
FOR j=R TO 1 STEP -1 !非負の10進数整数へ
   LET v=v*(N-R+j)+A(R-j+1)-1
NEXT j
LET Perm2Num=v
END FUNCTION

EXTERNAL SUB Num2Perm(h, A(),N,R) !番号から順列パターンを生成する ※辞書式順序
LET v=h !非負の10進数整数を(階乗)進数へ
FOR j=1 TO R
   LET w=N-R+j
   LET t=INT(v/w)
   LET A(R-j+1)=v-t*w +1 !(階乗)進数の各桁の値+1 A[1..R]=PERM(N-1,R-1) … PERM(N-j,R-j) … PERM(N-R,0)
   LET v=t
NEXT j
FOR j=R-1 TO 1 STEP -1 !順列パターンへ
   FOR k=j+1 TO R
      IF A(k)>=A(j) THEN LET A(k)=A(k)+1
   NEXT k
NEXT j
END SUB


EXTERNAL SUB PrevPerm(A(),N,R, rc) !辞書式順序で前の順列を返す
LET rc=0 !完了

FOR j=1 TO R-1 !(階乗)進数へ
   FOR k=j+1 TO R
      IF A(k)>=A(j) THEN LET A(k)=A(k)-1
   NEXT k
NEXT j

FOR i=R TO 1 STEP -1 !(階乗)進数で-1する
   IF A(i)>1 THEN !1~(N-i+1)で更新する
      LET A(i)=A(i)-1
      FOR k=i+1 TO R !i桁より下の位を「最後の並び」にする
         LET A(k)=N-k+1
      NEXT k

      LET rc=1 !未了
      EXIT FOR
   END IF
NEXT i

FOR j=R-1 TO 1 STEP -1 !順列パターンへ
   FOR k=j+1 TO R
      IF A(k)>=A(j) THEN LET A(k)=A(k)+1
   NEXT k
NEXT j
END SUB

EXTERNAL SUB NextPerm(A(),N,R, rc) !辞書式順序で次の順列を返す
LET rc=0 !完了

FOR j=1 TO R-1 !(階乗)進数へ
   FOR k=j+1 TO R
      IF A(k)>=A(j) THEN LET A(k)=A(k)-1
   NEXT k
NEXT j

FOR i=R TO 1 STEP -1 !(階乗)進数で+1する
   IF A(i)<N-i+1 THEN !1~(N-i+1)で更新する
      LET A(i)=A(i)+1
      FOR k=i+1 TO R !i桁より下の位を「最初の並び」にする
         LET A(k)=1
      NEXT k

      LET rc=1 !未了
      EXIT FOR
   END IF
NEXT i

FOR j=R-1 TO 1 STEP -1 !順列パターンへ
   FOR k=j+1 TO R
      IF A(k)>=A(j) THEN LET A(k)=A(k)+1
   NEXT k
NEXT j
END SUB
 

Re: 「順列と組合せ」の符号化・復号化などによる列挙

 投稿者:山中和義  投稿日:2010年 3月13日(土)10時49分38秒
  > No.1088[元記事へ]

続き
!●同じものをそれぞれp,q,…,r個ずつ含む総数n個(n=p+q+ … +r)のものをすべて並べる

!(p+q+ … +r)!/(p!*q!* … *r!)通りの順列パターン ⇔ 0~(p+q+ … +r)!/(p!*q!* … *r!)-1の番号

EXTERNAL FUNCTION PermFactorialM(B(),M) !同じものを含む順列の「場合の数」
LET s=B(M) !総数 r, … ,q+ … +r,p+q+ … +r
LET t=1 !組合せ comb(r,r), … ,comb(q+ … +r,q),comb(p+q+ … +r,p)
FOR i=M-1 TO 1 STEP -1
   LET s=s+B(i)
   LET t=t*COMB(s,B(i)) !組合せ順列
NEXT i
LET PermFactorialM=t
!!!別解
!!!LET s=B(1) !総数 p+q+ … +r
!!!LET t=FACT(B(1)) !階乗の積 p!*q!* … *r!
!!!FOR i=2 TO M
!!!   LET s=s+B(i)
!!!   LET t=t*FACT(B(i))
!!!NEXT i
!!!LET PermFactorialM=FACT(s)/t
END FUNCTION


EXTERNAL FUNCTION PermFactorialM2Num(A(),N,B(),M) !順列パターンに番号を付ける ※辞書式順序
DIM w(M)
MAT w=B !copy it
LET v=0
FOR i=1 TO N-1 !左端に着目する
   LET t=A(i)
   FOR j=1 TO t-1 !左端を1~A(i)-1として
      IF w(j)>0 THEN !その左端を除いた残りで最大の順列をつくる
         LET w(j)=w(j)-1
         !!!MAT PRINT w; !debug
         LET v=v+PermFactorialM(w,M) !その順列の番号を求める
         LET w(j)=w(j)+1
      END IF
   NEXT j
   LET w(t)=w(t)-1 !左端を消して、次へ
NEXT i
LET PermFactorialM2Num=v
END FUNCTION

EXTERNAL SUB Num2PermFactorialM(h, A(),N,B(),M) !番号から順列パターンを生成する ※辞書式順序
DIM w(M)
MAT w=B !copy it
LET v=h
FOR i=1 TO N
   FOR j=1 TO M !左端を1~Mとして
      IF w(j)>0 THEN !その左端を除いた残りで最大の順列をつくる
         LET w(j)=w(j)-1
         !!!MAT PRINT w;
         LET t=PermFactorialM(w,M) !その順列の番号を求める
         IF v<t THEN EXIT FOR
         LET v=v-t
         LET w(j)=w(j)+1
      END IF
   NEXT j
   LET A(i)=j !次へ
NEXT i
END SUB


!●異なるn個のものから重複を許してr個を取り出して並べる(重複順列)

!N^R通りの順列パターン ⇔ 0 ~ N^R-1 の番号

EXTERNAL FUNCTION ReptPerm2Num(A(),N,R) !順列パターンに番号を付ける ※辞書式順序
LET v=A(1)-1
FOR i=2 TO R !N進法R桁の数を10進法へ
   LET v=v*N+A(i)-1
NEXT i
LET ReptPerm2Num=v
END FUNCTION

EXTERNAL SUB Num2ReptPerm(h, A(),N,R) !番号から順列パターンを生成する ※辞書式順序
LET v=h
LET i=R !桁位置
DO UNTIL v=0 !10進法の数をN進法R桁へ
   LET t=INT(v/N)
   LET A(i)=v-t*N+1 !1~N ※剰余
   LET v=t
   LET i=i-1
LOOP
FOR k=i TO 1 STEP -1 !残りの桁を埋める
   LET A(k)=1
NEXT k
END SUB


EXTERNAL SUB PrevReptPerm(A(),N,R, rc) !辞書式順序で前の順列を返す
LET rc=0 !完了
FOR i=R TO 1 STEP -1 !N進法R桁の数として
   IF A(i)>1 THEN !1~Nで更新する
      LET A(i)=A(i)-1
      FOR j=i+1 TO R !A(i)=A(i+1)= … =A(R) 最後の並び
         LET A(j)=N
      NEXT j
      LET rc=1 !未了
      EXIT SUB
   END IF
NEXT i
END SUB

EXTERNAL SUB NextReptPerm(A(),N,R, rc) !辞書式順序で次の順列を返す
LET rc=0 !完了
FOR i=R TO 1 STEP -1 !N進法R桁の数として
   IF A(i)<N THEN !1~Nで更新する
      LET A(i)=A(i)+1
      FOR j=i+1 TO R !A(i)=A(i+1)= … =A(R) 最初の並び
         LET A(j)=1
      NEXT j
      LET rc=1 !未了
      EXIT SUB
   END IF
NEXT i
END SUB



!最小完全ハッシュ関数 combinadic

!●異なるn個のものから重複を許さずr個を取り出す組合せ

!comb(n,r)通りの組合せパターン ⇔ 0 ~ comb(n,r)-1 の番号

EXTERNAL FUNCTION Comb2Num(A(),N,R) !組合せパターンに番号を付ける ※辞書式順序
LET v=COMB(N,R)-1
FOR j=1 TO R !組合せをビット位置とする
   LET t=N-A(j)
   LET v=v-COMB(t,R-j+1)
NEXT j
LET Comb2Num=v
END FUNCTION

EXTERNAL SUB Num2Comb(h, A(),N,R) !番号から組合せパターンを生成する ※辞書式順序
LET v=COMB(N,R)-h
FOR j=R TO 1 STEP-1 !組合せをビット位置とする
   FOR i=N-1 TO 0 STEP -1 !組合せをビット位置とする
      LET t=COMB(i,j)
      IF v>t THEN EXIT FOR
   NEXT i
   LET v=v-t
   LET A(R-j+1)=N-i !ビット位置(N-i-1)を1とする
NEXT j
END SUB


EXTERNAL FUNCTION Comb2Num2(A(),N,R) !組合せパターンに番号を付ける ※辞書式順序ではない
LET v=0
FOR j=1 TO R !組合せをビット位置とする
   LET t=A(j)-1
   LET v=v+COMB(t,j)
NEXT j
LET Comb2Num2=v
END FUNCTION

EXTERNAL SUB Num2Comb2(h, A(),N,R) !番号から組合せパターンを生成する ※辞書式順序ではない
LET v=h
LET j=R
FOR i=N-1 TO 0 STEP -1 !組合せをビット位置とする
   LET t=COMB(i,j)
   IF t<=v THEN
      LET A(j)=i+1 !ビット位置iを1とする
      LET j=j-1
      LET v=v-t
   END IF
NEXT i
END SUB

EXTERNAL SUB PrevComb(A(),N,R, rc) !辞書式順序で前の組合せを返す
LET rc=0 !完了
FOR i=R TO 2 STEP -1 !並びの差が2以上の位置を探す
   IF A(i)-A(i-1)>1 THEN EXIT FOR
NEXT i
IF i>1 OR (i=1 AND A(1)>1) THEN
   LET A(i)=A(i)-1
   FOR j=i+1 TO R !A(2)=N-R+2< … A(R-1)=N-1<A(R)=N 最後の並び
      LET A(j)=N-R+j
   NEXT j
   LET rc=1 !未了
END IF
END SUB

EXTERNAL SUB NextComb(A(),N,R, rc) !辞書式順序で次の組合せを返す
LET rc=0 !完了
FOR i=R TO 1 STEP -1
   IF A(i)<N-R+i THEN !i~N-R+iで更新する
      LET A(i)=A(i)+1
      FOR j=i+1 TO R !A(i)<A(i+1)< … <A(R) 最初の並び
         LET A(j)=A(j-1)+1
      NEXT j
      LET rc=1 !未了
      EXIT SUB
   END IF
NEXT i
END SUB


!●異なるn個のものから重複を許してr個を取り出す組合せ(重複組合せ)

!comb(n+r-1,r)通りの組合せパターン ⇔ 0 ~ comb(n+r-1,r)-1 の番号

!※Homogeneous Product、nHr=comb(n+r-1,r)=comb(n+r-1,n-1)

EXTERNAL FUNCTION ReptComb2Num(A(),N,R) !組合せパターンに番号を付ける ※辞書式順序
LET v=COMB(N+R-1,R)-1
FOR j=R-1 TO 0 STEP -1
   LET t=N-A(R-j) !0~N-1
   LET v=v-COMB(t+j,j+1) !tHj+1
NEXT j
LET ReptComb2Num=v
!!!別解
!!!FOR j=1 TO R
!!!   LET t=N-A(j) !0~N-1
!!!   LET v=v-COMB(t+R-j,R-j+1) !tHr-j+1
!!!NEXT j
!!!LET ReptComb2Num=v
END FUNCTION

EXTERNAL SUB Num2ReptComb(h, A(),N,R) !番号から組合せパターンを生成する ※辞書式順序
LET v=COMB(N+R-1,R)-h
FOR j=R TO 1 STEP-1 !組合せをビット位置とする
   FOR i=N-1 TO 0 STEP -1 !組合せをビット位置とする
      LET t=COMB(i+j-1,j)
      IF v>t THEN EXIT FOR
   NEXT i
   LET v=v-t
   LET A(R-j+1)=N-i !ビット位置(N-i-1)を1とする
NEXT j
END SUB


EXTERNAL SUB PrevReptComb(A(),N,R, rc) !辞書式順序で前の組合せを返す
LET rc=0 !完了
FOR i=R TO 2 STEP -1 !並びの差が1以上の位置を探す
   IF A(i)-A(i-1)>0 THEN EXIT FOR
NEXT i
IF i>1 OR (i=1 AND A(1)>1) THEN
   LET A(i)=A(i)-1
   FOR j=i+1 TO R !A(i+1)= … A(R-1)=A(R)=N 最後の並び
      LET A(j)=N
   NEXT j
   LET rc=1 !未了
END IF
END SUB

EXTERNAL SUB NextReptComb(A(),N,R, rc) !辞書式順序で次の組合せを返す
LET rc=0 !完了
FOR i=R TO 1 STEP -1
   IF A(i)<N THEN !i~Nで更新する
      LET A(i)=A(i)+1
      FOR j=i+1 TO R !A(i)=A(i+1)= … =A(R) 最初の並び
         LET A(j)=A(j-1)
      NEXT j
      LET rc=1 !未了
      EXIT SUB
   END IF
NEXT i
END SUB
 

Re: 昔のbasicの移植

 投稿者:山中和義  投稿日:2010年 3月13日(土)14時22分2秒
  > No.1076[元記事へ]

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

> オペレーションズ・リサーチ(OR,Operations Research)の関連

最急降下法(method of steepest decent)のサンプル

●黄金分割法によるステップ幅の決定
DEF f(x1,x2)=2*x1^2-x1*x2+x2^2-2*x1-3*x2 !非線形関数の最小値
DEF df1(x1,x2)=4*x1-x2-2 !∂f/∂x1
DEF df2(x1,x2)=-x1+2*x2-3 !∂f/∂x2

LET x1=0 !初期値(x1,x2)=(0,0)
LET x2=0

LET cEPS=1E-6 !精度

LET iter=300 !繰り返し回数
FOR i=1 TO iter
   PRINT "x1=";x1, "x2=";x2, "f=";f(x1,x2)

   LET dx1=-df1(x1,x2) !勾配(gradient)
   LET dx2=-df2(x1,x2)
   LET norm2=dx1*dx1+dx2*dx2
   IF norm2<cEPS*cEPS THEN EXIT FOR !勾配が0なら、終了!

   !!!LET alpha=0.1 !ステップ幅(微小な定数による)
   LET alpha=GoldenSelection(x1,x2,dx1,dx2) !直線探索でステップ幅を計算する
   PRINT "α=";alpha !debug

   LET x1=x1+alpha*dx1 !近似解
   LET x2=x2+alpha*dx2
NEXT i

PRINT "繰り返し回数=";i


!1変数関数の最小化
! 目的関数Φk(α)=f(x[k]+α*d[k])を最小にするα∈[0,1]をみつける

FUNCTION GoldenSelection(x1,x2,dx1,dx2) !黄金分割法 GoldenSelection(x,d)
   LET t=(SQR(5)-1)/2 !1/τ、τはτ^2-τ-1=0の解
   LET a=0 !α∈[0,1]
   LET b=1
   LET w=b-a
   LET p=b-t*w !a<p<q< b
   LET q=a+t*w
   LET fxp=f(x1+p*dx1,x2+p*dx2)
   LET fxq=f(x1+q*dx1,x2+q*dx2)
   DO UNTIL w<cEPS !区間が十分小さくなれば終了
      IF fxp>=fxq THEN !区間を[p,b]に縮小する
         LET a=p
         LET w=b-a
         LET p=q
         LET fxp=fxq
         LET q=a+t*w
         LET fxq=f(x1+q*dx1,x2+q*dx2)
      ELSE ![a,q]
         LET b=q
         LET w=b-a
         LET q=p
         LET fxq=fxp
         LET p=b-t*w
         LET fxp=f(x1+p*dx1,x2+p*dx2)
      END IF
   LOOP
   LET GoldenSelection=(a+b)/2 !αの求解
END FUNCTION

END

●Armijoの基準
DEF f(x1,x2)=2*x1^2-x1*x2+x2^2-2*x1-3*x2 !非線形関数の最小値
DEF df1(x1,x2)=4*x1-x2-2 !∂f/∂x1
DEF df2(x1,x2)=-x1+2*x2-3 !∂f/∂x2

LET x1=0 !初期値(x1,x2)=(0,0)
LET x2=0

LET cEPS=1E-6 !精度

LET iter=300 !繰り返し回数
FOR i=1 TO iter
   PRINT "x1=";x1, "x2=";x2, "f=";f(x1,x2)

   LET dx1=-df1(x1,x2) !勾配(gradient)
   LET dx2=-df2(x1,x2)
   LET norm2=dx1*dx1+dx2*dx2
   IF norm2<cEPS*cEPS THEN EXIT FOR !勾配が0なら、終了!

   LET fx=f(x1,x2) !Armijoの基準でステップ幅を計算する
   FOR m=0 TO 10
      LET alpha=1/2^m
      IF f(x1+alpha*dx1,x2+alpha*dx2)<=fx-0.5*alpha*norm2 THEN EXIT FOR
   NEXT m
   PRINT m;alpha !debug

   LET x1=x1+alpha*dx1 !近似解
   LET x2=x2+alpha*dx2
NEXT i

PRINT "繰り返し回数=";i

END
 

Re: (無題)

 投稿者:N.E.  投稿日:2010年 3月13日(土)15時59分57秒
  > No.1086[元記事へ]

白石 和夫さんへのお返事です。
> 内部形式ファイルを使うところです。
> > http://www.geocities.jp/thinking_math_education/BASICHelp/html/basi6pgl.htm
内部形式ファイルの使い方は分かりましたが、異なるプログラムで書きこみ、読みこみを共通のファイルにしたいのですが、出来ますか?
 

Re: (無題)

 投稿者:白石 和夫  投稿日:2010年 3月13日(土)18時26分28秒
  > No.1091[元記事へ]

N.E.さんへのお返事です。
BASIC.EXEを2重起動して,一方で書き込みながら他方で読み込むことができるかどうかはやってみないとわかりませんが,同時に開くのでないならば,異なるプログラムで読み書きするのは,当然の使い方だと思います。
 

Re: (無題)

 投稿者:白石 和夫  投稿日:2010年 3月13日(土)18時31分25秒
  > No.1091[元記事へ]

> > > http://www.geocities.jp/thinking_math_education/BASICHelp/html/basi6pgl.htm
例2のプログラムが間違っていました。プログラムが終了すると自動的に閉じられるのと,読み込みのみに用いている二点から実害はまったくありませんが,CLOSE文は書いておくべきでした。
 

Re: (無題)

 投稿者:N.E.  投稿日:2010年 3月14日(日)15時06分54秒
  > No.1092[元記事へ]

白石 和夫さんへのお返事です。

> BASIC.EXEを2重起動して,一方で書き込みながら他方で読み込むことができるかどうかはやってみないとわかりませんが,同時に開くのでないならば,異なるプログラムで読み書きするのは,当然の使い方だと思います。

方法を教えて下さい。よろしくお願いします。
 

モンジュシャッフルの復元回数

 投稿者:GAI  投稿日:2010年 3月14日(日)15時26分6秒
  モンジュシャッフルの復元回数について知りたいのでお願いします。

左手にn枚のカードを持つ。
上から一枚ずつ右手に渡す。
ただし2枚目は右手のカードのトップにのせる。
3枚目は右手カードのボトムに入れる。
4枚目は右手カードのトップにのせる。
という風に、上、下と交互に左手から右手へと順序を入れ替えながら左手のカードが無くなるまで続ける。(この操作を1回とする。)
終わったら再び左手にカードを渡して、これを繰り返す。

この操作を何回繰り返したとき、再び最初の配列が並ぶのが何回目で達成できるのか知りたいのですが、よろしくお願いします。

n:1~52(枚)
の各データが知りたい。
 

Re: (無題)

 投稿者:白石 和夫  投稿日:2010年 3月14日(日)16時28分24秒
  > No.1094[元記事へ]

> 方法を教えて下さい。よろしくお願いします。

http://www.geocities.jp/thinking_math_education/BASICHelp/html/basi6pgl.htm
の例1と例2がすでにその例になっています。
また,
(仮称)十進BASICによるJIS Full BASIC入門 5.3ァイル
http://www.geocities.jp/thinking_math_education/tutorial/section5.htm#5.3
にも内部形式での書き込みと読み込みの例があります。
「異なるプログラム」の意味が「異なるアプリケーション」の意味である場合は,
十進BASICで読めるCSVの形式に注意してください。特に,
数値は引用符なし,空文字列は必ず""で表す。
 

Re: 昔のbasicの移植

 投稿者:山中和義  投稿日:2010年 3月14日(日)20時10分54秒
  > No.1090[元記事へ]

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

> オペレーションズ・リサーチ(OR,Operations Research)の関連

スケジューリング
 順序付け問題
  ガントチャート(Gantt chart)
!ジョンソン法 - 順序付け問題

!先に機械M1、次に機械M2を使って生産する製品A,B,C,…の工程順番を決める

LET N=5 !製品の数

DIM T(2,N) !加工時間
!    A,B,C,D,E
DATA 3,5,1,6,7 !M1
DATA 6,2,2,6,5 !M2
MAT READ T

DIM W(2,N)
MAT W=T !copy it

LET cMAX=9999

DIM A(N) !工程の順番
LET Top=1
LET Btm=N
FOR k=1 TO N

   LET s=cMAX !最小のものを探す
   FOR i=1 TO 2
      FOR j=1 TO N
         IF W(i,j)< s THEN
            LET s=W(i,j)
            LET y=i
            LET x=j
         END IF
      NEXT j
   NEXT i
   !!!PRINT y;x;s !debug

   IF y=1 THEN !M1側なら
      LET A(Top)=x !最初へ
      LET Top=Top+1
   ELSE
      LET A(Btm)=x !最後へ
      LET Btm=Btm-1
   END IF

   LET W(1,x)=cMAX !削除して、次へ
   LET W(2,x)=cMAX
   !!!MAT PRINT W; !debug

NEXT k
MAT PRINT A; !debug


DIM M1(N),M2(N) !工程の終了時間
LET s1=0
LET s2=0
FOR i=1 TO N
   LET s1=s1+T(1,A(i)) !つめる
   LET M1(i)=s1

   IF s1>s2 THEN !M1が終了しているかどうかを確認する
      LET s2=s1+T(2,A(i)) !M1の終了を待つ
   ELSE
      LET s2=s2+T(2,A(i)) !つめる
   END IF
   LET M2(i)=s2
NEXT i
MAT PRINT M1;
MAT PRINT M2;

PRINT "最小時間=";MAX(M1(N),M2(N))


!ガントチャートを描く

SET bitmap SIZE 25*20,11*20 !作画領域
SET WINDOW -1,25,-1,11
DRAW grid
SET TEXT JUSTIFY "center","half"
FOR i=1 TO N
   LET u=A(i) !工程

   LET v=T(1,A(i)) !M1側
   LET x2=M1(i)
   LET x1=x2-v
   CALL box(x1,x2,6,8,u,v)

   LET v=T(2,A(i)) !M2側
   LET x2=M2(i)
   LET x1=x2-v
   CALL box(x1,x2,2,4,u,v)
NEXT i
SUB box(x1,x2,y1,y2,u,v) !チャートを描く
   PLOT LINES: x1,y1; x2,y1; x2,y2; x1,y2; x1,y1 !長方形
   PLOT TEXT ,AT (x1+x2)/2,(y1+y2)/2: mid$("ABCDE",u,1)&"("&STR$(v)&")" !工程と時間
END SUB

END
 

Re: モンジュシャッフルの復元回数

 投稿者:山中和義  投稿日:2010年 3月15日(月)13時31分35秒
  > No.1095[元記事へ]

GAIさんへのお返事です。

> モンジュシャッフルの復元回数について知りたいのでお願いします。

10枚のカードの場合、このシャッフルを置換で表すと
┌  1  2  3  4  5  6  7  8  9 10 ┐
└  6  5  7  4  8  3  9  2 10  1 ┘

これを巡回置換の積で表すと
P=( 1  6  3  7  9  10 )( 2  5  8 )( 4 )

長さは、6,3,1なので、その最小公倍数6が求める解である。

実際のカードの並びは、置換の積で求まる。
 E*P*P* … ※Eは、恒等置換
0 回目
 1  2  3  4  5  6  7  8  9  10

 1 回目
 6  5  7  4  8  3  9  2  10  1

 2 回目
 3  8  9  4  2  7  10  5  1  6

 3 回目
 7  2  10  4  5  9  1  8  6  3

 4 回目
 9  5  1  4  8  10  6  2  3  7

 5 回目
 10  8  6  4  2  1  3  5  7  9

 6 回目
 1  2  3  4  5  6  7  8  9  10

●サンプル・プログラム
!「シャッフル」のシミュレーション

LET N=10 !カードの枚数

DIM shuffle(N) !シャッフルに相当する置換
FOR i=1 TO N
   LET shuffle(i)=INT((N-i*(-1)^i-MOD(N,2))/2)+1
   !LET shuffle(i)=MOD(2*i,N+1) !in shuffle ※Nは2の倍数
   !IF i=N THEN LET shuffle(i)=N ELSE LET shuffle(i)=MOD(2*(i-1),N-1)+1 !out shuffle(1,Nは不変) ※Nは2の倍数
NEXT i
CALL PermPrintOut(shuffle)
CALL PermCyclicPrintOut(shuffle)
!!!STOP


DIM C(N) !カードの束
CALL PermIdentity(C) !カードを整列させる
PRINT "0 回目"
MAT PRINT C;


DIM T(N)
LET cMax=500 !最大回数 ※調整が必要
FOR x=1 TO cMax

   CALL PermMultiply(C,shuffle, C) !シャッフル
   PRINT x;"回目"
   MAT PRINT C;

   IF PermIsIdentity(C)<>0 THEN EXIT FOR !元に戻ったら、終了!

NEXT x
IF x>cMax THEN PRINT cMax;"回では元に戻りません。"


END


EXTERNAL SUB PermIdentity(A()) !恒等置換
FOR i=1 TO UBOUND(A)
   LET A(i)=i
NEXT i
END SUB

EXTERNAL FUNCTION PermIsIdentity(A()) !恒等置換か確認する
LET PermIsIdentity=0 !false
FOR i=1 TO UBOUND(A)
   IF A(i)<>i THEN EXIT FUNCTION
NEXT i
LET PermIsIdentity=-1 !true
END FUNCTION

EXTERNAL SUB PermMultiply(A(),B(), AB()) !積AB
DIM T(UBOUND(A))
FOR i=1 TO UBOUND(A)
   LET T(i)=A(B(i)) !※合成写像(AB)(i)=A(B(i))
NEXT i
MAT AB=T
END SUB


!補助ルーチン

EXTERNAL SUB PermPrintOut(A()) !表示する ※標準形(2行n列の行列表記する)
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 " ┘"
END SUB

EXTERNAL SUB PermCyclicPrintOut(A()) !巡回置換の積で表示する ※(,,…,)(,,…,)…(,,…,)
DIM T(UBOUND(A)) !作業用
CALL PermIdentity(T)

FOR i=1 TO UBOUND(A)
   IF T(i)>0 THEN !含まれないなら
      LET L=0 !長さ
      PRINT "(";

      LET k=i !最初の値
      DO !リストを作成する ※(4 4)などの長さ1の置換も含む
         PRINT k;
         LET L=L+1

         LET T(k)=-1 !巡回に含まれる

         LET k=A(k) !次をトレースする
      LOOP UNTIL k=i !一巡するまで

      PRINT ")"; !次の組へ
      PRINT " 長さ=";L
   END IF
NEXT i
PRINT
END SUB
 

Re: (無題)

 投稿者:N.E.  投稿日:2010年 3月15日(月)20時25分2秒
  > No.1096[元記事へ]

白石 和夫さんへのお返事です。

> > 方法を教えて下さい。よろしくお願いします。
>
> http://www.geocities.jp/thinking_math_education/BASICHelp/html/basi6pgl.htm
> の例1と例2がすでにその例になっています。
> また,
> (仮称)十進BASICによるJIS Full BASIC入門 5.3ァイル
> http://www.geocities.jp/thinking_math_education/tutorial/section5.htm#5.3
> にも内部形式での書き込みと読み込みの例があります。
> 「異なるプログラム」の意味が「異なるアプリケーション」の意味である場合は,
> 十進BASICで読めるCSVの形式に注意してください。特に,
> 数値は引用符なし,空文字列は必ず""で表す。
「異なるプログラム」の意味は「異なるアプリケーション」の意味ではありません。
分かりました。ありがとうございました。
内部形式ファイルのことをよく分かっていませんでした。ごめんなさい。
 

(無題)

 投稿者:N.E.  投稿日:2010年 3月21日(日)15時33分59秒
  十進BASICのソースコードを公開してくれませんか?
どのように高速で精度の高い計算をしているのかが気になります。
c言語では、十進BASICほど精度が高くありません。
使用している言語名、製品名も教えて下さい。
 

Re: (無題)

 投稿者:白石 和夫  投稿日:2010年 3月21日(日)18時40分5秒
  > No.1100[元記事へ]

Decimal BASIC Open Source Project
http://sourceforge.jp/projects/decimalbasic/releases/?package_id=8178
から,BASIC054JaSRC.zipをダウンロードしてください。
Lazarusをインストールすれば,Windows上でもコンパイルして実行できます。
 

Re: (無題)

 投稿者:N.E.  投稿日:2010年 3月22日(月)11時06分2秒
  > No.1101[元記事へ]

白石 和夫さんへのお返事です。

> Decimal BASIC Open Source Project
> http://sourceforge.jp/projects/decimalbasic/releases/?package_id=8178
> から,BASIC054JaSRC.zipをダウンロードしてください。
> Lazarusをインストールすれば,Windows上でもコンパイルして実行できます。

Lazarusはどこのサイトから手に入れるのですか。
(日本語のものがありません)
教えて下さい。
Lazarusは何けたもある計算を、高速で実行出来るのですか。
 

Re: (無題)

 投稿者:N.E.  投稿日:2010年 3月22日(月)14時23分36秒
  > No.1101[元記事へ]

白石 和夫さんへのお返事です。
> Decimal BASIC Open Source Project
> http://sourceforge.jp/projects/decimalbasic/releases/?package_id=8178
> から,BASIC054JaSRC.zipをダウンロードしてください。
> Lazarusをインストールすれば,Windows上でもコンパイルして実行できます。

No.1102への補足

http://hp.vector.co.jp/authors/VA008683/basi0000.htmでは、
Windows 7.3.5は開発言語が「Delphi」となっていたので、補足します。
OS名:windows XP (SP2)
十進BASICのversion:7.3.3
 

Re: (無題)

 投稿者:白石 和夫  投稿日:2010年 3月22日(月)18時38分55秒
  > No.1102[元記事へ]

ソースを読むだけであれば,Lazarusは不要ですが,
Lazarusは,
http://snapshots.lazarus.shikami.org/
にあります。Windowsで使うのであれば,
win32 Lazarus + fpc 2.4.0 版を入手してください。

Windows向きのソースを読むのが目的であれば,
http://sourceforge.jp/projects/decimalbasic/releases/?package_id=8178
から,BASIC0300Src.zipを入手してください。
Ver.0.4とVer.0.5はMAC CarbonおよびLinux GTK2に対応させるための変更を含みます。
(FPUエラーの扱いが異なります)

Full BASIC規格に沿う数値計算は,数値式は1000000000を基底として計算し,
10進換算で19桁~27桁の有効数字を持つようにします。
そして,数値変数に代入するときに,四捨五入を実行して15桁の精度に劣化させます。
無理関数は一度Intel拡張精度実数に変換して計算し,その結果を17桁の十進数に丸めます。
その丸め方は17桁めが最も近い偶数にする丸めです。
無理関数で発生する例外は,Windows版(Ver.4.5以降)とVer.0.2,Ver.0.3ではOSの例外処理を利用し,
Ver.0.4とVer.0.5では計算のたびごとにFPUのステータスレジスタを読んで調べています。
 

Re: (無題)

 投稿者:N.E.  投稿日:2010年 3月23日(火)20時14分38秒
  > No.1104[元記事へ]

白石 和夫さんへのお返事です。

ありがとうございました。試してみます。
 

これが繋がるのが不思議です。

 投稿者:GAI  投稿日:2010年 3月23日(火)20時36分29秒
  option base 0

DIM f(1000)
DIM g(1000)

LET f(0)=0
LET f(1)=6
INPUT n
FOR i=1 TO n
   LET f(i+1)=(34*i^3+51*i^2+27*i+5)/(i+1)^3*f(i)-i^3/(i+1)^3*f(i-1)
NEXT i
PRINT "f(n)=";f(n)

LET g(0)=1
LET g(1)=5
FOR i=1 TO n
   LET g(i+1)=(34*i^3+51*i^2+27*i+5)/(i+1)^3*g(i)-i^3/(i+1)^3*g(i-1)
NEXT i
PRINT "g(n)=";g(n)

PRINT "f(n)/g(n)=";f(n)/g(n)
PRINT "比較:ζ(3)=1+1/2^3+1/3^3+1/4^3+・・・・・"
PRINT "          =1.2020569031595942853997381615114499907649・・・・・"

END


1000桁モードで見て下さい。
 

回帰式

 投稿者:しばっち  投稿日:2010年 3月27日(土)21時13分39秒
  !'最小2乗法により回帰式を求める。
LET  N = 15 !'データ数
RANDOMIZE
DIM X(N), Y(N)
LET  A = RND !'乱数で係数を決める
LET  B = RND
LET MODE=INT(RND*8)+1
FOR I =1 TO N
   LET X(I)=I
   SELECT CASE MODE !'仮データ作成
   CASE 1
      LET Y(I)=A+B*X(I)
   CASE 2
      LET Y(I)=EXP(A*X(I))*B
   CASE 3
      LET Y(I)=A*X(I)^B
   CASE 4
      LET Y(I)=A*LOG(X(I))+B
   CASE 5
      LET Y(I)=A*B^X(I)
   CASE 6
      LET Y(I)=A*SQR(X(I))+B
   CASE 7
      LET Y(I)=A/X(I)+B
   CASE 8
      LET Y(I)=A*X(I)^(1/3)+B
   END SELECT
NEXT I
FOR I=1 TO N
   PRINT "X=";X(I);"Y=";Y(I);"^Y=";
   SELECT CASE MODE
   CASE 1
      PRINT FORECAST(X(I),N,Y,X)
   CASE 2
      PRINT FORECAST2(X(I),N,Y,X)
   CASE 3
      PRINT FORECAST3(X(I),N,Y,X)
   CASE 4
      PRINT FORECAST4(X(I),N,Y,X)
   CASE 5
      PRINT FORECAST5(X(I),N,Y,X)
   CASE 6
      PRINT FORECAST6(X(I),N,Y,X)
   CASE 7
      PRINT FORECAST7(X(I),N,Y,X)
   CASE 8
      PRINT FORECAST8(X(I),N,Y,X)
   END SELECT
NEXT I
!'PRINT "R2=";R2(N,Y,X)
END

EXTERNAL  FUNCTION R2(N,YA(),XA()) !'決定係数(寄与率) 0<=r^2<=1
LET  YN=MEAN(N,YA)
FOR I=1 TO N
   LET  YY=FORECAST(XA(I),N,YA,XA)
   !' LET  YY=FORECAST2(XA(I),N,YA,XA)
   !' LET  YY=FORECAST3(XA(I),N,YA,XA)
   !' LET  YY=FORECAST4(XA(I),N,YA,XA)
   !' LET  YY=FORECAST5(XA(I),N,YA,XA)
   !' LET  YY=FORECAST6(XA(I),N,YA,XA)
   !' LET  YY=FORECAST7(XA(I),N,YA,XA)
   !' LET  YY=FORECAST8(XA(I),N,YA,XA)
   LET  SY=SY+(YA(I)-YN)^2
   LET  SE=SE+(YA(I)-YY)^2
NEXT I
LET  R2=1-SE/SY
END FUNCTION

EXTERNAL  FUNCTION MEAN(N,X()) !'平均
FOR I=1 TO N
   LET  S=S+X(I)
NEXT I
LET  MEAN=S/N
END FUNCTION

EXTERNAL  FUNCTION SLOPEA(N,YA(),XA())
LET  XN=MEAN(N,XA)
LET  YN=MEAN(N,YA)
FOR I=1 TO N
   LET  X=X+(XA(I)-XN)^2
   LET  XY=XY+(XA(I)-XN)*(YA(I)-YN)
NEXT I
LET  SLOPEA=XY/X
END FUNCTION

EXTERNAL  FUNCTION INTERCEPTA(N, YA(), XA())
LET  B = SLOPEA(N, YA, XA)
FOR I = 1 TO N
   LET  A = A + YA(I) - B * XA(I)
NEXT I
LET  INTERCEPTA = A / N
END FUNCTION

EXTERNAL  FUNCTION FORECASTA(X, N, YA(), XA())
!'Y=B+A*X
LET  A = SLOPEA(N, YA, XA)
LET  B = INTERCEPTA(N, YA, XA)
LET  FORECASTA = B + A * X
END FUNCTION

EXTERNAL  FUNCTION SLOPE(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + XA(I) * YA(I)
   LET   X = X + XA(I)
   LET   Y = Y + YA(I)
   LET  XX = XX + XA(I) * XA(I)
NEXT I
LET  SLOPE = (N * XY - X * Y) / (N * XX - X * X)
END FUNCTION

EXTERNAL  FUNCTION INTERCEPT(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + XA(I) * YA(I)
   LET   X = X + XA(I)
   LET   Y = Y + YA(I)
   LET  XX = XX + XA(I) * XA(I)
NEXT I
LET  INTERCEPT = (Y * XX - XY * X) / (N * XX - X * X)
END FUNCTION

EXTERNAL  FUNCTION FORECAST(X, N, YA(), XA())
!'Y=B+A*X
LET  A = SLOPE(N, YA, XA)
LET  B = INTERCEPT(N, YA, XA)
LET  FORECAST = B + A * X
END FUNCTION

EXTERNAL  FUNCTION SLOPE2(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + XA(I) * LOG(YA(I))
   LET   X = X + XA(I)
   LET   Y = Y + LOG(YA(I))
   LET  XX = XX + XA(I) * XA(I)
NEXT I
LET  SLOPE2 = (N * XY - X * Y) / (N * XX - X * X)
END FUNCTION

EXTERNAL  FUNCTION INTERCEPT2(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + XA(I) * LOG(YA(I))
   LET   X = X + XA(I)
   LET   Y = Y + LOG(YA(I))
   LET  XX = XX + XA(I) * XA(I)
NEXT I
LET  INTERCEPT2 = EXP((Y * XX - XY * X) / (N * XX - X * X))
END FUNCTION

EXTERNAL  FUNCTION FORECAST2(X, N, YA(), XA())
!'y=b*EXP(a*x)
!'LOG(y)=LOG(b)+a*x
!'Y=LOG(y) B=LOG(b) A=a X=x
!'Y=B+A*X
!'b=EXP(B)
LET  A = SLOPE2(N, YA, XA)
LET  B = INTERCEPT2(N, YA, XA)
LET  FORECAST2 = B * EXP(A * X)
END FUNCTION

EXTERNAL  FUNCTION SLOPE3(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + LOG(XA(I)) * LOG(YA(I))
   LET   X = X + LOG(XA(I))
   LET   Y = Y + LOG(YA(I))
   LET  XX = XX + LOG(XA(I)) * LOG(XA(I))
NEXT I
LET  SLOPE3 = (N * XY - X * Y) / (N * XX - X * X)
END FUNCTION

EXTERNAL  FUNCTION INTERCEPT3(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + LOG(XA(I)) * LOG(YA(I))
   LET   X = X + LOG(XA(I))
   LET   Y = Y + LOG(YA(I))
   LET  XX = XX + LOG(XA(I)) * LOG(XA(I))
NEXT I
LET  INTERCEPT3 = EXP((Y * XX - XY * X) / (N * XX - X * X))
END FUNCTION

EXTERNAL  FUNCTION FORECAST3(X, N, YA(), XA())
!'y=a*x^b
!'LOG(y)=LOG(a)+b*LOG(x)
!'Y=LOG(y) A=b B=LOG(a) X=LOG(x)
!'Y=B+A*X
!'a=EXP(B)
LET  B = SLOPE3(N, YA, XA)
LET  A = INTERCEPT3(N, YA, XA)
LET  FORECAST3 = A * X ^ B
END FUNCTION

EXTERNAL  FUNCTION SLOPE4(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + LOG(XA(I)) * YA(I)
   LET   X = X + LOG(XA(I))
   LET   Y = Y + YA(I)
   LET  XX = XX + LOG(XA(I)) * LOG(XA(I))
NEXT I
LET  SLOPE4 = (N * XY - X * Y) / (N * XX - X * X)
END FUNCTION

EXTERNAL  FUNCTION INTERCEPT4(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + LOG(XA(I)) * YA(I)
   LET   X = X + LOG(XA(I))
   LET   Y = Y + YA(I)
   LET  XX = XX + LOG(XA(I)) * LOG(XA(I))
NEXT I
LET  INTERCEPT4 = (Y * XX - XY * X) / (N * XX - X * X)
END FUNCTION

EXTERNAL  FUNCTION FORECAST4(X, N, YA(), XA())
!'y=b+a*LOG(x)
!'Y=y A=a X=LOG(x) B=b
!'Y=B+A*X
LET  A = SLOPE4(N, YA, XA)
LET  B = INTERCEPT4(N, YA, XA)
LET  FORECAST4 = A * LOG(X) + B
END FUNCTION

EXTERNAL  FUNCTION SLOPE5(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + XA(I) * LOG(YA(I))
   LET   X = X + XA(I)
   LET   Y = Y + LOG(YA(I))
   LET  XX = XX + XA(I) * XA(I)
NEXT I
LET  SLOPE5 = EXP((N * XY - X * Y) / (N * XX - X * X))
END FUNCTION

EXTERNAL  FUNCTION INTERCEPT5(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + XA(I) * LOG(YA(I))
   LET   X = X + XA(I)
   LET   Y = Y + LOG(YA(I))
   LET  XX = XX + XA(I) * XA(I)
NEXT I
LET  INTERCEPT5 = EXP((Y * XX - XY * X) / (N * XX - X * X))
END FUNCTION

EXTERNAL  FUNCTION FORECAST5(X, N, YA(), XA())
!'y=a*b^x
!'LOG(y)=LOG(a)+LOG(b)*x
!'Y=LOG(y) B=LOG(a) X=x A=LOG(b)
!'Y=B+A*X
!'a=EXP(B) b=EXP(A)
LET  B = SLOPE5(N, YA, XA)
LET  A = INTERCEPT5(N, YA, XA)
LET  FORECAST5 = A * B ^ X
END FUNCTION
 

Re: 回帰式

 投稿者:しばっち  投稿日:2010年 3月27日(土)21時14分27秒
  > No.1111[元記事へ]

続き

EXTERNAL  FUNCTION SLOPE6(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + SQR(XA(I)) * YA(I)
   LET   X = X + SQR(XA(I))
   LET   Y = Y + YA(I)
   LET  XX = XX + SQR(XA(I)) * SQR(XA(I))
NEXT I
LET  SLOPE6 = (N * XY - X * Y) / (N * XX - X * X)
END FUNCTION

EXTERNAL  FUNCTION INTERCEPT6(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + SQR(XA(I)) * YA(I)
   LET   X = X + SQR(XA(I))
   LET   Y = Y + YA(I)
   LET  XX = XX + SQR(XA(I)) * SQR(XA(I))
NEXT I
LET  INTERCEPT6 = (Y * XX - XY * X) / (N * XX - X * X)
END FUNCTION

EXTERNAL  FUNCTION FORECAST6(X, N, YA(), XA())
!'y=a*SQR(x)+b
!'X=SQR(x)
!'Y=B+A*X
LET  A = SLOPE6(N, YA, XA)
LET  B = INTERCEPT6(N, YA, XA)
LET  FORECAST6 = B + A * SQR(X)
END FUNCTION

EXTERNAL  FUNCTION SLOPE7(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + 1 / XA(I) * YA(I)
   LET   X = X + 1 / XA(I)
   LET   Y = Y + YA(I)
   LET  XX = XX + 1 / XA(I) * 1 / XA(I)
NEXT I
LET  SLOPE7 = (N * XY - X * Y) / (N * XX - X * X)
END FUNCTION

EXTERNAL  FUNCTION INTERCEPT7(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + 1 / XA(I) * YA(I)
   LET   X = X + 1 / XA(I)
   LET   Y = Y + YA(I)
   LET  XX = XX + 1 / XA(I) * 1 / XA(I)
NEXT I
LET  INTERCEPT7 = (Y * XX - XY * X) / (N * XX - X * X)
END FUNCTION

EXTERNAL  FUNCTION FORECAST7(X, N, YA(), XA())
!'y=a*(1/x)+b
!'X=1/x
!'Y=B+A*X
LET  A = SLOPE7(N, YA, XA)
LET  B = INTERCEPT7(N, YA, XA)
LET  FORECAST7 = B + A * (1/X)
END FUNCTION

EXTERNAL  FUNCTION SLOPE8(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + XA(I)^(1/3) * YA(I)
   LET   X = X + XA(I)^(1/3)
   LET   Y = Y + YA(I)
   LET  XX = XX + XA(I)^(1/3) * XA(I)^(1/3)
NEXT I
LET  SLOPE8 = (N * XY - X * Y) / (N * XX - X * X)
END FUNCTION

EXTERNAL  FUNCTION INTERCEPT8(N, YA(), XA())
FOR I = 1 TO N
   LET  XY = XY + XA(I)^(1/3) * YA(I)
   LET   X = X + XA(I)^(1/3)
   LET   Y = Y + YA(I)
   LET  XX = XX + XA(I)^(1/3) * XA(I)^(1/3)
NEXT I
LET  INTERCEPT8 = (Y * XX - XY * X) / (N * XX - X * X)
END FUNCTION

EXTERNAL  FUNCTION FORECAST8(X, N, YA(), XA())
!'y=a*x^(1/3)+b
!'X=x^(1/3)
!'Y=B+A*X
LET  A = SLOPE8(N, YA, XA)
LET  B = INTERCEPT8(N, YA, XA)
LET  FORECAST8 = B + A * X ^ (1/3)
END FUNCTION
 

回帰式 その2

 投稿者:しばっち  投稿日:2010年 3月27日(土)21時15分28秒
  !'最小2乗法により一次関数(多変数)を求める(重回帰)
!'  A  +   X*B +  Y*C  + Z*D +  W*E   =   F(X,Y,Z,W)
!'Σ1*1  ΣX*1  ΣY*1  ΣZ*1  ΣW*1     ΣF(X,Y,Z,W)*1
!'Σ1*X  ΣX*X  ΣY*X  ΣZ*X  ΣW*X     ΣF(X,Y,Z,W)*X
!'Σ1*Y  ΣX*Y  ΣY*Y  ΣZ*Y  ΣW*Y     ΣF(X,Y,Z,W)*Y
!'Σ1*Z  ΣX*Z  ΣY*Z  ΣZ*Z  ΣW*Z     ΣF(X,Y,Z,W)*Z
!'Σ1*W  ΣX*W  ΣY*W  ΣZ*W  ΣW*W     ΣF(X,Y,Z,W)*W
LET  N = 10 !'データ数
RANDOMIZE
DIM X(N),Y(N),Z(N),W(N),F(N)
FOR I = 1 TO N
   LET  X(I) = INT(RND*20)
   LET  Y(I) = INT(RND*20)
   LET  Z(I) = INT(RND*20)
   LET  F(I) = INT(RND*20)
NEXT I
LET  M=INT(RND*2)+2
SELECT CASE M
CASE 2
   FOR I=1 TO N
      PRINT "X=";X(I);"Y=";Y(I);"F(X,Y)=";F(I);"^F(X,Y)=";FORECAST2(N,X,Y,F,X(I),Y(I))
   NEXT  I
CASE 3
   FOR I=1 TO N
      PRINT "X=";X(I);"Y=";Y(I);"Z=";Z(I);"F(X,Y,Z)=";F(I);"^F(X,Y,Z)=";FORECAST3(N,X,Y,Z,F,X(I),Y(I),Z(I))
   NEXT  I
END SELECT
END

EXTERNAL  FUNCTION FORECAST2(N,X(),Y(),F(),XA,YA)
!'F(X,Y)=A+B*X+C*Y
DIM XX(3,3),YY(3),WW(3)
FOR I=1 TO N
   LET  XX(1,1)=XX(1,1)+1
   LET  XX(2,1)=XX(2,1)+X(I)
   LET  XX(3,1)=XX(3,1)+Y(I)
   LET  XX(1,2)=XX(1,2)+X(I)
   LET  XX(2,2)=XX(2,2)+X(I)*X(I)
   LET  XX(3,2)=XX(3,2)+X(I)*Y(I)
   LET  XX(1,3)=XX(1,3)+Y(I)
   LET  XX(2,3)=XX(2,3)+Y(I)*X(I)
   LET  XX(3,3)=XX(3,3)+Y(I)*Y(I)
   LET  YY(1)=YY(1)+F(I)
   LET  YY(2)=YY(2)+F(I)*X(I)
   LET  YY(3)=YY(3)+F(I)*Y(I)
NEXT I
CALL CRAMER(3,XX,YY,WW)
LET  AA=WW(1)
LET  BB=WW(2)
LET  CC=WW(3)
LET  FORECAST2 = AA+BB*XA+CC*YA
END FUNCTION

EXTERNAL  FUNCTION FORECAST3(N,X(),Y(),Z(),F(),XA,YA,ZA)
!'F(X,Y,Z)=A+B*X+C*Y+D*Z
DIM XX(4,4),YY(4),WW(4)
FOR I=1 TO N
   LET  XX(1,1)=XX(1,1)+1
   LET  XX(2,1)=XX(2,1)+X(I)
   LET  XX(3,1)=XX(3,1)+Y(I)
   LET  XX(4,1)=XX(4,1)+Z(I)
   LET  XX(1,2)=XX(1,2)+X(I)
   LET  XX(2,2)=XX(2,2)+X(I)*X(I)
   LET  XX(3,2)=XX(3,2)+X(I)*Y(I)
   LET  XX(4,2)=XX(4,2)+X(I)*Z(I)
   LET  XX(1,3)=XX(1,3)+Y(I)
   LET  XX(2,3)=XX(2,3)+Y(I)*X(I)
   LET  XX(3,3)=XX(3,3)+Y(I)*Y(I)
   LET  XX(4,3)=XX(4,3)+Y(I)*Z(I)
   LET  XX(1,4)=XX(1,4)+Z(I)
   LET  XX(2,4)=XX(2,4)+Z(I)*X(I)
   LET  XX(3,4)=XX(3,4)+Z(I)*Y(I)
   LET  XX(4,4)=XX(4,4)+Z(I)*Z(I)
   LET  YY(1)=YY(1)+F(I)
   LET  YY(2)=YY(2)+F(I)*X(I)
   LET  YY(3)=YY(3)+F(I)*Y(I)
   LET  YY(4)=YY(4)+F(I)*Z(I)
NEXT I
CALL CRAMER(4,XX,YY,WW)
LET  AA=WW(1)
LET  BB=WW(2)
LET  CC=WW(3)
LET  DD=WW(4)
LET  FORECAST3 = AA+BB*XA+CC*YA+DD*ZA
END FUNCTION

EXTERNAL  SUB CRAMER (N, X(,), Y(), D()) !'クラーメル法
DIM A(N, N)
FOR I=1 TO N
   FOR J=1 TO N
      LET A(I,J)=X(I,J)
   NEXT J
NEXT I
LET DD = DET(A)
IF DD = 0 THEN STOP !'ERROR
FOR K = 1 TO N
   FOR I = 1 TO N
      FOR J = 1 TO N
         IF J = K THEN LET  A(I, J) = Y(I) ELSE LET  A(I, J) = X(I, J)
      NEXT J
   NEXT I
   LET  D(K) = DET(A) / DD
NEXT K
END SUB
 

回帰式 その3

 投稿者:しばっち  投稿日:2010年 3月27日(土)21時16分22秒
  !'最小2乗法によりn次関数を求める
!'  A   +    X*B   +   X^2*C  +   X^3*D  +   X^4*E    =    F(X)
!'Σ1*1    ΣX*1     ΣX^2*1    ΣX^3*1    ΣX^4*1       ΣF(X)*1
!'Σ1*X    ΣX*X     ΣX^2*X    ΣX^3*X    ΣX^4*X       ΣF(X)*X
!'Σ1*X^2  ΣX*X^2   ΣX^2*X^2  ΣX^3*X^2  ΣX^4*X^2     ΣF(X)*X^2
!'Σ1*X^3  ΣX*X^3   ΣX^2*X^3  ΣX^3*X^3  ΣX^4*X^3     ΣF(X)*X^3
!'Σ1*X^4  ΣX*X^4   ΣX^2*X^4  ΣX^3*X^4  ΣX^4*X^4     ΣF(X)*X^4
LET N =10
RANDOMIZE
DIM X(N),Y(N)
LET A =RND
LET B =RND
LET C =RND
LET D =RND
FOR I =1 TO N
   LET X(I)=I
   LET Y(I)=A+B*X(I)+C*X(I)^2+D*X(I)^3 !'仮データ作成(3次式)
NEXT I
FOR I=1 TO N
   PRINT "X=";X(I);"Y=";Y(I);"^Y=";FORECASTAUTO(X(I),N,Y,X)
NEXT I
END

EXTERNAL FUNCTION FORECASTAUTO(X,N,YA(),XA())
LET NLEVEL=7 !'当てはめ曲線の最高次数
DIM A(NLEVEL+1,NLEVEL+1),B(NLEVEL+1),R(NLEVEL+1),W(NLEVEL+1),WW(NLEVEL+1)
LET YN=MEAN(N,YA)
FOR I=1 TO N
   LET SY=SY+(YA(I)-YN)^2
NEXT I
FOR I=0 TO NLEVEL
   FOR J=0 TO NLEVEL
      LET A(I+1,J+1)=A(I+1,J+1)+XA(I+1)^(I+J)
   NEXT J
   LET B(I+1)=B(I+1)+XA(I+1)^I*YA(I+1)
NEXT I
FOR LEVEL=2 TO NLEVEL !'2次式からNLEVEL次まで
   MAT W=ZER
   CALL CRAMER(LEVEL,A,B,W)
   LET SE=0
   FOR I=1 TO N
      LET YY=W(LEVEL+1)
      FOR J=LEVEL-1 TO 0 STEP -1
         LET YY=YY*XA(I)+W(J+1)
      NEXT J
      LET SE=SE+(YA(I)-YY)^2
   NEXT I
   IF RR<1-SE/SY THEN !'決定係数より最良の次数を求める
      LET RR=1-SE/SY
      LET JISU=LEVEL
      MAT WW=W !'係数の保存
   END IF
NEXT LEVEL
LET YY=WW(JISU+1)
FOR J=JISU-1 TO 0 STEP -1
   LET YY=YY*X+WW(J+1)
NEXT J
LET FORECASTAUTO=YY
END FUNCTION

EXTERNAL FUNCTION MEAN(N,X()) !'平均
FOR I=1 TO N
   LET S=S+X(I)
NEXT I
LET MEAN=S/N
END FUNCTION

EXTERNAL  SUB CRAMER (N, X(,), Y(), D()) !'クラーメル法
DIM A(N, N)
FOR I=1 TO N
   FOR J=1 TO N
      LET A(I,J)=X(I,J)
   NEXT J
NEXT I
LET DD = DET(A)
IF DD = 0 THEN STOP !'ERROR
FOR K = 1 TO N
   FOR I = 1 TO N
      FOR J = 1 TO N
         IF J = K THEN LET  A(I, J) = Y(I) ELSE LET  A(I, J) = X(I, J)
      NEXT J
   NEXT I
   LET  D(K) = DET(A) / DD
NEXT K
END SUB
 

回帰式 その5

 投稿者:しばっち  投稿日:2010年 3月27日(土)21時18分27秒
  !'和の公式により回帰式を求める
LET N=12
OPTION BASE 0
DIM Y(N)
RANDOMIZE
LET C=INT(RND*1000)+1000
LET A=RND*4-2
LET B=RND*4-2
FOR I=0 TO N-1
   LET Y(I)=C/(1+B*EXP(-A*I)) !'仮データ作成
NEXT I
FOR I=0 TO N-1
   PRINT "X=";I;"Y=";Y(I);"^Y=";FORECAST(I,N,Y)
NEXT I
END

EXTERNAL FUNCTION FORECAST(X,N,YA())
!'Y=C/(1+B*EXP(-A*X))
!'1/Y=(1+B*EXP(-A*X))/C
!'S=1/C*Σ1+B/C*ΣEXP(-A*X)
!'S1=N/C+B/C*(EXP(-A*N)-1)/(EXP(-A)-1)
!'S2=N/C+B/C*EXP(-A*N)*(EXP(-A*N)-1)/(EXP(-A)-1)
!'S3=N/C+B/C*EXP(-A*N)^ 2*(EXP(-A*N)-1)/(EXP(-A)-1)
!'S2-S1=B/C*(EXP(-A*N)-1)*(EXP(-A*N)-1)/(EXP(-A)-1)
!'S3-S2=B/C*(EXP(-A*N)-1)*EXP(-A*N)*(EXP(-A*N)-1)/(EXP(-A)-1)
!'(S3-S2)/(S2-S1)=EXP(-A*N)
LET NN=INT(N/3)
FOR I=0 TO NN-1
   LET S1=S1+1/YA(I)
   LET S2=S2+1/YA(NN+I)
   LET S3=S3+1/YA(2*NN+I)
NEXT I
LET AA=((S3-S2)/(S2-S1))^(1/NN)!'=EXP(-A)
LET A=-LOG(AA)
LET CB=(S1-S2)*(EXP(-A)-1)/(EXP(-A*NN)-1)^2 !'=-B/C
!'LET CC=1/NN*(S1+CB*(EXP(-A*NN)-1)/(EXP(-A)-1))!'=1/C
LET CC=1/NN*((S1*S3-S2*S2)/(S1+S3-2*S2))
LET C=1/CC
LET B=-C*CB
LET FORECAST =C/(1+B*EXP(-A*X))
END FUNCTION
 

回帰式 その6

 投稿者:しばっち  投稿日:2010年 3月27日(土)21時19分27秒
  !'和の公式により回帰式を求める(修正指数関数)
LET N=12
OPTION BASE 0
DIM Y(N)
RANDOMIZE
LET A=RND*5
LET B=RND*5
LET C=INT(RND*100)+100
FOR I=0 TO N-1
   LET Y(I)=C-B*A^I !'仮データ作成
NEXT I
FOR I=0 TO N-1
   PRINT "X=";I;"Y=";Y(I);"^Y=";FORECAST(I,N,Y)
NEXT I
END

EXTERNAL FUNCTION FORECAST(X,N,YA())
!'Y=C-B*A^X  修正指数関数
!'S1=Y(0)+Y(1)+Y(2)+Y(3)+...Y(n-1)
!'S2=Y(n)+Y(n+1)+Y(n+2)+...Y(2n-1)
!'S3=Y(2n)+Y(2n+1)+Y(2n+2)+...Y(3n-1)
!'S1=(C-B)+(C-B*A)+(C-B*A^ 2)+(C-B*A^3)+...(C-B*A^(N-1))
!'S2=(C-B*A^N)+(C-B*A^(N+1))+...(C-B*A^(2*(N-1)))
!'S3=(C-B*A^(2*N))+(C-B*A^(2*N+2))+...(C-B*A^(3*(N-1)))
!'S1=N*C+B*(A^N-1)/(A-1)
!'S2=N*C+B*A^N*(A^N-1)/(A-1)
!'S3=N*C+B*A^(2*N)*(A^N-1)/(A-1)
LET NN=INT(N/3)
FOR I=0 TO NN-1
   LET S1=S1+YA(I)
   LET S2=S2+YA(NN+I)
   LET S3=S3+YA(2*NN+I)
NEXT I
LET A=((S3-S2)/(S2-S1))^(1/NN)
LET B=(S1-S2)*(A-1)/(A^NN-1)^2
!'LET C=1/NN*(S1+B*(A^NN-1)/(A-1))
LET C=1/NN*((S1*S3-S2*S2)/(S1+S3-2*S2))
LET FORECAST =C-B*A^X
END FUNCTION
 

回帰式 その7

 投稿者:しばっち  投稿日:2010年 3月27日(土)21時20分25秒
  !'和の公式より回帰式を求める(ゴンペルツ)
OPTION BASE 0
LET N =12
DIM Y(N)
RANDOMIZE
LET K=INT(RND*5)+5
LET A=RND
LET B=RND
FOR I=0 TO N-1
   LET Y(I)=K*A^(B^I) !'仮データ作成
NEXT I
FOR I=0 TO N-1
   PRINT "X=";I;"Y=";Y(I);"^Y=";FORECAST(I,N,Y)
NEXT I
END

EXTERNAL FUNCTION FORECAST(X,N,YA())
!'Y=K*A^(B^X) ゴンペルツ (条件 0<A<1,0<B<1)
LET NN=INT(N/3)
FOR I=0 TO NN-1
   LET S1=S1+LOG(YA(I))
   LET S2=S2+LOG(YA(NN+I))
   LET S3=S3+LOG(YA(2*NN+I))
NEXT I
LET B=((S3-S2)/(S2-S1))^(1/NN)
LET AA=(S2-S1)*(B-1)/(B^NN-1)^2
LET KK=1/NN*((S1*S3-S2*S2)/(S1+S3-2*S2))
LET K=EXP(KK)
LET A=EXP(AA)
LET FORECAST =K*A^(B^X)
END FUNCTION
 

回帰式 その8

 投稿者:しばっち  投稿日:2010年 3月27日(土)21時21分49秒
  !'最小2乗法により回帰式を求める。
LET N =15
RANDOMIZE
DIM X(N),Y(N)
LET A=INT(RND*5)+1
LET B=INT(RND*3)+1
LET C=INT(RND*1000)+500
LET MODE=INT(RND*8)+1
FOR I =1 TO N
   LET X(I)=I*2-1
   SELECT CASE MODE
   CASE 1
      LET Y(I)=C/(A+B*X(I))
   CASE 2
      LET Y(I)=C/(A*EXP(B*X(I)))
   CASE 3
      LET Y(I)=C/(A*X(I)^B)
   CASE 4
      LET Y(I)=C/(B*LOG(X(I))+A)
   CASE 5
      LET Y(I)=C/(A*B^X(I))
   CASE 6
      LET Y(I)=C/(A+B*SQR(X(I)))
   CASE 7
      LET Y(I)=C/(A+B/X(I))
   CASE 8
      LET Y(I)=C/(A+B*X(I)^(1/3))
   END SELECT
NEXT I
FOR I=1 TO N
   PRINT "X=";X(I);"Y=";Y(I);"^Y=";
   SELECT CASE MODE
   CASE 1
      PRINT FORECAST(X(I),N,Y,X)
   CASE 2
      PRINT FORECAST2(X(I),N,Y,X)
   CASE 3
      PRINT FORECAST3(X(I),N,Y,X)
   CASE 4
      PRINT FORECAST4(X(I),N,Y,X)
   CASE 5
      PRINT FORECAST5(X(I),N,Y,X)
   CASE 6
      PRINT FORECAST6(X(I),N,Y,X)
   CASE 7
      PRINT FORECAST7(X(I),N,Y,X)
   CASE 8
      PRINT FORECAST8(X(I),N,Y,X)
   END SELECT
NEXT I
END

EXTERNAL FUNCTION FORECAST(X,N,YA(),XA())
!'Y=C/(A+B*X)
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET C=MAX(C,1/YA(I))
NEXT I
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1/C
   LET XX(2,1)=XX(2,1)+XA(I)/C
   LET XX(1,2)=XX(1,2)+XA(I)/C
   LET XX(2,2)=XX(2,2)+XA(I)*XA(I)/C
   LET YY(1)=YY(1)+1/YA(I)
   LET YY(2)=YY(2)+1/YA(I)*XA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST =C/(A+B*X)
END FUNCTION

EXTERNAL FUNCTION FORECAST2(X,N,YA(),XA())
!'Y=C/(A*EXP(B*X))
DIM XX(2,2),YY(2),WW(2)
LET C=-10000
FOR I=1 TO N
   LET C=MAX(C,LOG(1/YA(I)))
NEXT I
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1
   LET XX(2,1)=XX(2,1)+XA(I)
   LET XX(1,2)=XX(1,2)+XA(I)
   LET XX(2,2)=XX(2,2)+XA(I)*XA(I)
   LET YY(1)=YY(1)+LOG(1/YA(I))
   LET YY(2)=YY(2)+LOG(1/YA(I))*XA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=EXP(WW(1))*C
LET B=WW(2)
LET FORECAST2 =C/(A*EXP(B*X))
END FUNCTION

EXTERNAL FUNCTION FORECAST3(X,N,YA(),XA())
!'Y=C/(A*X^B)
DIM XX(2,2),YY(2),WW(2)
LET C=-10000
FOR I=1 TO N
   LET C=MAX(C,LOG(1/YA(I)))
NEXT I
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1
   LET XX(2,1)=XX(2,1)+LOG(XA(I))
   LET XX(1,2)=XX(1,2)+LOG(XA(I))
   LET XX(2,2)=XX(2,2)+LOG(XA(I))*LOG(XA(I))
   LET YY(1)=YY(1)+LOG(1/YA(I))
   LET YY(2)=YY(2)+LOG(1/YA(I))*LOG(XA(I))
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=EXP(WW(1))*C
LET B=WW(2)
LET FORECAST3 =C/(A*X^B)
END FUNCTION

EXTERNAL FUNCTION FORECAST4(X,N,YA(),XA())
!'Y=C/(B*LOG(X)+A)
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET C=MAX(C,1/YA(I))
NEXT I
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1/C
   LET XX(2,1)=XX(2,1)+LOG(XA(I))/C
   LET XX(1,2)=XX(1,2)+LOG(XA(I))/C
   LET XX(2,2)=XX(2,2)+LOG(XA(I))*LOG(XA(I))/C
   LET YY(1)=YY(1)+1/YA(I)
   LET YY(2)=YY(2)+1/YA(I)*LOG(XA(I))
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST4 =C/(B*LOG(X)+A)
END FUNCTION

EXTERNAL FUNCTION FORECAST5(X,N,YA(),XA())
!'Y=C/(A*B^X)
DIM XX(2,2),YY(2),WW(2)
LET C=-100000
FOR I=1 TO N
   LET C=MAX(C,LOG(1/YA(I)))
NEXT I
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1
   LET XX(2,1)=XX(2,1)+XA(I)
   LET XX(1,2)=XX(1,2)+XA(I)
   LET XX(2,2)=XX(2,2)+XA(I)*XA(I)
   LET YY(1)=YY(1)+LOG(1/YA(I))
   LET YY(2)=YY(2)+LOG(1/YA(I))*XA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=EXP(WW(1))*C
LET B=EXP(WW(2))
LET FORECAST5 =C/(A*B^X)
END FUNCTION

EXTERNAL FUNCTION FORECAST6(X,N,YA(),XA())
!'Y=C/(A+B*SQR(X))
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET C=MAX(C,1/YA(I))
NEXT I
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1/C
   LET XX(2,1)=XX(2,1)+SQR(XA(I))/C
   LET XX(1,2)=XX(1,2)+SQR(XA(I))/C
   LET XX(2,2)=XX(2,2)+SQR(XA(I))*SQR(XA(I))/C
   LET YY(1)=YY(1)+1/YA(I)
   LET YY(2)=YY(2)+1/YA(I)*SQR(XA(I))
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST6 =C/(A+B*SQR(X))
END FUNCTION

EXTERNAL FUNCTION FORECAST7(X,N,YA(),XA())
!'Y=C/(A+B*(1/X))
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET C=MAX(C,1/YA(I))
NEXT I
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1/C
   LET XX(2,1)=XX(2,1)+1/XA(I)/C
   LET XX(1,2)=XX(1,2)+1/XA(I)/C
   LET XX(2,2)=XX(2,2)+1/XA(I)/XA(I)/C
   LET YY(1)=YY(1)+1/YA(I)
   LET YY(2)=YY(2)+1/YA(I)/XA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST7 =C/(A+B/X)
END FUNCTION

EXTERNAL FUNCTION FORECAST8(X,N,YA(),XA())
!'Y=C/(A+B*X^(1/3))
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET C=MAX(C,1/YA(I))
NEXT I
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1/C
   LET XX(2,1)=XX(2,1)+(XA(I)^(1/3))/C
   LET XX(1,2)=XX(1,2)+(XA(I)^(1/3))/C
   LET XX(2,2)=XX(2,2)+(XA(I)^(2/3))/C
   LET YY(1)=YY(1)+1/YA(I)
   LET YY(2)=YY(2)+1/YA(I)*XA(I)^(1/3)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST8 =C/(A+B*X^(1/3))
END FUNCTION

EXTERNAL SUB CRAMER2(X(,),Y(),W()) !'クラーメル法
LET D=X(1,1)*X(2,2)-X(2,1)*X(1,2)
LET XX=Y(1)*X(2,2)-Y(2)*X(1,2)
LET YY=Y(2)*X(1,1)-Y(1)*X(2,1)
LET W(1)=XX/D
LET W(2)=YY/D
END SUB

!'EXTERNAL  SUB  CRAMER3 (X(,), Y(), W())
!'LET  D = X(1, 1) * X(2, 2) * X(3, 3) + X(2, 1) * X(3, 2) * X(1, 3) + X(3, 1) * X(1, 2) * X(2, 3) - X(3, 1) * X(2, 2) * X(1, 3) - X(2, 1) * X(1, 2) * X(3, 3) - X(1, 1) * X(3, 2) * X(2, 3)
!'LET  XX = Y(1) * X(2, 2) * X(3, 3) + Y(2) * X(3, 2) * X(1, 3) + Y(3) * X(1, 2) * X(2, 3) - Y(3) * X(2, 2) * X(1, 3) - Y(2) * X(1, 2) * X(3, 3) - Y(1) * X(3, 2) * X(2, 3)
!'LET  YY = X(1, 1) * Y(2) * X(3, 3) + X(2, 1) * Y(3) * X(1, 3) + X(3, 1) * Y(1) * X(2, 3) - X(3, 1) * Y(2) * X(1, 3) - X(2, 1) * Y(1) * X(3, 3) - X(1, 1) * Y(3) * X(2, 3)
!'LET  ZZ = X(1, 1) * X(2, 2) * Y(3) + X(2, 1) * X(3, 2) * Y(1) + X(3, 1) * X(1, 2) * Y(2) - X(3, 1) * X(2, 2) * Y(1) - X(2, 1) * X(1, 2) * Y(3) - X(1, 1) * X(3, 2) * Y(2)
!'LET  W(1) = XX / D
!'LET  W(2) = YY / D
!'LET  W(3) = ZZ / D
!'END SUB
 

回帰式 その9

 投稿者:しばっち  投稿日:2010年 3月27日(土)21時23分2秒
  !'最小2乗法により回帰式を求める。
LET N=15
RANDOMIZE
DIM X(N),Y(N)
LET A=INT(RND*3)+2
LET B=INT(RND*3)+2
LET MODE=INT(RND*10)+1
FOR I =1 TO N
   LET X(I)=I*2
   SELECT CASE MODE
   CASE 1
      LET Y(I)=SQR(X(I))/(A+B*X(I))
   CASE 2
      LET Y(I)=LOG(X(I))/(A+B*X(I))
   CASE 3
      LET Y(I)=SQR(X(I))/LOG(A+B*X(I))
   CASE 4
      LET Y(I)=SQR(X(I))/EXP(A+B*X(I))
   CASE 5
      LET Y(I)=EXP(X(I))/SQR(A+B*X(I))
   CASE 6
      LET Y(I)=LOG(X(I))/(A+B*X(I))^(1/3)
   CASE 7
      LET Y(I)=X(I)^2/(A+B*X(I))
   CASE 8
      LET Y(I)=EXP(X(I))/(A+B*X(I))
   CASE 9
      LET Y(I)=1/(1+1/(A+B*X(I)))
   CASE 10
      LET Y(I)=X(I)/(A+B*(1/X(I)))
   END SELECT
NEXT I
FOR I=1 TO N
   PRINT "X=";X(I);"Y=";Y(I);"^Y=";
   SELECT CASE MODE
   CASE 1
      PRINT FORECAST(X(I),N,Y,X)
   CASE 2
      PRINT FORECAST2(X(I),N,Y,X)
   CASE 3
      PRINT FORECAST3(X(I),N,Y,X)
   CASE 4
      PRINT FORECAST4(X(I),N,Y,X)
   CASE 5
      PRINT FORECAST5(X(I),N,Y,X)
   CASE 6
      PRINT FORECAST6(X(I),N,Y,X)
   CASE 7
      PRINT FORECAST7(X(I),N,Y,X)
   CASE 8
      PRINT FORECAST8(X(I),N,Y,X)
   CASE 9
      PRINT FORECAST9(X(I),N,Y,X)
   CASE 10
      PRINT FORECAST10(X(I),N,Y,X)
   END SELECT
NEXT I
END

EXTERNAL FUNCTION FORECAST(X,N,YA(),XA())
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1
   LET XX(2,1)=XX(2,1)+XA(I)
   LET XX(1,2)=XX(1,2)+XA(I)
   LET XX(2,2)=XX(2,2)+XA(I)*XA(I)
   LET YY(1)=YY(1)+SQR(XA(I))/YA(I)
   LET YY(2)=YY(2)+SQR(XA(I))*XA(I)/YA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST =SQR(X)/(A+B*X)
END FUNCTION

EXTERNAL FUNCTION FORECAST2(X,N,YA(),XA())
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1
   LET XX(2,1)=XX(2,1)+XA(I)
   LET XX(1,2)=XX(1,2)+XA(I)
   LET XX(2,2)=XX(2,2)+XA(I)*XA(I)
   LET YY(1)=YY(1)+LOG(XA(I))/YA(I)
   LET YY(2)=YY(2)+LOG(XA(I))/YA(I)*XA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST2 =LOG(X)/(A+B*X)
END FUNCTION

EXTERNAL FUNCTION FORECAST3(X,N,YA(),XA())
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1
   LET XX(2,1)=XX(2,1)+XA(I)
   LET XX(1,2)=XX(1,2)+XA(I)
   LET XX(2,2)=XX(2,2)+XA(I)*XA(I)
   LET YY(1)=YY(1)+EXP(SQR(XA(I))/YA(I))
   LET YY(2)=YY(2)+EXP(SQR(XA(I))/YA(I))*XA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST3 =SQR(X)/LOG(A+B*X)
END FUNCTION

EXTERNAL FUNCTION FORECAST4(X,N,YA(),XA())
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1
   LET XX(2,1)=XX(2,1)+XA(I)
   LET XX(1,2)=XX(1,2)+XA(I)
   LET XX(2,2)=XX(2,2)+XA(I)*XA(I)
   LET YY(1)=YY(1)+LOG(SQR(XA(I))/YA(I))
   LET YY(2)=YY(2)+LOG(SQR(XA(I))/YA(I))*XA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST4=SQR(X)/EXP(A+B*X)
END FUNCTION

EXTERNAL FUNCTION FORECAST5(X,N,YA(),XA())
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1
   LET XX(2,1)=XX(2,1)+XA(I)
   LET XX(1,2)=XX(1,2)+XA(I)
   LET XX(2,2)=XX(2,2)+XA(I)*XA(I)
   LET YY(1)=YY(1)+(EXP(XA(I))/YA(I))^2
   LET YY(2)=YY(2)+(EXP(XA(I))/YA(I))^2*XA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST5 =EXP(X)/SQR(A+B*X)
END FUNCTION

EXTERNAL FUNCTION FORECAST6(X,N,YA(),XA())
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1
   LET XX(2,1)=XX(2,1)+XA(I)
   LET XX(1,2)=XX(1,2)+XA(I)
   LET XX(2,2)=XX(2,2)+XA(I)*XA(I)
   LET YY(1)=YY(1)+(LOG(XA(I))/YA(I))^3
   LET YY(2)=YY(2)+(LOG(XA(I))/YA(I))^3*XA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST6 =LOG(X)/(A+B*X)^(1/3)
END FUNCTION

EXTERNAL FUNCTION FORECAST7(X,N,YA(),XA())
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1
   LET XX(2,1)=XX(2,1)+XA(I)
   LET XX(1,2)=XX(1,2)+XA(I)
   LET XX(2,2)=XX(2,2)+XA(I)^2
   LET YY(1)=YY(1)+XA(I)^2/YA(I)
   LET YY(2)=YY(2)+XA(I)^2/YA(I)*XA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST7=X^2/(A+B*X)
END FUNCTION

EXTERNAL FUNCTION FORECAST8(X,N,YA(),XA())
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1
   LET XX(2,1)=XX(2,1)+XA(I)
   LET XX(1,2)=XX(1,2)+XA(I)
   LET XX(2,2)=XX(2,2)+XA(I)^2
   LET YY(1)=YY(1)+EXP(XA(I))/YA(I)
   LET YY(2)=YY(2)+EXP(XA(I))/YA(I)*XA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST8 =EXP(X)/(A+B*X)
END FUNCTION

EXTERNAL  FUNCTION FORECAST9(X,N,YA(),XA())
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET  XX(1,1)=XX(1,1)+1
   LET  XX(2,1)=XX(2,1)+XA(I)
   LET  XX(1,2)=XX(1,2)+XA(I)
   LET  XX(2,2)=XX(2,2)+XA(I)*XA(I)
   LET  YY(1)=YY(1)+YA(I)/(1-YA(I))
   LET  YY(2)=YY(2)+YA(I)/(1-YA(I))*XA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET  A=WW(1)
LET  B=WW(2)
LET  FORECAST9= 1/(1+1/(A+B*X))
END FUNCTION

EXTERNAL FUNCTION FORECAST10(X,N,YA(),XA())
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET XX(1,1)=XX(1,1)+1
   LET XX(2,1)=XX(2,1)+1/XA(I)
   LET XX(1,2)=XX(1,2)+1/XA(I)
   LET XX(2,2)=XX(2,2)+1/XA(I)^2
   LET YY(1)=YY(1)+XA(I)/YA(I)
   LET YY(2)=YY(2)+XA(I)/YA(I)/XA(I)
NEXT I
CALL CRAMER2(XX,YY,WW)
LET A=WW(1)
LET B=WW(2)
LET FORECAST10=X/(A+B/X)
END FUNCTION

EXTERNAL SUB CRAMER2 (X(,),Y(),W()) !'クラーメル法
LET D=X(1,1)*X(2,2)-X(2,1)*X(1,2)
LET XX=Y(1)*X(2,2)-Y(2)*X(1,2)
LET YY=Y(2)*X(1,1)-Y(1)*X(2,1)
LET W(1)=XX/D
LET W(2)=YY/D
END SUB
 

回帰式 その10

 投稿者:しばっち  投稿日:2010年 3月27日(土)21時25分47秒
  !'最小2乗法により回帰式を求める(ロジスティック回帰式)
!'y=1/(1+EXP(-(a+bx)))  0<y<1
!'1/y=1+EXP(-(a+bx))
!'1/(1/y-1)=EXP(a+bx)
!'LOG(y/(1-y))=a+bx
!'Y=LOG(y/(1-y)) X=x A=a B=b
!'  A  +   X*B +  Y*C  + Z*D +  W*E   =   LOG(F(X,Y,Z,W)/(1-F(X,Y,Z,W)))
!'Σ1*1  ΣX*1  ΣY*1  ΣZ*1  ΣW*1     ΣLOG(F(X,Y,Z,W)/(1-F(X,Y,Z,W)))*1
!'Σ1*X  ΣX*X  ΣY*X  ΣZ*X  ΣW*X     ΣLOG(F(X,Y,Z,W)/(1-F(X,Y,Z,W)))*X
!'Σ1*Y  ΣX*Y  ΣY*Y  ΣZ*Y  ΣW*Y     ΣLOG(F(X,Y,Z,W)/(1-F(X,Y,Z,W)))*Y
!'Σ1*Z  ΣX*Z  ΣY*Z  ΣZ*Z  ΣW*Z     ΣLOG(F(X,Y,Z,W)/(1-F(X,Y,Z,W)))*Z
!'Σ1*W  ΣX*W  ΣY*W  ΣZ*W  ΣW*W     ΣLOG(F(X,Y,Z,W)/(1-F(X,Y,Z,W)))*W
LET  N = 10
RANDOMIZE
DIM X(N),Y(N),Z(N),F(N)
LET A=RND
LET B=RND
LET C=RND
LET D=RND
LET M=INT(RND*3)+1
FOR I = 1 TO N
   LET  X(I) = RND
   IF M>1 THEN LET  Y(I) = RND
   IF M>2 THEN LET  Z(I) = RND
   LET  F(I) = 1/(1+EXP(-(A+B*X(I)+C*Y(I)+D*Z(I))))
NEXT I
SELECT CASE M
CASE 1
   FOR I=1 TO N
      PRINT "X=";X(I);"F(X)=";F(I);"^F(X)=";FORECAST(N,X,F,X(I))
   NEXT  I
CASE 2
   FOR I=1 TO N
      PRINT "X=";X(I);"Y=";Y(I);"F(X,Y)=";F(I);"^F(X,Y)=";FORECAST2(N,X,Y,F,X(I),Y(I))
   NEXT  I
CASE 3
   FOR I=1 TO N
      PRINT "X=";X(I);"Y=";Y(I);"Z=";Z(I);"F(X,Y,Z)=";F(I);"^F(X,Y,Z)=";FORECAST3(N,X,Y,Z,F,X(I),Y(I),Z(I))
   NEXT  I
END SELECT
END

EXTERNAL  FUNCTION FORECAST(N,X(),F(),XA)
!'F(X)=1/(1+EXP(-(A+B*X)))
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET  XX(1,1)=XX(1,1)+1
   LET  XX(2,1)=XX(2,1)+X(I)
   LET  XX(1,2)=XX(1,2)+X(I)
   LET  XX(2,2)=XX(2,2)+X(I)*X(I)
   LET  YY(1)=YY(1)+LOG(F(I)/(1-F(I)))
   LET  YY(2)=YY(2)+LOG(F(I)/(1-F(I)))*X(I)
NEXT I
CALL CRAMER(2,XX,YY,WW)
LET  AA=WW(1)
LET  BB=WW(2)
LET  FORECAST = 1/(1+EXP(-(AA+BB*XA)))
END FUNCTION

EXTERNAL  FUNCTION FORECAST2(N,X(),Y(),F(),XA,YA)
!'F(X,Y)=1/(1+EXP(-(A+B*X+C*Y)))
DIM XX(3,3),YY(3),WW(3)
FOR I=1 TO N
   LET  XX(1,1)=XX(1,1)+1
   LET  XX(2,1)=XX(2,1)+X(I)
   LET  XX(3,1)=XX(3,1)+Y(I)
   LET  XX(1,2)=XX(1,2)+X(I)
   LET  XX(2,2)=XX(2,2)+X(I)*X(I)
   LET  XX(3,2)=XX(3,2)+X(I)*Y(I)
   LET  XX(1,3)=XX(1,3)+Y(I)
   LET  XX(2,3)=XX(2,3)+Y(I)*X(I)
   LET  XX(3,3)=XX(3,3)+Y(I)*Y(I)
   LET  YY(1)=YY(1)+LOG(F(I)/(1-F(I)))
   LET  YY(2)=YY(2)+LOG(F(I)/(1-F(I)))*X(I)
   LET  YY(3)=YY(3)+LOG(F(I)/(1-F(I)))*Y(I)
NEXT I
CALL CRAMER(3,XX,YY,WW)
LET  AA=WW(1)
LET  BB=WW(2)
LET  CC=WW(3)
LET  FORECAST2 = 1/(1+EXP(-(AA+BB*XA+CC*YA)))
END FUNCTION

EXTERNAL  FUNCTION FORECAST3(N,X(),Y(),Z(),F(),XA,YA,ZA)
!'F(X,Y,Z)=1/(1+EXP(-(A+B*X+C*Y+D*Z)))
DIM XX(4,4),YY(4),WW(4)
FOR I=1 TO N
   LET  XX(1,1)=XX(1,1)+1
   LET  XX(2,1)=XX(2,1)+X(I)
   LET  XX(3,1)=XX(3,1)+Y(I)
   LET  XX(4,1)=XX(4,1)+Z(I)
   LET  XX(1,2)=XX(1,2)+X(I)
   LET  XX(2,2)=XX(2,2)+X(I)*X(I)
   LET  XX(3,2)=XX(3,2)+X(I)*Y(I)
   LET  XX(4,2)=XX(4,2)+X(I)*Z(I)
   LET  XX(1,3)=XX(1,3)+Y(I)
   LET  XX(2,3)=XX(2,3)+Y(I)*X(I)
   LET  XX(3,3)=XX(3,3)+Y(I)*Y(I)
   LET  XX(4,3)=XX(4,3)+Y(I)*Z(I)
   LET  XX(1,4)=XX(1,4)+Z(I)
   LET  XX(2,4)=XX(2,4)+Z(I)*X(I)
   LET  XX(3,4)=XX(3,4)+Z(I)*Y(I)
   LET  XX(4,4)=XX(4,4)+Z(I)*Z(I)
   LET  YY(1)=YY(1)+LOG(F(I)/(1-F(I)))
   LET  YY(2)=YY(2)+LOG(F(I)/(1-F(I)))*X(I)
   LET  YY(3)=YY(3)+LOG(F(I)/(1-F(I)))*Y(I)
   LET  YY(4)=YY(4)+LOG(F(I)/(1-F(I)))*Z(I)
NEXT I
CALL CRAMER(4,XX,YY,WW)
LET  AA=WW(1)
LET  BB=WW(2)
LET  CC=WW(3)
LET  DD=WW(4)
LET  FORECAST3 = 1/(1+EXP(-(AA+BB*XA+CC*YA+DD*ZA)))
END FUNCTION

EXTERNAL  SUB CRAMER (N, X(,), Y(), D()) !'クラーメル法
DIM A(N, N)
FOR I=1 TO N
   FOR J=1 TO N
      LET A(I,J)=X(I,J)
   NEXT J
NEXT I
LET DD = DET(A)
IF DD = 0 THEN STOP !'ERROR
FOR K = 1 TO N
   FOR I = 1 TO N
      FOR J = 1 TO N
         IF J = K THEN LET  A(I, J) = Y(I) ELSE LET  A(I, J) = X(I, J)
      NEXT J
   NEXT I
   LET  D(K) = DET(A) / DD
NEXT K
END SUB
 

Re: 回帰式 その10

 投稿者:島村1243  投稿日:2010年 3月29日(月)10時35分28秒
  > No.1121[元記事へ]

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

> !'最小2乗法により回帰式を求める(ロジスティック回帰式)
> !'y=1/(1+EXP(-(a+bx)))  0<y<1
>---中略---
> END SUB

しばっちさんの回帰式プログラムは、多数のデータ(x,y)値から
指定関数形(例えば)y=A+B*x+C*x^2
の係数A,B,Cを求めることだと解釈しているのですが
しばっちさんのプログラムは、この係数を求めるものとは違うのでしょうか?

RND関数で(x,y)値を作り出して、指定回帰式の係数を求める計算を行っている
ように見えるのですが、係数が出力されないので意味が理解出来ません。
係数が出力されれば、非常に便利なのですが。
 

十進モードでの計算の不具合

 投稿者:山中和義  投稿日:2010年 3月29日(月)16時09分21秒
  下記の「ビット列の並びを反転する」プログラムのビット演算を行うと
十進モードでは、他のモード(1000桁、2進、有理数)と計算結果が異なります。
LET m=4
LET N=2^m

FOR i=0 TO N-1

   LET x=i
   LET x=bitor( sft(bitand(x,BVAL("AAAAAAAA",16)),-1), sft(bitand(x,BVAL("55555555",16)),1) )
   LET x=bitor( sft(bitand(x,BVAL("CCCCCCCC",16)),-2), sft(bitand(x,BVAL("33333333",16)),2) )
   LET x=bitor( sft(bitand(x,BVAL("F0F0F0F0",16)),-4), sft(bitand(x,BVAL("0F0F0F0F",16)),4) )
   LET x=bitor( sft(bitand(x,BVAL("FF00FF00",16)),-8), sft(bitand(x,BVAL("00FF00FF",16)),8) )
   LET x=bitor(sft(x,-16),sft(x,16)) !FFFF0000,0000FFFF
   LET x=sft(x,-(32-m))

   PRINT i;BSTR$(i,2),
   IF x<0 THEN PRINT 2^m+x;BSTR$(2^m+x,2) ELSE PRINT x;BSTR$(x,2)

NEXT i

END

EXTERNAL FUNCTION bitand(a,b) !ビットごとの論理積
LET c=0 !値
FOR i=0 TO 31
   LET aa=MOD(a,2)
   LET a=(a-aa)/2
   LET bb=MOD(b,2)
   LET b=(b-bb)/2
   LET c=c+MIN(aa,bb)*2^i
NEXT i
IF c>=2^31 THEN LET c=c-2^32
LET bitand=c
END FUNCTION

EXTERNAL FUNCTION bitor(a,b) !ビットごとの論理和
LET c=0
FOR i=0 TO 31
   LET aa=MOD(a,2)
   LET a=(a-aa)/2
   LET bb=MOD(b,2)
   LET b=(b-bb)/2
   LET c=c+MAX(aa,bb)*2^i
NEXT i
IF c>=2^31 THEN LET c=c-2^32
LET bitor=c
END FUNCTION

EXTERNAL FUNCTION sft(x,n) !nビットのシフトする ※nは整数
LET sft=IP(x*2^n)
END FUNCTION
 

Re: 十進モードでの計算の不具合

 投稿者:白石 和夫  投稿日:2010年 3月29日(月)17時06分14秒
  > No.1123[元記事へ]

トレース出力が最初に一致しない部分をプログラムにすると

LET N=-28
LET X=-2147483648
LET sft=IP(x*2^n)
PRINT sft
END

となります。
その結果は,十進モードで-7,1000桁モードで-8となります。
理由は,2^(-28)の正しい値は
(1000桁モードの計算で)
.0000000037252902984619140625
ですが,十進モードでは,
.000000003725290298461914
に丸められるのが原因です。
 

バグ発見

 投稿者:白石 和夫  投稿日:2010年 3月29日(月)17時15分13秒
  十進モード,1000桁モードで
LET x=-2147483648
PRINT 2^x
を実行すると結果が0.5になるバグを発見しました。
修正します。
 

Re: 回帰式 その10

 投稿者:しばっち  投稿日:2010年 3月29日(月)21時17分19秒
  > No.1122[元記事へ]

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

> しばっちさんの回帰式プログラムは、多数のデータ(x,y)値から
> 指定関数形(例えば)y=A+B*x+C*x^2
> の係数A,B,Cを求めることだと解釈しているのですが
> しばっちさんのプログラムは、この係数を求めるものとは違うのでしょうか?
>
> RND関数で(x,y)値を作り出して、指定回帰式の係数を求める計算を行っている
> ように見えるのですが、係数が出力されないので意味が理解出来ません。
> 係数が出力されれば、非常に便利なのですが。

島村1243さんの解釈どおり回帰式の係数をプログラムで求めています。
ただ係数を出力することより、プログラムに組み込んで使用することを
想定しているのでそのようには作っていません。
どうしても係数を見たいのならばFUNCTION 文の中で関数値を代入しているところ
の係数をPRINT 文で出力してください。

EXTERNAL  FUNCTION FORECAST(N,X(),F(),XA) 回帰式その10より
!'F(X)=1/(1+EXP(-(A+B*X)))
DIM XX(2,2),YY(2),WW(2)
FOR I=1 TO N
   LET  XX(1,1)=XX(1,1)+1
   LET  XX(2,1)=XX(2,1)+X(I)
   LET  XX(1,2)=XX(1,2)+X(I)
   LET  XX(2,2)=XX(2,2)+X(I)*X(I)
   LET  YY(1)=YY(1)+LOG(F(I)/(1-F(I)))
   LET  YY(2)=YY(2)+LOG(F(I)/(1-F(I)))*X(I)
NEXT I
CALL CRAMER(2,XX,YY,WW) <----連立方程式をクラーメル法で解いている
LET  AA=WW(1) <---これが係数
LET  BB=WW(2) <---これが係数
LET  FORECAST = 1/(1+EXP(-(AA+BB*XA))) <---関数値を代入
PRINT "1/(1+EXP(-(AA+BB*XA))) の係数 AA=";AA;"BB=";BB <----このようにPRINT文を追加してください
END FUNCTION

外部関数として定義しているので
EXTERNAL  FUNCTION FORECAST(N,X(),F(),XA,AA,BB)
これで係数AA,BB値を受け取れないためです。

内部関数として定義すれば直接変数値を取り出せますが、
メインルーチン等の変数名とダブらないようにして下さい。
 

Re: 十進モードでの計算の不具合

 投稿者:山中和義  投稿日:2010年 3月29日(月)21時17分20秒
  > No.1124[元記事へ]

白石 和夫さんへのお返事です。

> 丸められるのが原因です。

次のように変更して対応します。
EXTERNAL FUNCTION sft(x,n) !nビットのシフトする ※nは整数
LET t=x*2^n
LET sft=IP(t)
!!!丸めによる結果が期待にそわない LET sft=IP(x*2^n)
END FUNCTION

または
EXTERNAL FUNCTION sft(x,n) !nビットのシフトする ※nは整数
IF n>=0 THEN
   LET sft=x*2^n
ELSE
   LET sft=IP(x/2^(-n)) !※丸めにより期待にそわない LET sft=IP(x*2^n)
END IF
END FUNCTION
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 3月30日(火)09時23分9秒
  > No.1064[元記事へ]

SECONDさんがスレッド「複数ページ長編プログラム(新規投稿)」の「FFTプログラム」内で
 ビット反転
を紹介されています。(SUB IBrev 参照)
ビット反転は
・「各ビットの1と0を反転する」
・「ビット列の並びを反転(逆順に)する」 ※こちら
があります。

まず、提示されたプログラムを検証してみます。
LET m=4 !ビット数
LET N=2^m

!●ビット演算(排他的論理和、シフト)を四則演算に置き換える
LET j=0
FOR i=0 TO N-1 !※0~(N-1)の連続に限る

   PRINT i;BSTR$(i,2), j;BSTR$(j,2)

   LET k=N/2
   DO WHILE k<=j
      LET j=j-k
      LET k=k/2
   LOOP
   LET j=j+k

NEXT i

!●ビット演算(排他的論理和、シフト)による
LET j=0
FOR i=0 TO N-1 !※0~(N-1)の連続に限る

   PRINT i;BSTR$(i,2), j;BSTR$(j,2)

   !C言語 for(k=n>>1; k>(j^=k); k>>=1); の等価
   LET k=sft(N,-1) !k=n>>1
   DO
      LET j=bitxor(j,k) !j^=k
      !!!PRINT BSTR$(j,2) !debug
      IF k<=j THEN EXIT DO
      LET k=sft(k,-1) !k>>=1
   LOOP

NEXT i

END

EXTERNAL FUNCTION bitxor(a,b) !ビットごとの排他的論理和
LET c=0
FOR i=0 TO 31
   LET aa=MOD(a,2)
   LET a=(a-aa)/2
   LET bb=MOD(b,2)
   LET b=(b-bb)/2
   LET c=c+MOD(aa+bb,2)*2^i
NEXT i
IF c>=2^31 THEN LET c=c-2^32
LET bitxor=c
END FUNCTION

EXTERNAL FUNCTION sft(x,n) !nビットのシフトする ※nは整数
LET t=x*2^n
LET sft=IP(t)
!!!十進モードの場合、結果が期待にそわないLET sft=IP(x*2^n)
END FUNCTION
ビット演算で考えると、反転した状態で+1しているのが解ると思います。
一見何をしているか解りづらいですが、高速な手法です。

2進数の対称性を用いて反転の計算を減らすと、範囲 [0,N/4) で対が現れるので
LET m=4 !ビット数
LET N=2^m

LET n2=N/2
LET n1=n2+1
LET n4=n2/2
LET j=0
FOR i=0 TO n2-1 STEP 2 !0~N/4

!!!IF i<j THEN
   PRINT i;BSTR$(i,2), j;BSTR$(j,2)
   PRINT i+n1;BSTR$(i+n1,2), j+n1;BSTR$(j+n1,2)
   !!!END IF
   PRINT i+n2;BSTR$(i+n2,2), j+1;BSTR$(j+1,2)
   PRINT i+1;BSTR$(i+1,2), j+n2;BSTR$(j+n2,2) !!!

   LET k=n4
   DO WHILE k<=j
      LET j=j-k
      LET k=k/2
   LOOP
   LET j=j+k

NEXT i

END
1/3程度の短縮で交換ができます。


他の手法で、「ビット演算」と「そうでない」方法をいくつか考えてみると、、、
!ビット列の並びを逆順にする - ビット演算(論理積、論理和、シフト)による

LET m=4 !ビット数
LET N=2^m

!●その1
FOR i=0 TO N-1

   LET a=i

   LET x=0 !求める値
   FOR k=1 TO m
      LET x=bitor(sft(x,1),bitand(a,1)) !x=(x<<1)|(a&1)
      LET a=sft(a,-1) !a>>=1
   NEXT k

   PRINT i;BSTR$(i,2), x;BSTR$(x,2)

NEXT i

!●その2
FOR i=0 TO N-1

   LET x=i
   LET x=bitor( sft(bitand(x,BVAL("AAAAAAAA",16)),-1), sft(bitand(x,BVAL("55555555",16)),1) )
   LET x=bitor( sft(bitand(x,BVAL("CCCCCCCC",16)),-2), sft(bitand(x,BVAL("33333333",16)),2) )
   LET x=bitor( sft(bitand(x,BVAL("F0F0F0F0",16)),-4), sft(bitand(x,BVAL("0F0F0F0F",16)),4) )
   LET x=bitor( sft(bitand(x,BVAL("FF00FF00",16)),-8), sft(bitand(x,BVAL("00FF00FF",16)),8) )
   LET x=bitor(sft(x,-16),sft(x,16)) !FFFF0000,0000FFFF
   LET x=sft(x,-(32-m))

   PRINT i;BSTR$(i,2),
   IF x<0 THEN PRINT 2^m+x;BSTR$(2^m+x,2) ELSE PRINT x;BSTR$(x,2)

NEXT i

END

EXTERNAL FUNCTION bitand(a,b) !ビットごとの論理積
LET c=0 !値
FOR i=0 TO 31
   LET aa=MOD(a,2)
   LET a=(a-aa)/2
   LET bb=MOD(b,2)
   LET b=(b-bb)/2
   LET c=c+MIN(aa,bb)*2^i
NEXT i
IF c>=2^31 THEN LET c=c-2^32
LET bitand=c
END FUNCTION

EXTERNAL FUNCTION bitor(a,b) !ビットごとの論理和
LET c=0
FOR i=0 TO 31
   LET aa=MOD(a,2)
   LET a=(a-aa)/2
   LET bb=MOD(b,2)
   LET b=(b-bb)/2
   LET c=c+MAX(aa,bb)*2^i
NEXT i
IF c>=2^31 THEN LET c=c-2^32
LET bitor=c
END FUNCTION

EXTERNAL FUNCTION bitxor(a,b) !ビットごとの排他的論理和
LET c=0
FOR i=0 TO 31
   LET aa=MOD(a,2)
   LET a=(a-aa)/2
   LET bb=MOD(b,2)
   LET b=(b-bb)/2
   LET c=c+MOD(aa+bb,2)*2^i
NEXT i
IF c>=2^31 THEN LET c=c-2^32
LET bitxor=c
END FUNCTION

EXTERNAL FUNCTION sft(x,n) !nビットのシフトする ※nは整数
LET t=x*2^n
LET sft=IP(t)
!!!丸めによる結果が期待にそわないLET sft=IP(x*2^n)
END FUNCTION
1番目は一般的に発想しやすいですが、2番目は、、、

2番目は次のように置き換えるとピンとくると思います。
LET m=4 !ビット数
LET N=2^m

!●進数変換による
FOR i=0 TO N-1
   LET a=i

   LET x=0 !求める値
   FOR k=1 TO m !2進法への変換より
      LET aa=INT(a/2)
      LET x=x*2+(a-aa*2) !mod(a,2)
      LET a=aa
   NEXT k

   PRINT i;BSTR$(i,2), x;BSTR$(x,2)
NEXT i

!●交換による
FOR i=0 TO N-1

   LET j=rev_bit(i,m) !※mは偶数

   PRINT i;BSTR$(i,2), j;BSTR$(j,2)
NEXT i

FUNCTION rev_bit(nm,s) !分割して逆順にする ※sは偶数
   local low,high
   IF s>1 THEN
      LET s=s/2
      LET high=INT(nm/2^s) !上半分
      LET low=nm - high * 2^s !下半分 MOD(nm,2^s)
      LET nm=rev_bit(high,s) + rev_bit(low,s) * 2^s !逆順にする
   END IF
   LET rev_bit=nm
END FUNCTION

END

対比してみると、「アルゴリズム」の見通しがよくなります。
 

Re: 回帰式 その10

 投稿者:島村1243  投稿日:2010年 3月30日(火)09時23分55秒
  > No.1126[元記事へ]

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

> 島村1243さんへのお返事です。
> ---中省略---
> 島村1243さんの解釈どおり回帰式の係数をプログラムで求めています。
> ただ係数を出力することより、プログラムに組み込んで使用することを
> 想定しているのでそのようには作っていません。
> どうしても係数を見たいのならばFUNCTION 文の中で関数値を代入しているところ
> の係数をPRINT 文で出力してください。
> ---中省略---
> メインルーチン等の変数名とダブらないようにして下さい。

しばっちさん、ご教示有難うございます。
プログラム中の最初の説明行に書かれていたA,B,C..が係数だと思い込んでいたため理解
出来ずにいましたが、プログラム作成の主旨も良く分かりました。
 

多重window

 投稿者:N.E.  投稿日:2010年 3月30日(火)15時19分54秒
  描画画面を2つ以上出したいのですが、出来ますか?  

Re: 多重window

 投稿者:白石 和夫メール  投稿日:2010年 3月30日(火)16時17分31秒
  > No.1130[元記事へ]

> 描画画面を2つ以上出したいのですが、出来ますか?
できません。
描画画面を分割して使うことはできます。
http://www.geocities.jp/thinking_math_education/BASICHelp/html/basi8sc4.htm
また,BASIC自身を多重起動することはできます。
 

Re: 多重window

 投稿者:N.E.  投稿日:2010年 3月30日(火)16時36分59秒
  > No.1131[元記事へ]

白石 和夫さんへのお返事です。
> > 描画画面を2つ以上出したいのですが、出来ますか?
> できません。
> 描画画面を分割して使うことはできます。
> http://www.geocities.jp/thinking_math_education/BASICHelp/html/basi8sc4.htm
> また,BASIC自身を多重起動することはできます。

 > http://www.geocities.jp/thinking_math_education/BASICHelp/html/basi8sc4.htm
この例はどういう意味ですか。
ある1つのプログラムから、別のプログラムを開き、BASICを多重起動できませんか。
 

Re: 多重window

 投稿者:白石 和夫  投稿日:2010年 3月30日(火)16時46分10秒
  > No.1132[元記事へ]

> ある1つのプログラムから、別のプログラムを開き、BASICを多重起動できませんか。
BASICを多重起動する手法は,
http://www.geocities.jp/thinking_math_education/BASICHelp/html/basi6yjp.htm
にあります。
 

Re: 多重window

 投稿者:N.E.  投稿日:2010年 3月30日(火)17時19分29秒
  > No.1133[元記事へ]

白石 和夫さんへのお返事です。

ありがとうございました。
よく分かりました。
 

WIN32API利用の各種ダイアログの修正

 投稿者:N.E.  投稿日:2010年 3月30日(火)17時25分54秒
  http://hp.vector.co.jp/authors/VA008683/Dialogs.htm
には、
>これらの関数は,Win32APIのMessageBoxを利用して定義されているので,目的に応じて修正して使うことができます。 と書いてありますが、どのように修正するのですか。
教えてください。
 

Re: WIN32API利用の各種ダイアログの修正

 投稿者:白石 和夫  投稿日:2010年 3月30日(火)20時17分10秒
  > No.1141[元記事へ]

MSGBOX.LIB自体はただのテキストファイルです。
BASICのプログラム編集画面に読み込んで書き換えることが可能です。
十進BASICからWin32 APIを使う方法は
http://hp.vector.co.jp/authors/VA008683/ExtDLL.htm
を参照してください。
Win32 API自体の使い方は,MSDNで調べてください。
たとえば,
http://msdn.microsoft.com/ja-jp/library/cc410914.aspx
ただし,実際に使うためには,その関数を含むDLLの名称と,各定数の実際の数値を知る必要がありますが,それが一番面倒です。
 

Re: WIN32API利用の各種ダイアログの修正

 投稿者:N.E.  投稿日:2010年 3月30日(火)21時10分21秒
  > No.1142[元記事へ]

白石 和夫さんへのお返事です。

ありがとうございました。
大変そうなので、別の方法を考えます。
 

キーボードからの入力

 投稿者:N.E.  投稿日:2010年 3月30日(火)21時20分19秒
  キーボードから入力するためにはどのようにすればいいのでしょうか。
ヘルプ>入出力>独自の拡張(キーボード)

GetKeyState(n)ではなく、
フォアグラウンドの時のみ働き、キーコードを出力し、押されるまで待たない命令はありませんか。
教えてください。
 

Re: キーボードからの入力

 投稿者:白石 和夫  投稿日:2010年 3月30日(火)21時29分13秒
  > No.1144[元記事へ]

N.E.さんへのお返事です。

> キーボードから入力するためにはどのようにすればいいのでしょうか。
> ヘルプ>入出力>独自の拡張(キーボード)
> の
> GetKeyState(n)ではなく、
> フォアグラウンドの時のみ働き、キーコードを出力し、押されるまで待たない命令はありませんか。
> 教えてください。

CHARACTER INPUT NOWAIT が最も近いと思いますが,文字キー以外のキーには反応しません。
 

Re: キーボードからの入力

 投稿者:N.E.  投稿日:2010年 3月31日(水)10時30分23秒
  > No.1145[元記事へ]

白石 和夫さんへのお返事です。

> CHARACTER INPUT NOWAIT が最も近いと思いますが,文字キー以外のキーには反応しません。

文字キーとは、どのキーですか?
(スペース、エンターも含まれますか。)
 

Re: キーボードからの入力

 投稿者:N.E.  投稿日:2010年 3月31日(水)11時53分28秒
  > No.1146[元記事へ]

追加
なぜか結果が同じ文字2文字になってしまいます。
どうすればいいか教えて下さい。
 

使用できるもの

 投稿者:エンペラー  投稿日:2010年 3月31日(水)13時44分28秒
  専門的な話ではありませんが、初心者からの質問です。

・linux 版の十進BASICは、windows版と少し違うみたいですね。メニューも日本語ではないですし。今後linux 版の日本語バージョンは出ないのでしょうか?
・iphone や SonyPS3では、やろうと思っても出来ませんか?
 

Re: キーボードからの入力

 投稿者:白石 和夫  投稿日:2010年 3月31日(水)16時48分54秒
  > No.1147[元記事へ]

N.E.さんへのお返事です。

> 追加
> なぜか結果が同じ文字2文字になってしまいます。
> どうすればいいか教えて下さい。

SET ECHO "OFF"
を実行していないからだと思います。
 

Re: 使用できるもの

 投稿者:白石 和夫  投稿日:2010年 3月31日(水)16時55分57秒
  > No.1148[元記事へ]

エンペラーさんへのお返事です。

> 専門的な話ではありませんが、初心者からの質問です。
>
> ・linux 版の十進BASICは、windows版と少し違うみたいですね。メニューも日本語ではないですし。今後linux 版の日本語バージョンは出ないのでしょうか?
Windows版との完全な互換性はありませんが,Linux版には日本語版と英語版があります。
ただし,Ver. 0.4.9 は日本語版しかありません。

> ・iphone や SonyPS3では、やろうと思っても出来ませんか?
わかりません。それらのOSについて詳しいのであれば,移植に挑戦してください。
ただし,CPUがIntel x86系でなかったり,Lazarusが対応してなかったりしたら,そんなに簡単な話ではないと思います。
 

Re: キーボードからの入力

 投稿者:N.E.  投稿日:2010年 4月 1日(木)11時16分51秒
  > No.1149[元記事へ]

白石 和夫さんへのお返事です。

なぜか結果が同じ文字2文字になるのは、
> SET ECHO "OFF"
を実行すると、1文字だけになりました。
ありがとうございました。
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 4月 1日(木)13時03分18秒
  > No.1128[元記事へ]

資料の整理や分析は、EXCELなどのツールを使うことでできます。
実用的なリテラシー(利用技術)だと思いますが、あまり指導させていません。
簡単なデータを使って、BASICプログラムでその計算方法などを確認してみます。

線形回帰
 連立方程式を解く
!単回帰分析

!●回帰直線 Y=a*X+b、a=SLOPE(Y,X),b=INTERCEPT(Y,X)

PUBLIC NUMERIC N !データの数
LET N=5

DATA 1.8, 2.0 !X,Y
DATA 2.3, 3.7
DATA 4.1, 2.7
DATA 6.5, 4.5
DATA 5.2, 4.6

DIM X(N),Y(N) !データを読み込む
FOR i=1 TO N
   READ X(i),Y(i)
NEXT i


PRINT "Y =";SLOPE(Y,X);"* X +";INTERCEPT(Y,X)
PRINT USING "-#.##": FORECAST(3.5,Y,X) !3.29


SET WINDOW -1,10,-1,10 !グラフを描いてみる
DRAW grid
FOR i=1 TO N !データ
   PLOT POINTS: X(i),Y(i)
NEXT i

FOR t=-1 TO 10 STEP 0.1 !近似式
   PLOT LINES: t,FORECAST(t,Y,X);
NEXT t
PLOT LINES

!!※データが多い場合は、こちら
!!LET a=SLOPE(Y,X)
!!LET b=INTERCEPT(Y,X)
!!FOR t=-1 TO 10 STEP 0.1
!!   PLOT LINES: t,a*t+b;
!!NEXT t
!!PLOT LINES

END


!最小2乗法による
!
!残差平方和 S=Σ[i=1,n]{(Y[i]-(a*X[i]+b))^2} を最小にする係数を求める。
! ∂S/∂a = -2*Σ[i=1,n]{X([i]*(Y[i]-(a*X[i]+b))} = 0
! ∂S/∂b = -2*Σ[i=1,n]{Y[i]-(a*X[i]+b)} = 0
!次の連立方程式を得る。
! n*b + a*Σ[i=1,n]{x[i]} = Σ[i=1,n]{y[i]}
! b*Σ[i=1,n]{x[i]} + a*Σ[i=1,n]{x[i]^2} = Σ[i=1,n]{x[i]*y[i]}
!係数a,bについて解く。

EXTERNAL FUNCTION SLOPE(Y(),X()) !傾き
CALL inner_product(Y,X, sx,sy,sxy,sx2)
LET SLOPE=(N*sxy-sx*sy)/(N*sx2-sx*sx)
END FUNCTION

EXTERNAL SUB inner_product(Y(),X(), sx,sy,sxy,sx2) !Σの計算
DIM E(N) !{1,1,…,1} 内積の計算に用いる
MAT E=CON
LET sx=DOT(X,E) !Σ[i=1,n]{x[i]}
LET sy=DOT(Y,E) !Σ[i=1,n]{y[i]}
LET sxy=DOT(X,Y) !Σ[i=1,n]{x[i]*y[i]}
LET sx2=DOT(X,X) !Σ[i=1,n]{x[i]*x[i]}
END SUB

EXTERNAL FUNCTION INTERCEPT(Y(),X()) !切片
CALL inner_product(Y,X, sx,sy,sxy,sx2)
LET INTERCEPT=(sy*sx2-sx*sxy)/(N*sx2-sx*sx)
END FUNCTION

EXTERNAL FUNCTION FORECAST(T,Y(),X()) !予測値を求める
LET A=SLOPE(Y,X)
LET B=INTERCEPT(Y,X)
LET FORECAST=A*T+B
END FUNCTION

非線形回帰
 線形回帰に置き換える
!●回帰式 Y=b*EXP(a*X)
! 両辺に対数をとって、線形回帰式に変形する。
! LOG(Y)=LOG(b)+a*X → Y'=b'+a*X → Y=EXP(Y')

PUBLIC NUMERIC N !データの数
LET N=5

DATA 1.8, 2.0 !X,Y
DATA 2.3, 3.7
DATA 4.1, 2.7
DATA 6.5, 4.5
DATA 5.2, 4.6

DIM X(N),Y(N) !データを読み込む
FOR i=1 TO N
   READ X(i),Y(i)
NEXT i


DIM LogY(N) !Y'
FOR i=1 TO N
   LET LogY(i)=LOG(Y(i))
NEXT i

PRINT "Y =";EXP( INTERCEPT(LogY,X) );"* EXP(";SLOPE(LogY,X);"* X )"

SET WINDOW -1,10,-1,10 !グラフを描いてみる
DRAW grid
FOR i=1 TO N !データ
   PLOT POINTS: X(i),Y(i)
NEXT i

FOR t=-1 TO 10 STEP 0.1 !近似式
   PLOT LINES: t,EXP( FORECAST(t,LogY,X) );
   !!PLOT LINES: t,EXP(INTERCEPT(LogY,X))*EXP(SLOPE(LogY,X)*t);
NEXT t
PLOT LINES

END
※外部手続きや関数は共通のため省略。上記をコピーしてください。


同様に、変数が多い場合
!重回帰分析 - 重回帰式 Y=a*X1+b*X2+ … +c*Xp+d

!●重回帰式 Y=0.8161*X1-0.2749*X2+1.055*X3+2.504

PUBLIC NUMERIC P,N
LET P=3 !変数の数
LET N=8 !データの数

DATA 8,4,8,18 !X1,X2,X3,Y
DATA 7,7,7,12
DATA 5,8,9,14
DATA 4,3,3,6
DATA 6,8,8,12
DATA 2,5,3,8
DATA 3,6,6,10
DATA 9,9,7,16

DIM X(N,P+1),Y(N) !データを読み込む
FOR i=1 TO N
   FOR j=1 TO P
      READ X(i,j+1) !Xp
   NEXT j
   LET X(i,1)=1

   READ Y(i) !Y
NEXT i

DIM C(P+1)
CALL LINEST(Y,X, C) !係数
MAT PRINT C;

DIM t(P) !X1,X2,X3
DATA 5,8,9
MAT READ t
PRINT FORECAST(t,Y,X) !予測値

END


!最小2乗法による
!
!残差平方和 S=Σ[i=1,n]{(Y[i]-(a*X1+b*X2+ … +c*Xp+d))^2} を最小にする係数を求める。
!偏微分(∂S/∂a、∂S/∂bなど)して、連立方程式を得る。
! ┌ Σ1*1  Σ1*X1  Σ1*X2  … Σ1*Xp  ┐┌ d ┐=┌ Σ1*Y  ┐
! │ ΣX1*1 ΣX1*X1 ΣX1*X2 … ΣX1*Xp ││ a │ │ ΣX1*Y │
! │ ΣX2*1 ΣX1*X2 ΣX2*X2 … ΣX2*Xp ││ b │ │ ΣX2*Y │
!       :        :    :    :
! └ ΣXp*1 ΣXp*X1 ΣXp*X2 … ΣXp*Xp ┘└ c ┘ └ ΣXp*Y ┘

EXTERNAL SUB LINEST(Y(),X(,), t()) !係数を返す
DIM W(P+1,N) !内積の計算に用いる
MAT W=TRN(X)
DIM A(P+1,P+1),b(P+1) !連立方程式 A*t=b
MAT A=W*X !左辺 A
MAT b=W*Y !右辺 b
!!!MAT PRINT A; !debug
!!!MAT PRINT b;

DIM iA(P+1,P+1) !連立方程式を解く
MAT iA=INV(A)
MAT t=iA*b !求める係数
!!!MAT PRINT t; !debug
END SUB

EXTERNAL FUNCTION FORECAST(T(),Y(),X(,)) !予測値を求める
DIM C(P+1)
CALL LINEST(Y,X, C)
LET s=C(1) !Y=a*X1+b*X2+ … +c*Xp+d
FOR i=2 TO P+1
   LET s=s+T(i-1)*C(i)
NEXT i
LET FORECAST=s
END FUNCTION

同様に、非線形の例
!●ロジスティック回帰モデル Y = 1 / ( 1 + EXP(b+a*X) )

PUBLIC NUMERIC P,N
LET P=1 !変数の数
LET N=8 !データの数

DATA 5.42, 0.05 !X,Y
DATA 5.61, 0.18
DATA 5.78, 0.25
DATA 5.95, 0.47
DATA 6.12, 0.82
DATA 6.28, 0.89
DATA 6.43, 0.98
DATA 6.58, 1.00

DIM XX(N,P+1),YY(N) !データを読み込む
FOR i=1 TO N
   READ XX(i,2) !Xp
   LET XX(i,1)=1

   READ YY(i) !Y
NEXT i

!線形回帰式に変形する。LOG(1/Y-1)=b+a*X → Y'=b+a*X → Y=1/(1+EXP(Y'))
DIM LogYY(N)
FOR i=1 TO N
   IF YY(i)=1 THEN
      LET LogYY(i)=-5 !※
   ELSE
      LET LogYY(i)=LOG(1/YY(i)-1)
   END IF
NEXT i

DIM C(P+1) !係数
CALL LINEST(logYY,XX, C)
MAT PRINT C;

SET WINDOW 5,7,-0.2,1.2 !グラフを描いてみる
DRAW grid(0.5,0.25)
FOR i=1 TO N !データ
   PLOT POINTS: XX(i,2),YY(i)
NEXT i

DIM t(1) !X1
FOR i=5 TO 7 STEP 0.1 !近似式
   LET t(1)=i
   PLOT LINES: i,1/(1+EXP( FORECAST(t,LogYY,XX) ));
NEXT i
PLOT LINES

END
※外部手続きや関数は共通のため省略。
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 4月 3日(土)09時06分3秒
  > No.1152[元記事へ]

別解 偏差平方和・積和行列による
!重回帰分析 - 重回帰式 Y=a0+a1*X1+a2*X2+a3*X3+ … +ap*Xp

!多項式モデル Y=a+b*X+c*X^2+d*X^3 → Y=a+b*X1+c*X2+d*X3 と置き換える

PUBLIC NUMERIC P,N
LET P=3 !変数の数
LET N=11 !データの数

DATA 0, 0 !X,Y
DATA 0.1, 0.1002
DATA 0.2, 0.2013
DATA 0.3, 0.3045
DATA 0.4, 0.4108
DATA 0.5, 0.5211
DATA 0.6, 0.6367
DATA 0.7, 0.7586
DATA 0.8, 0.8881
DATA 0.9, 1.0265
DATA 1, 1.1752

DIM X(N,P),Y(N) !データを読み込む
FOR i=1 TO N
   READ w
   LET X(i,1)=w ![X1,X2,X3]
   LET X(i,2)=w^2
   LET X(i,3)=w^3

   READ Y(i) !Y
NEXT i

DIM C(P+1) !係数
CALL LINEST(Y,X,C)
MAT PRINT C; !Y=a+b*X+c*X^2


SET WINDOW -0.1,1.2, -0.1,1.2 !グラフを描いてみる
DRAW grid
FOR i=1 TO N !データ
   PLOT POINTS: X(i,1),Y(i)
NEXT i
DIM t(P)
FOR i=0 TO 12 STEP 0.1 !近似式
   LET t(1)=i !X1
   LET t(2)=i^2 !X2
   LET t(3)=i^3 !X2
   PLOT LINES: i,FORECAST(t,Y,X);
NEXT i
PLOT LINES

END


!偏差平方和・積和行列による

!偏差平方和・積和 Sij=Σ[k=1,n]{(Xi[k]-AXi))*(Xj[k]-AXj))}
!偏差積和 Siy=Σ[k=1,n]{(Xi[k]-AXi)*(Y[k]-AY)}
!ただし、平均 AXi=( Σ[k=1,n]{(Xi[k])} )/n、AY=( Σ[k=1,n]{(Y[k])} )/n とする。
! ┌ S11 S12 S13 … S1p ┐┌ a1 ┐=┌ S1y ┐
! │ S21 S22 S23 … S2p ││ a2 │ │ S2y │
! │ S31 S32 S33 … S3p ││ a3 │ │ S3y │
!       :      :   :
! └ Sp1 Sp2 Sp3 … Spp ┘└ ap ┘ └ Spy ┘

EXTERNAL SUB LINEST(Y(),X(,), t()) !係数を返す
DIM SUMX(P) !ΣXi
FOR i=1 TO P
   LET s=0
   FOR k=1 TO N
      LET s=s+X(k,i)
   NEXT k
   LET SUMX(i)=s
NEXT i
!!!MAT PRINT SUMX; !debug

LET SUMY=0 !ΣYi
FOR k=1 TO N
   LET SUMY=SUMY+Y(k)
NEXT k
!!!PRINT SUMY !debug

DIM A(P,P),w(P),b(P) !連立方程式 A*w=b
FOR i=1 TO P !左辺 A
   FOR j=i TO P
      LET s=0 !ΣXi*Xj
      FOR k=1 TO N
         LET s=s+X(k,i)*X(k,j)
      NEXT k
      LET s=s-SUMX(i)*SUMX(j)/N !Σ(Xi-AXi)(Xj-AXj)=ΣXi*Xj-(ΣXi*ΣXj)/Nより

      LET A(i,j)=s
      IF i<>j THEN LET A(j,i)=s !対称
   NEXT j
NEXT i
!!!MAT PRINT A; !debug

FOR i=1 TO P !右辺 b
   LET s=0 !ΣXi*Y
   FOR k=1 TO N
      LET s=s+X(k,i)*Y(k)
   NEXT k
   LET b(i)=s-SUMX(i)*SUMY/N
NEXT i
!!!MAT PRINT b; !debug

DIM iA(P,P) !連立方程式を解く
MAT iA=INV(A)
MAT w=iA*b !求める係数 a1,a2,a3,…,ap
FOR i=1 TO P !copy it
   LET t(i+1)=w(i)
NEXT i

LET s=SUMY !求める係数 a0=AY-(a1*AX1+a2*AX2+a3*AX3+ … +ap*AXp)
FOR i=1 TO P
   LET s=s-w(i)*SUMX(i)
NEXT i
LET t(1)=s/N
!!!MAT PRINT t; !debug
END SUB


EXTERNAL FUNCTION FORECAST(T(),Y(),X(,)) !予測値を求める
DIM C(P+1)
CALL LINEST(Y,X, C)
LET s=C(1)
FOR i=2 TO P+1
   LET s=s+T(i-1)*C(i)
NEXT i
LET FORECAST=s
END FUNCTION
 

準モンテカルロ法

 投稿者:S.S  投稿日:2010年 4月 6日(火)13時09分16秒
  モンテカルロ法で定積分の値を(例えば被積分関数y=x^2,積分範囲0<=x<=1)
求めることはできるのですが同じことを準モンテカルロ法で行う場合はどんな
プログラムを組めばいいのでしょうか。急ぎませんので暇があれば
ご回答くだされば助かります。
 

Re: 準モンテカルロ法

 投稿者:山中和義  投稿日:2010年 4月 6日(火)16時32分24秒
  > No.1154[元記事へ]

S.Sさんへのお返事です。

> モンテカルロ法で定積分の値を(例えば被積分関数y=x^2,積分範囲0<=x<=1)
> 求めることはできるのですが同じことを準モンテカルロ法で行う場合はどんな
> プログラムを組めばいいのでしょうか。
!準モンテカルロ法 ∫[0,1]f(x)dx=1/N*Σ[i=1,N]f(xi)

DEF f(x)=x^2 !被積分関数 1/3

LET ITER=1000 !発生個数

LET UINT_MAX=2^32-1 !4294967295UL
LET s=0
FOR n=0 TO ITER-1
   LET g2n=0 !超一様分布列 ヴァンデルコープット列(van der Corput)
   FOR i=0 TO 30
      LET g2n=(g2n+REMAINDER(r_sft(n,i),2))*2
   NEXT i
   IF REMAINDER(r_sft(n,31),2)=1 THEN LET g2n=g2n+1

   LET x=g2n/(UINT_MAX+1) !区間[0,1)={0,1/2,1/4,3/4,1/8,5/8,3/8,7/8,1/16,9/16,5/16,13/16,…}
   !!!PRINT x !debug

   LET s=s+f(x) !Σf
   PRINT s/(n+1)
NEXT n
!PRINT s/ITER !結果を表示する

FUNCTION r_sft(n,i) !C言語 n>>i 等価
   LET r_sft=IP(n/2^i)
END FUNCTION

END

ヴァンデルコープット列の生成は、こちらの方が分かりやすいと思います。
!準モンテカルロ法 ∫[0,1]f(x)dx=1/N*Σ[i=1,N]f(xi)

DEF f(x)=x^2 !被積分関数 1/3

LET ITER=1000 !発生個数

LET UINT_MAX=2^32-1 !4294967295UL ※32bit
LET s=0
FOR n=0 TO ITER-1
   LET g2n=0 !超一様分布列 ヴァンデルコープット列(van der Corput)
   LET a=n
   FOR i=1 TO 32 !2進法への変換より、ビット列の並びを反転(逆順に)する
      LET aa=INT(a/2)
      LET g2n=g2n*2+(a-aa*2) !下位桁を上位桁へ
      LET a=aa
   NEXT i
   !!!PRINT n;g2n,right$(REPEAT$("0",32)&BSTR$(g2n,2),32) !debug

   LET x=g2n/(UINT_MAX+1) !区間[0,1)={0,1/2,1/4,3/4,1/8,5/8,3/8,7/8,1/16,9/16,5/16,13/16,…}
   !!!PRINT x !debug

   LET s=s+f(x) !Σf
   !PRINT s/(n+1)
NEXT n
PRINT s/ITER !結果を表示する

END

参考 モンテカルロ法による数値積分 No.31 [元記事へ]
 

Re: 準モンテカルロ法

 投稿者:S.S  投稿日:2010年 4月 7日(水)11時21分23秒
  > No.1155[元記事へ]

山中和義さんへのお返事です。
お忙しい中、早速のご回答ありがとうございました。
大変助かりました。
 

擬素数

 投稿者:永野護  投稿日:2010年 4月 7日(水)11時58分3秒
  2を底とする擬素数を求めよ、という問題です。

定義:ある合成数nがaを底とするフェルマーテストを通るときnをaを底とする擬素数とよぶ。
フェルマーテスト:a^(n-1)<>1 (mod n) であればnは合成数である。(ただしaとnは互いに素)。


次のようなプログラムを書きましたが結果がうまくでません。どこが間違っているのでしょうか。
ご多忙の折まことに恐縮でございますが
ご教示のほどよろしくお願いいたします。(正解は341, 561, 645 らしいです。)

FOR  n=4  TO     1000     REM  2を底とする擬素数を4から1000までの範囲で求める。
IF    MOD(n,2)=0   THEN   GOTO    100    REM  nが2で割り切れる、すなわちnとaが互いに素で
!      なければ次のnへ行く。
IF  MOD(2^(n-1)-1,n)<>0    THEN   PRINT  n      REM フェルマーテスト
100
NEXT  n
END
 

Re: 擬素数

 投稿者:山中和義  投稿日:2010年 4月 7日(水)13時32分5秒
  > No.1157[元記事へ]

永野護さんへのお返事です。

> 2を底とする擬素数を求めよ、という問題です。
> 次のようなプログラムを書きましたが結果がうまくでません。どこが間違っているのでしょうか。

フェルマーテストが間違っていると思います。
OPTION ARITHMETIC RATIONAL !有理数モード(多桁整数)

LET a=2
FOR n=2 TO 1000
   IF GCD(a,n)=1 THEN !aとnは互いに素
      IF MOD(a^(n-1),n)<>1 THEN !フェルマーテスト
      !合成数
      ELSE
         IF PrimeQ(n)=0 THEN PRINT "擬素数=";
         PRINT n
      END IF
   END IF
NEXT n

END

EXTERNAL FUNCTION PrimeQ(n) !素数判定 1:素数、0:素数でない
OPTION ARITHMETIC RATIONAL !有理数モード(多桁整数)
LET PrimeQ=0
IF n<2 OR n<>INT(n) THEN EXIT FUNCTION !引数を確認する
!2以上の自然数なら
IF MOD(n,2)=0 THEN !偶数なら
   IF n=2 THEN LET PrimeQ=1 !2は素数
ELSE !奇数なら
   LET k=3
   DO WHILE k*k<=n !3~√nの奇数のみで検証する
      IF MOD(n,k)=0 THEN EXIT FUNCTION !ひとつでも割り切れるものがあれば素数でない
      LET k=k+2
   LOOP
   LET PrimeQ=1 !最後まで割り切れなければ、素数である
END IF
END FUNCTION
 

Re: 擬素数

 投稿者:永野護  投稿日:2010年 4月 7日(水)14時43分33秒
  > No.1158[元記事へ]

山中和義様へのお返事です。
ご多忙の折、早速のご回答ありがとうございました。
丁寧なプログラムに感謝いたします。
なお質問文に一部記述のみだれたところがありました事をお詫びします。
 

報告(その2)

 投稿者:N.E.  投稿日:2010年 4月 7日(水)21時25分21秒
  DO
   GET POINT: a,b
   IF a>9 AND a<247 THEN
      LET c=1
      IF b>29 AND b<61 THEN
         LET c=2
         beep
         pause "通常は形式を1にして下さい。"
      ELSEIF b>59 AND b<91 THEN
         LET c=3
         beep
         pause "通常は形式を1にして下さい。"
      ELSEIF b>89 AND b<121 THEN
         LET c=4
         beep
         pause "通常は形式を1にして下さい。"
         !ELSEIF c>0 AND d>0 AND
      ELSE
         ASK PIXEL VALUE (a,b)e
         IF e=2 AND a<80 THEN
            LET d=d-1
         ELSEIF e=2 AND a>80 THEN
            LET d=d+1
         END IF
         IF d=0 THEN
            LET d=1
            beep
            pause  "これ以上細くすることは出来ません。"
         ELSEIF e=2 AND d>2 THEN
            beep
            pause "通常は太さを2以下にして下さい。"
            IF d=41 THEN
               LET d=40
               pause "これ以上太くすることは出来ません。"
            END IF
         END IF
      END IF
   END IF
   IF c>0 AND d>0 THEN
      SET LINE STYLE c
      SET LINE WIDTH d
      PLOT LINES: 30,260;226,260
      PLOT TEXT,AT  10,300:"現在のイメージに変更するには、"
      PLOT TEXT,AT  10,320:"右下の「OK」を押して下さい。"
      PLOT TEXT,AT  10,350:"現在の形式(STYLE)は"&STR$(c)&"、"
      PLOT TEXT,AT  10,370:"太さ(WIDTH)は"&STR$(d)&"です。"
      PLOT AREA:170,330;240,330;240,370;170,370
      SET TEXT HEIGHT 25
      PLOT TEXT,AT  190,367:"OK"
      SET TEXT HEIGHT 11
   END IF LOOP END
 

報告(その1)

 投稿者:N.E.  投稿日:2010年 4月 7日(水)21時25分24秒
 

version7.3.3でバグ発見以下のプログラムで文字の色が勝手に白になる(書いてないかも)

・概要

   ・SET TEXT HEIGHT の後、 SET WINDOW を使うと、変になる

   ・高さを変えなければ普通のまま

・初期設定と同じ文字サイズにするために、SET TEXT HEIGHT を使った。
 SET TEXT HEIGHTをSET WINDOW の前に入れると、文字の色が白くなる
 SET WINDOW の後、SET TEXT HEIGHTを使うと、元に戻る
 SET BITMAP SIZE を使っても元に戻る(ただし、またSET WINDOW を使う必要がある)

(絵を書くための設定変更のプログラム)

・以下のプログラムを実行するとバグになる

・(SET WINDOW )の直後に
 SET TEXT HEIGHT 11
 実行すると成功する

・画像は上から失敗、成功

SET TEXT HEIGHT 11
SET BITMAP SIZE 256,380
SET WINDOW 1,256,380,1
FOR a=0TO 3
   SET LINE STYLE a+1
   FOR b=0TO 3
      SET LINE WIDTH b+1
      IF b>1 THEN LET b=b-1.9
      PLOT LINES: 20+IP(b)*116,40+MOD(b*10,10)*10+a*30;120+IP(b)*116,40+MOD(b*10,10)*10+a*30
      IF b>IP(b) THEN LET b=b+1.9
   NEXT  B
   SET LINE STYLE 1
   SET LINE WIDTH 1
   PLOT LINES: 10,60+a*30;246,60+a*30
NEXT  A
SET AREA STYLE "hollow"
PLOT AREA:10,30;246,30;246,150;10,150
!PLOT AREA:10,175;65,175;65,210;10,210
!PLOT AREA:100,175;155,175;155,210;100,210
PLOT TEXT,AT  10,20:"形式を以下の中から選んで下さい。"
PLOT TEXT,AT  10,170 :"太さを選んで下さい。"
PLOT TEXT,AT  35,200 :"細く      太く"
SET AREA COLOR 2
SET AREA STYLE "solid"
PLOT AREA:20,192;30,182;30,202
PLOT AREA:145,192;135,182;135,202
PLOT TEXT,AT 10,230:"イメージ"
LET c=1
LET d=40
SET AREA STYLE "hollow"
SET AREA COLOR 1
 

 

Re: 擬素数

 投稿者:SECOND  投稿日:2010年 4月 8日(木)15時16分59秒
  > No.1157[元記事へ]

永野護さんへのお返事です。

!ご参考に。下記を、走らせてみてください。
!※素数判定は、速度に余裕が大きく仮なので、別途ご研究下さい。
!
!※「a が n の倍数でない」「a と n が互いに素」を区別しない説明サイトが目立ちます。
!◆フェルマーの小定理
!
! n が素数なら、n の倍数でない整数 a で、mod( a^(n-1), n)=1 を満たす。
!
! しかし、逆に、上の条件と式を満たす n は素数だけでなく、余計がある。
! その余計を、擬素数とよぶ。(素数でないが、それに準ずる意。)
!--------------------------------------------------------------------

OPTION ARITHMETIC RATIONAL !有理数モード
PRINT " a:  素数でないnで、mod(a^(n-1),n)=1 のn"
PRINT "↓: ---------------------------------------"
FOR a=2 TO 15              ! a=11~15 は、有理数モードでないと1000 桁でもオーバーフロー。
   PRINT USING "##:":a;
   !!FOR n=4 TO 1000         !(偶数奇数の両方)走査するnは、素数 が対象外なので、最小値4から~1000
   FOR n=5 TO 1000 STEP 2  !(奇数のみ)最小5から・・・ 下表と比較するとき。
      IF 0< MOD(a,n) AND MOD(a^(n-1),n)=1 AND 1< Pri(n) THEN PRINT USING "####":n;  !素数でないnのみ表示。
   NEXT n
   PRINT
NEXT a

FUNCTION Pri(n)
   FOR i=CEIL(n/2) TO 2 STEP -1
      IF MOD(n,i)=0 THEN EXIT FOR
   NEXT i
   LET Pri=i  !素数は i=1 まで下がる。
END FUNCTION

END  !※上のプログラムで出来た表から、奇数のnだけを見れば下表に一致します。

!以下は、http://mitv2.net/python/prime2.html から転載。

!表1. 1000 以下の奇数の擬素数と,それが 1000 以下の奇数の合成数に占める割合
!  底 1000 以下の奇数の擬素数 割合
!   2  341, 561, 645 0.9%
!   3   91, 121, 671, 703, 949 1.5%
!   4   15,  85, 91, 341, 435, 451, 561, 645, 703 2.7%
!   5  217, 561, 781 0.9%
!   6   35, 185, 217, 301, 481 1.5%
!   7   25, 325, 561, 703, 817 1.5%
!   8    9,  21, 45, 63, 65, 105, 117, 133, 153, 231, 273,
!        341, 481, 511, 561, 585, 645, 651, 861, 949 6.0%
!   9   91, 121, 205, 511, 671, 697, 703, 949 2.4%
!  10    9, 33, 91, 99, 259, 451, 481, 561, 657, 703, 909 3.3%
!  11   15, 133, 259, 305, 481, 645, 703, 793 2.4%
!  12   65, 91, 133, 143, 145, 247, 377, 385, 703 2.7%
!  13   21, 85, 105, 231, 357, 427, 561 2.1%
!  14   15, 39, 65, 195, 481, 561, 781, 793, 841, 985 3.0%
!  15  341 0.3%
 

Re: 報告(その1)

 投稿者:N.E.  投稿日:2010年 4月 8日(木)18時22分2秒
  > No.1161[元記事へ]

追加

全体のはじめの座標を元に決めているかもしれません。
ASK TEXT COLOR はどうなるかも試してみます。
 

Re: 報告(その1)

 投稿者:白石 和夫メール  投稿日:2010年 4月 9日(金)08時47分10秒
  > No.1163[元記事へ]

SET TEXT HEIGHTは,その文が実行されたときの座標系に基づいてフォントサイズを選択しています。
規格では,
「設定された文字寸法が現在の視野変形によって基準装置座標に写像され,その要求された高さを超えない最大寸法の機械文字集合が選択される」
となっています。
「現在」がSET TEXT HEIGHTの実行時を意味するのであれば現在の動作が正しく,「現在」がPLOT TEXT文の実行時を意味するとしたら現在の動作は誤りです。
どちらが正しいか即断できないので,とりあえず,SET WINDOW文を実行したらTEXT HEIGHTを再設定するようにプログラムを書いておいてください。そうすれば,どちらの場合でも正しく動作します。
 

カーマイケル数

 投稿者:永野護  投稿日:2010年 4月 9日(金)12時57分46秒
  山中様、SECOND様、丁寧な回答ありがとうございました。
教えていただきましたプログラムを参考にして擬素数をみつけることができました。
両氏のお忙しいところ、まことに申し訳ないのですが、今度はカーマイケル数
の場合はどのようなプログラムにすればよいのか教えていただけないでしょうか。
十進BASICでできるのでしょうか。もし暇な時間があるようでしたら、よろしくお願いします。
 

Re: カーマイケル数

 投稿者:山中和義  投稿日:2010年 4月 9日(金)13時57分47秒
  > No.1165[元記事へ]

永野護さんへのお返事です。

> カーマイケル数の場合はどのようなプログラムにすればよいのか教えていただけないでしょうか。

前回の延長線では
!カーマイケル数

OPTION ARITHMETIC RATIONAL !有理数モード(多桁整数)

LET M=10000 !検索範囲

FOR n=2 TO M
   IF PrimeQ(n)=0 THEN !合成数nが

      FOR a=2 TO n-1 !底
         IF GCD(a,n)=1 THEN !自身と互いに素である任意の自然数aに対して
            IF MOD(a^(n-1),n)<>1 THEN EXIT FOR !a^(n-1)≡1 mod n を満たす
         END IF
      NEXT a
      IF a=n THEN PRINT n !最後までなら

   END IF
NEXT n

END

EXTERNAL FUNCTION PrimeQ(n) !素数判定 1:素数、0:素数でない
OPTION ARITHMETIC RATIONAL !有理数モード(多桁整数)
LET PrimeQ=0
IF n<2 OR n<>INT(n) THEN EXIT FUNCTION !引数を確認する
!2以上の自然数なら
IF MOD(n,2)=0 THEN !偶数なら
   IF n=2 THEN LET PrimeQ=1 !2は素数
ELSE !奇数なら
   LET k=3
   DO WHILE k*k<=n !3~√nの奇数のみで検証する
      IF MOD(n,k)=0 THEN EXIT FUNCTION !ひとつでも割り切れるものがあれば素数でない
      LET k=k+2
   LOOP
   LET PrimeQ=1 !最後まで割り切れなければ、素数である
END IF
END FUNCTION

となりますが、多桁整数の計算のため時間を要します。

十進モードや2進モードで高速に計算するには、
関数GCDの定義とa^(n-1)のオーバーフロー対策をプログラムする必要があります。
!カーマイケル数

LET M=10000 !検索範囲

FOR n=2 TO M
   IF PrimeQ(n)=0 THEN !合成数nが

      FOR a=2 TO n-1 !底
         IF GCD(a,n)=1 THEN !自身と互いに素である任意の自然数aに対して
            IF modpow(a,n-1,n)<>1 THEN EXIT FOR !a^(n-1)≡1 mod n を満たす
         END IF
      NEXT a
      IF a=n THEN PRINT n !最後までなら

   END IF
NEXT n

END

EXTERNAL FUNCTION PrimeQ(n) !素数判定 1:素数、0:素数でない
LET PrimeQ=0
IF n<2 OR n<>INT(n) THEN EXIT FUNCTION !引数を確認する
!2以上の自然数なら
IF MOD(n,2)=0 THEN !偶数なら
   IF n=2 THEN LET PrimeQ=1 !2は素数
ELSE !奇数なら
   LET k=3
   DO WHILE k*k<=n !3~√nの奇数のみで検証する
      IF MOD(n,k)=0 THEN EXIT FUNCTION !ひとつでも割り切れるものがあれば素数でない
      LET k=k+2
   LOOP
   LET PrimeQ=1 !最後まで割り切れなければ、素数である
END IF
END FUNCTION

EXTERNAL FUNCTION modpow(a,n,b) !a^n≡x mod b のxを返す ※nは非負整数
LET S=MOD(1,b)
DO WHILE n>0 !べき乗nを2進展開する
   IF MOD(n,2)=1 THEN LET S=MOD(S*a,b) !ビットが1なら計算する
   LET a=MOD(a*a,b)
   LET n=INT(n/2)
LOOP
LET modpow=S
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
 

Re: カーマイケル数

 投稿者:永野護  投稿日:2010年 4月 9日(金)14時41分20秒
  > No.1166[元記事へ]

山中和義様、お忙しい中、度重なるご回答ありがとうございました。
大変参考になりました。
敬具
 

Re: カーマイケル数

 投稿者:山中和義  投稿日:2010年 4月 9日(金)20時27分8秒
  > No.1165[元記事へ]

永野護さんへのお返事です。

別解 カーマイケルのλ関数でカーマイケル数を求める
FOR n=1 TO 10000
   IF PrimeQ(n)=0 AND MOD(n,carmichaelLambda(n))=1 THEN PRINT n
NEXT n

END


EXTERNAL FUNCTION PrimeQ(n) !素数判定 1:素数、0:素数でない
LET PrimeQ=0
IF n<2 OR n<>INT(n) THEN EXIT FUNCTION !引数を確認する
!2以上の自然数なら
IF MOD(n,2)=0 THEN !偶数なら
   IF n=2 THEN LET PrimeQ=1 !2は素数
ELSE !奇数なら
   LET k=3
   DO WHILE k*k<=n !3~√nの奇数のみで検証する
      IF MOD(n,k)=0 THEN EXIT FUNCTION !ひとつでも割り切れるものがあれば素数でない
      LET k=k+2
   LOOP
   LET PrimeQ=1 !最後まで割り切れなければ、素数である
END IF
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 carmichaelLambda(n) !カーマイケルのλ関数
!与えられた数nに対し、a^m ≡ 1 (mod n) が
!任意のnと互いに素なaについて成立するような最小のmを返す。
LET ans=1
IF MOD(n,8)=0 THEN LET n=n/2
FOR d=2 TO n
   IF MOD(n,d)=0 THEN
      LET y=d-1
      LET n=INT(n/d)
      DO WHILE MOD(n,d)=0
         LET n=INT(n/d)
         LET y=y*d
      LOOP
      LET ans=lcm(ans,y)
   END IF
NEXT d
LET carmichaelLambda=ans
END FUNCTION
 

2つの順列のある関係について

 投稿者:GAI  投稿日:2010年 4月10日(土)06時47分13秒
  2つの次の順列P1、P2において、おもしろい関係が成立する。

P1=(3,8,5,10,9,4,6,1,7,2)

P2=(8,10,1,6,3,7,9,2,5,4)

<関係>
P1の数"3"は"1"番目にあるが、P2では"3"番目が"1"の数である。
P2の数"8"は"1"番目にあるが、P1では"8"番目が"1"の数である。

P1の数"8"は"2"番目にあるが、P2では"8"番目が"2"の数である。
P2の数"10"は"2"番目にあるが、P1では"10"番目が"2"の数である。

P1の数"5"は"3"番目にあるが、P2では"5"番目が"3"の数である。
P2の数"1"は"3"番目にあるが、P1では"1"番目が"3"の数である。

・・・・・・
・・・・・・

P1の数"2"は"10"番目にあるが、P2では"2"番目が"10"の数である。
P2の数"4"は"10"番目にあるが、P1では"4"番目が"10"の数である。


この関係を上手く利用したら、なにか面白いパズルやマジックが作れそうな気がする。


また、この関係について調べていたら
要素が例えば4つの場合に
全順列が4!=24通りある中で、次の10個
(1,2,3,4)
(1,2,4,3)
(1,3,2,4)
(1,4,3,2)
(2,1,3,4)
(2,1,4,3)
(3,2,1,4)
(3,4,1,2)
(4,2,3,1)
(4,3,2,1)
をP1としてとったとき、例の関係を満たすようにするP2が全く同じものになりました。

そこで一般に要素がn個のとき、これらが何個あるのかが気になってきます。
どなたか、n個の順列には例の関係をみたしながら、しかも元の順列と全く同じものになるものが何通りあるのかを調べて頂きたい。
 

Re: 2つの順列のある関係について

 投稿者:山中和義  投稿日:2010年 4月10日(土)11時05分26秒
  > No.1169[元記事へ]

GAIさんへのお返事です。

> 要素が例えば4つの場合に
> 全順列が4!=24通りある中で、次の10個
> (1,2,3,4)
> (1,2,4,3)
> (1,3,2,4)
> (1,4,3,2)
> (2,1,3,4)
> (2,1,4,3)
> (3,2,1,4)
> (3,4,1,2)
> (4,2,3,1)
> (4,3,2,1)
> をP1としてとったとき、例の関係を満たすようにするP2が全く同じものになりました。

N=4の場合、条件を満たすものを置換および巡回置換で表現すると

┌  1  2  3  4 ┐
└  1  2  3  4 ┘
=( 1 )( 2 )( 3 )( 4 )

┌  1  2  3  4 ┐
└  1  2  4  3 ┘
=( 1 )( 2 )( 3  4 )

┌  1  2  3  4 ┐
└  1  3  2  4 ┘
=( 1 )( 2  3 )( 4 )

┌  1  2  3  4 ┐
└  1  4  3  2 ┘
=( 1 )( 2  4 )( 3 )

┌  1  2  3  4 ┐
└  2  1  3  4 ┘
=( 1  2 )( 3 )( 4 )

┌  1  2  3  4 ┐
└  2  1  4  3 ┘
=( 1  2 )( 3  4 )

┌  1  2  3  4 ┐
└  3  2  1  4 ┘
=( 1  3 )( 2 )( 4 )

┌  1  2  3  4 ┐
└  3  4  1  2 ┘
=( 1  3 )( 2  4 )

┌  1  2  3  4 ┐
└  4  2  3  1 ┘
=( 1  4 )( 2 )( 3 )

┌  1  2  3  4 ┐
└  4  3  2  1 ┘
=( 1  4 )( 2  3 )


恒等置換と長さ2の巡回置換のみが該当するので
 恒等置換 1つ
 長さ2 (x x)、(x x)(x x)の形は、COMB(4,2)=6、COMB(4,2)*COMB(2,2)/FACT(2)=3
したがって、1+6+3=10
!参考サイト http://www.research.att.com/~njas/sequences/A000085
!1 + COMB(N,2)/1! + COMB(N,2)*COMB(N-2,2)/2! + COMB(N,2)*COMB(N-2,2)*COMB(N-4,2)/3! + …
LET N=4
LET T=1
FOR i=1 TO INT(N/2)
   LET S=1
   FOR k=0 TO i-1
      LET S=S*COMB(N-2*k,2)
   NEXT k
   LET T=T+S/FACT(i)
NEXT i
PRINT T
END
 

Re: カーマイケル数

 投稿者:永野護  投稿日:2010年 4月10日(土)14時39分11秒
  > No.1168[元記事へ]

山中様の再三のお返事に感謝します。
お忙しい中、ありがとうございました。
私には少々難しいですが、参考にさせていただきます。
 

Re: 擬素数

 投稿者:SECOND  投稿日:2010年 4月11日(日)01時43分30秒
  > No.1162[元記事へ]

!※「a が n の倍数でない」「a と n が互いに素」を区別しない説明サイトが目立ちます。
!と、書いたけれども、勿論異なるわけであるが、◆フェルマーの小定理 の場合、
!
!「n が素数」ならば、「n の倍数でない整数 a 」は、自動的に「a と n が互いに素」に
!なってしまう。
!ところが、「擬素数」を探す場合、「n が素数」の条件を持たないために、
!「a が n の倍数でない」が「a と n が互いに素」を、伴うとは限らない。
! 結果として付随していた「a と n が互いに素」の条件は、
! 「擬素数」を探す場合に、別途に必要とするのか?
!
! どなたか、お答え願えれば、助かります。
!
!---------------------------------------------------------
! n=4~1000、a=2~100 まで「n の倍数でない整数 a 」のみと、
!「a と n が互いに素」まで加えた条件の 2通りを比較したが、
! この範囲での差は見られなかった。

OPTION ARITHMETIC RATIONAL !有理数モード
PRINT "  a:  素数でないnで、mod(a^(n-1),n)=1 のn"
PRINT " ↓: ---------------------------------------"
FOR a=2 TO 100
   LET w$=USING$("###",a)& ":"
   FOR n=4 TO 1000  !走査するnは、素数 が対象外で、4~1000
   !FOR n=5 TO 1000 STEP 2  !偶数を除くとき。
      IF 0< MOD(a,n) AND MOD(a^(n-1),n)=1 AND 1< Pri(n) THEN LET w$=w$& USING$("####",n)
   NEXT n
   PRINT w$
   !----「a と n が互いに素」を加えた条件( 上と合わせて2行づつ表示。)
   LET w$="    "
   FOR n=4 TO 1000
   !FOR n=5 TO 1000 STEP 2  !偶数を除くとき。
      IF 0< MOD(a,n) AND GCD(a,n)=1 AND MOD(a^(n-1),n)=1 AND 1< Pri(n) THEN LET w$=w$& USING$("####",n)
   NEXT n
   PRINT w$
NEXT a

FUNCTION Pri(n)
   FOR i=CEIL(n/2) TO 2 STEP -1
      IF MOD(n,i)=0 THEN EXIT FOR
   NEXT i
   LET Pri=i  !素数は i=1 まで下がる。
END FUNCTION

END
 

Re: 擬素数

 投稿者:山中和義  投稿日:2010年 4月11日(日)15時03分40秒
  > No.1172[元記事へ]

SECONDさんへのお返事です。

> 「擬素数」を探す場合に、別途に必要とするのか?

概素数
 a^(n-1)≡1 mod n となるnをaを底とする概素数という。a-PRPと記す。

擬素数
 合成数の概素数を擬素数という。

この定義だと
 「aはnの倍数でない」「aとnは互いに素」
は(表立って)ありません。
 

Re: 擬素数

 投稿者:SECOND  投稿日:2010年 4月11日(日)16時13分21秒
  > No.1158[元記事へ]

ご返事ありがとうございます。実は、このページが難解だったのですが、

・・・という事は、
IF MOD(a^(n-1),n)=1 AND 1< Pri(n) THEN LET w$=w$& USING$("####",n) !擬素数

これだけで、良いとなりますが、確かに一致します。
 

Re: 擬素数

 投稿者:山中和義  投稿日:2010年 4月12日(月)08時45分36秒
  > No.1174[元記事へ]

SECONDさんへのお返事です。

> これだけで、良いとなりますが、確かに一致します。

擬素数は
 「倍数でない」かつ「互いに素」を満たしている
ということでしょう。

次のような定義(?)もあります。

!擬素数
! nを合成数とする。1<a<n かつ GCD(a,n)=1 となるある整数aに対して、
! a^(n-1) ≡ 1 mod n となるとき、nをaを底とする擬素数という。

!擬素数
! フェルマーテストを通過する合成数
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 4月12日(月)10時01分27秒
  > No.1153[元記事へ]

素数関連の関数
 素数判定の関数PrimeQを定義して、それを使ったいくつかの関数を定義します。
 個々の関数ごとに最適化もありますので、研究してみてください。
!素数 2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,…

!n番目の素数 ※UBASIC prm(n)関数
FOR i=1 TO 168
   PRINT Prime(i);
NEXT i
PRINT

!n番目の素数の近似
FOR i=2 TO 168
   PRINT i*LOG(i)+i*LOG(LOG(i));
NEXT i
PRINT


!nより大きい素数の最小のもの ※UBASIC nxtprm(x)関数
FOR i=0 TO 100
   PRINT i; NextPrime(i)
NEXT i


!n以下の素数の数
LET N=1000
PRINT "素数は";PrimePi(N);"個です。"

PRINT N/LOG(N) !ガウス・アダマール・ピュイサンの素数定理による近似
PRINT N/(LOG(N)-1.08366) !ルジャンドルの近似


!n個の素数列
LET N=168
DIM P(N)
CALL PrimeList(N,P)
MAT PRINT P;


END


EXTERNAL FUNCTION PrimeQ(n) !素数判定 1:素数、0:素数でない
LET PrimeQ=0
IF n<2 OR n<>INT(n) THEN EXIT FUNCTION !引数を確認する
!2以上の自然数なら
IF MOD(n,2)=0 THEN !2の倍数
   IF n=2 THEN LET PrimeQ=1 !2は素数
ELSEIF MOD(n,3)=0 THEN !3の倍数
   IF n=3 THEN LET PrimeQ=1 !3は素数
ELSE
   LET k=5
   DO WHILE k*k<=n !√nまで検証する
      IF MOD(n,k)=0 THEN !5,11,17,23,29,…
         EXIT FUNCTION
      ELSEIF MOD(n,k+2)=0 THEN !7,13,19,25,31,…
         EXIT FUNCTION
      END IF !+1,+3,+5は2の倍数(偶数)、+1,+4は3の倍数、+5は5の倍数
      LET k=k+6
   LOOP
   LET PrimeQ=1 !最後まで割り切れなければ、素数である
END IF
END FUNCTION

EXTERNAL FUNCTION Prime(n) !n番目の素数
IF n<1 THEN EXIT FUNCTION !引数を確認する
IF n=1 THEN
   LET Prime=2
ELSE
   LET c=1 !見つけた個数
   LET i=1 !素数の候補 ※3以上の奇数
   DO WHILE c<n
      LET i=i+2
      LET c=c+PrimeQ(i) !素数なら+1する
   LOOP
   LET Prime=i
END IF
END FUNCTION

EXTERNAL FUNCTION NextPrime(n) !nより大きい素数の最小のもの
IF n<2 THEN
   LET NextPrime=2
ELSE
   LET i=INT(n)
   IF MOD(i,2)=0 THEN LET i=i+1 ELSE LET i=i+2 !素数の候補 ※3以上の奇数
   DO UNTIL PrimeQ(i)<>0 !見つかるまで
      LET i=i+2
   LOOP
   LET NextPrime=i
END IF
END FUNCTION

EXTERNAL FUNCTION PrimePi(n) !n以下の素数の数
LET c=0
IF n>=2 THEN LET c=1 !2は素数
FOR i=3 TO n STEP 2 !指定の数まで検証する
   LET c=c+PrimeQ(i) !素数なら+1する
NEXT i
LET PrimePi=c
END FUNCTION

EXTERNAL SUB PrimeList(n,p()) !n個の素数列を返す
IF n<1 THEN EXIT SUB !引数を確認する
LET c=1 !見つけた個数
LET p(c)=2 !2は素数
LET i=3 !素数の候補 ※3以上の奇数
DO WHILE c<n
   IF PrimeQ(i)<>0 THEN !素数なら
      LET c=c+1
      LET p(c)=i
   END IF
   LET i=i+2
LOOP
END SUB


また、UBASICの場合、PrimeQ関数は次のように記述するとよい。
EXTERNAL FUNCTION PrimeQ(X) !素数判定 1:素数、0:素数でない
LET PrimeQ=0
IF X>=2 AND X=INT(X) THEN !2以上の整数で
   IF prmdiv(X)=X THEN LET PrimeQ=1 !1より大きい最小の約数が自分自身なら素数である
END IF
END FUNCTION
 

描画の位置補正

 投稿者:N.E.  投稿日:2010年 4月12日(月)17時47分15秒
  SET BITMAP SIZE a,b
SET WINDOW 1,a,b,1
となる座標(左上を1とする一画素当たりの座標が1)を定義し、
POINT STYLEが1の場合、
PLOT POINTで小数で表せる座標を指定したとき、
どのように処理をすれば、画面と同じ結果になるのでしょうか。
(計算で求めた座標と、画面の座標を同じ結果にする方法)

教えて下さい。
お願いします。
 

Re: 描画の位置補正

 投稿者:山中和義  投稿日:2010年 4月12日(月)19時33分14秒
  > No.1177[元記事へ]

N.E.さんへのお返事です。

> どのように処理をすれば、画面と同じ結果になるのでしょうか。
> (計算で求めた座標と、画面の座標を同じ結果にする方法)

SET POINTS: 12.3, 45.6
とすれば、BASIC側で最寄の位置(12,46)(だと思います)に点を打ちます。

SET POINTS: INT(12.3), INT(45.6)
とすれば、(12,45)に点を打ちます。

、、、が、
小数指定したとしても「指定した座標」と「表示した座標」との間には誤差があります。

描画ソフト、特にCADでは
操作は画面をクリックして、(描画した図形から)座標を読み込んでいるように見えますが、
(マウス座標値は精度も悪いので)近傍値として取得して、
内部の図形データ(浮動小数点数)から該当する座標を探すことになります。

「指定した座標」は「理論値」、「表示した座標」は「近似値」として扱う仕組みが必要になります。
 

Re: 描画の位置補正

 投稿者:N.E.  投稿日:2010年 4月12日(月)20時30分35秒
  > No.1178[元記事へ]

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

> SET POINTS: 12.3, 45.6
> とすれば、BASIC側で最寄の位置(12,46)(だと思います)に点を打ちます。
>
> SET POINTS: INT(12.3), INT(45.6)
> とすれば、(12,45)に点を打ちます。
>
> 、、、が、
> 小数指定したとしても「指定した座標」と「表示した座標」との間には誤差があります。
> 「指定した座標」は「理論値」、「表示した座標」は「近似値」として扱う仕組みが必要になります。

MAT PLOTを使えないでしょうか。

扇形を描こうとしているのですが、多角形として描くために、一点一点座標を求めています。
何かいい方法はないでしょうか。
ちなみに、1画素0.1での場合、四捨五入より約0.000000000000000005875ずれました。
 

Re: 描画の位置補正

 投稿者:山中和義  投稿日:2010年 4月12日(月)20時58分16秒
  > No.1179[元記事へ]

N.E.さんへのお返事です。

> MAT PLOTを使えないでしょうか。

配列変数の中身を整数化などすればいいのでは?

> 扇形を描こうとしているのですが、多角形として描くために、一点一点座標を求めています。

曲線描画は、格子状の点列に割り付けるので(ビットマップ方式の描画)、細かい折れ線描画です。
滑らかに見えるかは、解像度が関係していますので、たとえば小さい円を描くと歪みます。
(複数の「指定した点」が同一の「表示した点」になる)

> 何かいい方法はないでしょうか。

多角形以外ということでしょうか? 上記説明より他の手法はないです。

> ちなみに、1画素0.1での場合、四捨五入より約0.000000000000000005875ずれました。

何が何に対してなのか抽象過ぎて回答できません。
 

Re: 描画の位置補正

 投稿者:N.E.  投稿日:2010年 4月12日(月)21時23分22秒
  > No.1180[元記事へ]

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

> > MAT PLOTを使えないでしょうか。
>
> 配列変数の中身を整数化などすればいいのでは?

方法を教えて下さい。

> > 何かいい方法はないでしょうか。
>
> 多角形以外ということでしょうか? 上記説明より他の手法はないです。

簡単でわかりやすいなら多角形でもいいです。

> > ちなみに、1画素0.1での場合、四捨五入より約0.000000000000000005875ずれました。
描かれる位置のずれです。
例)0.04999999999999999999999…なら、0.04の位置に、
  0.045なら、0.05の位置に描かれるはずなのに、約0.000000000000000005875ずれ、
  0.04999999999999999994125で0.04に、
   0.04999999999999999994126で0.05になってしまうということです。
 

Re: 描画の位置補正

 投稿者:山中和義  投稿日:2010年 4月12日(月)21時44分49秒
  > No.1181[元記事へ]

N.E.さんへのお返事です。

> 例)0.04999999999999999999999…なら、0.04の位置に、
>   0.045なら、0.05の位置に描かれるはずなのに、約0.000000000000000005875ずれ、
>   0.04999999999999999994125で0.04に、
>    0.04999999999999999994126で0.05になってしまうということです。

連続する数値計算は、誤差が膨らみます。
通常16桁程度で計算していくので、結果の有効桁は10桁程度と思って
最終的な補正を行う必要があります。
たとえば、上記数値の最後4126は誤差として処理するということです。
 

扇形のアニメ

 投稿者:SECOND  投稿日:2010年 4月13日(火)01時07分35秒
  !扇形のアニメ

SET WINDOW -1.07, 1.02, -1.07, 1.02
SET COLOR MIX(15) .4,.4,.4  !グリッドの色 R,G,B
!
!---扇の原形
LET x0= 0.2        !中心x座標
LET y0=-0.5        !中心y座標
LET r0=1.1         !半径
LET Sa=PI*1.5/6    !開始角度
LET Ea=PI*5.5/6    !終了角度
!
!---扇の変形移動
FOR i=0 TO 2*PI+1e-9 STEP PI/50
   LET r=r0+i*(i-2*PI)/10
   SET DRAW mode hidden
   CLEAR
   DRAW grid(.5,.5)
   DRAW fan(x0,y0,r,Sa,Ea) WITH ROTATE(i*2)*SHIFT(.3*COS(i)-.3,.3*SIN(i))
   SET LINE width 2
   DRAW fan(x0,y0,r/2,Sa,Ea) WITH ROTATE(i*2)*SHIFT(.3*COS(i)-.3,.3*SIN(i))
   SET DRAW mode explicit
   SET LINE width 1
   WAIT DELAY .01
NEXT i

!---扇の型
PICTURE fan(x0,y0,r0,Sa,Ea)
   PLOT LINES :x0,y0; !中心点~開始角度の点まで直線を引くための、Pen-ON
   FOR a=Sa TO Ea +(1e-9) STEP (Ea-Sa)/20
      PLOT LINES :r0*COS(a)+x0,r0*SIN(a)+y0; !開始から終了角度の点まで短い直線で、なぞる
   NEXT a
   PLOT LINES :x0,y0  !終了角度の点から、中心点までの直線を引き、Pen-OFF
END PICTURE

END
 

Re: 描画の位置補正

 投稿者:山中和義  投稿日:2010年 4月13日(火)09時50分44秒
  > No.1179[元記事へ]

N.E.さんへのお返事です。

> 扇形を描こうとしているのですが、多角形として描くために、一点一点座標を求めています。

ちなみに私ならこう記述します。(2つの例)
!最近のグラフィックス・ライブラリ系の機能(特にワールド座標変換)がない場合
!自分でその機能を実現します。

LET p=1 !丸めする小数桁位置
LET zm=1/10^p !倍率

LET a=550 !描画領域
LET b=400
SET bitmap SIZE a,b
SET WINDOW 0,(a-1)*zm,0,(b-1)*zm !※左下が原点

CALL fan(100,50,20,60,300) !小さい
CALL fan(200,150,200,-150,120) !中ぐらい
CALL fan(250,100,350,30,330) !大きい

SUB fan(X,Y,R,SA,EA) !中心(X,Y)、半径Rの扇形を描く ※0≦R、-360≦SA≦EA≦360
   LET cx=ROUND(X*zm, p) !中心点と開始点を結ぶ
   LET cy=ROUND(Y*zm, p)
   PLOT LINES: cx,cy;
   FOR i=SA TO EA STEP 0.5
      LET th=RAD(i) !ラジアンへ
      LET xx=ROUND((R*COS(th)+X)*zm, p) !問題座標へ
      LET yy=ROUND((R*SIN(th)+Y)*zm, p)
      PLOT LINES: xx,yy; !多角形近似
      PRINT i;xx;yy !debug
   NEXT i
   PLOT LINES: cx,cy !終了点と中心点を結ぶ
END SUB



!FULL BASICのグラフィックス・ライブラリ系の機能を使って記述すると

SET LINE COLOR 4 !上書きを確認する

DRAW arc(100,50,20,60,300) WITH SCALE(zm) !小さい
DRAW arc(200,150,200,-150,120) WITH SCALE(zm) !中ぐらい
DRAW arc(250,100,350,30,330) WITH SCALE(zm) !大きい

PICTURE arc(X,Y,R,SA,EA) !中心(X,Y)、半径Rの扇形を描く ※0≦R、-360≦SA≦EA≦360
   DRAW arc0(SA,EA) WITH SCALE(R)*SHIFT(X,Y)
END PICTURE
PICTURE arc0(SA,EA) !原点を中心とした半径1の扇形を描く ※-360≦SA≦EA≦360
   PLOT LINES: 0,0; !中心点と開始点を結ぶ
   FOR i=SA TO EA STEP 0.5
      LET th=RAD(i) !ラジアンへ
      LET x=COS(th) !問題座標へ
      LET y=SIN(th)
      PLOT LINES: x,y; !多角形近似
      !!!PRINT i;x;y !debug
   NEXT i
   PLOT LINES: 0,0 !終了点と中心点を結ぶ
END PICTURE

END
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 4月16日(金)09時22分13秒
  > No.1176[元記事へ]

行列成分の初期化
LET N=7 !正方行列の大きさ

LET M=N-1
DIM A(0 TO M,0 TO M) !※C言語などと等価

!まず、成分番号での次のような代入を考える。

!左斜めのグループ
FOR i=0 TO M
   FOR j=0 TO M
      LET A(i,j)=i-j
   NEXT j
NEXT i
MAT PRINT A;

!右斜めのグループ
FOR i=0 TO M
   FOR j=0 TO M
      LET A(i,j)=i+j-M
   NEXT j
NEXT i
MAT PRINT A;


!とすると、斜めをグループ化することができる。したがって、対角線への書き込みは、

!左斜め対角線
FOR i=0 TO M
   FOR j=0 TO M
      IF i=j THEN
         LET A(i,j)=1
      ELSE
         LET A(i,j)=0
      END IF
   NEXT j
NEXT i
MAT PRINT A;


!右斜め対角線
FOR i=0 TO M
   FOR j=0 TO M
      IF i+j=M THEN
         LET A(i,j)=1
      ELSE
         LET A(i,j)=0
      END IF
   NEXT j
NEXT i
MAT PRINT A;


!要素番号i,jを、XY座標の第1象限の座標と考えると、
! ・─X(j)
! │
! Y(i)

!幅がある場合は、絶対値(ABS関数)を使って、その範囲を不等式で表現できる。

!左上半分(右下半分)
FOR i=0 TO M
   FOR j=0 TO M
      IF ABS(i+j)<=M THEN !Mは幅 ※>=
         LET A(i,j)=i+j
      ELSE
         LET A(i,j)=0
      END IF
   NEXT j
NEXT i
MAT PRINT A;


!左斜めの帯状
FOR i=0 TO M
   FOR j=0 TO M
      IF ABS(i-j)<2 THEN !2は幅
         LET A(i,j)=1
      ELSE
         LET A(i,j)=0
      END IF
   NEXT j
NEXT i
MAT PRINT A;



!問題 ひし形状に1を埋める

!答え ※ドラッグして反転表示してください

FOR i=0 TO M
   FOR j=0 TO M
      IF ABS(i+j-M)<=M/2 AND ABS(i-j)<=M/2 THEN
         LET A(i,j)=1
      ELSE
         LET A(i,j)=0
      END IF
   NEXT j
NEXT i
MAT PRINT A;


END
 

ヤコビ記号

 投稿者:永野護  投稿日:2010年 4月17日(土)11時41分11秒
  いつも大変お世話になっています。
お忙しい最中、恐縮ですが、また1つ質問させてください。
数論のほうで平方剰余の相互法則というのがあります。
ここでルジャンドル記号とかヤコビ記号がでてくるのですが、
ヤコビ記号の値(1,-1,0)を求めるプログラムは十進BASICで書くと
どのようになるのでしょうか。
急ぎませんのでお暇なときにでもご教示いただければ、助かります。
 

Re: ヤコビ記号

 投稿者:山中和義  投稿日:2010年 4月17日(土)13時37分42秒
  > No.1186[元記事へ]

永野護さんへのお返事です。

> ヤコビ記号の値(1,-1,0)を求めるプログラムは十進BASICで書くとどのようになるのでしょうか。
FUNCTION jacobi(a,b) !ヤコビ記号
   LET j=1
   IF a<0 THEN
      LET a=-a
      IF MOD(b,4)=3 THEN LET j=-j
   END IF
   LET a=MOD(a,b)
   DO WHILE a>1
      DO WHILE MOD(a,2)=0
         LET a=a/2
         IF MOD(b,8)=3 OR MOD(b,8)=5 THEN LET j=-j
      LOOP
      IF a<>1 THEN
         IF MOD(a,4)=3 AND MOD(b,4)=3 THEN LET j=-j
         LET c=b
         LET b=a
         LET a=MOD(c,b)
      END IF
   LOOP
   IF a=0 THEN LET j=0
   LET jacobi=j
END FUNCTION

FOR a=1 TO 3
   FOR b=1 TO 9 STEP 2
      PRINT jacobi(a,b);
   NEXT b
   PRINT
NEXT a

END
 

ヤコビ記号

 投稿者:永野護  投稿日:2010年 4月17日(土)15時24分14秒
  山中様、大変お世話になりました。
丁寧なプログラムに感謝します。
お忙しい中、ありがとうございました。
敬具
 

ヤコビ記号

 投稿者:永野護  投稿日:2010年 4月18日(日)09時14分55秒
  たびたびお邪魔して申し訳ございません。もうひとつ質問させてください。
インターネットなんかを見ると、(a/p)をルジャンドル記号とした場合、
aは奇数pは奇素数であり(n/m)をヤコブ記号とした場合、nは任意の整数
mは奇数と書いてあります。pやmが偶数の場合これらの記号の値は定義されていないのでしょうか。
 

Re: ヤコビ記号

 投稿者:山中和義  投稿日:2010年 4月18日(日)20時51分45秒
  > No.1189[元記事へ]

永野護さんへのお返事です。

> pやmが偶数の場合これらの記号の値は定義されていないのでしょうか。

クロネッカー記号(Kronecker Symbol) http://mathworld.wolfram.com/KroneckerSymbol.html
!クロネッカー記号(Kronecker Symbol)

FUNCTION Kro(a,b)
   IF b=0 THEN
      IF ABS(a)=1 THEN LET Kro=1 ELSE LET Kro=0
      EXIT FUNCTION
   END IF
   IF MOD(a,2)=0 AND MOD(b,2)=0 THEN
      LET Kro=0
      EXIT FUNCTION
   END IF
   LET v=0
   DO WHILE MOD(b,2)=0
      LET v=v+1
      LET b=b/2
   LOOP
   IF MOD(v,2)=0 THEN LET k=1 ELSE LET k=(-1)^((a^2-1)/8)
   IF a<0 AND b<0 THEN LET k=-k
   IF b<0 THEN LET b=-b
   DO WHILE a<>0
      LET v=0
      DO WHILE MOD(a,2)=0
         LET v=v+1
         LET a=a/2
      LOOP
      IF MOD(v,2)=1 THEN LET k=(-1)^((b^2-1)/8)*k
      LET k=(-1)^((a-1)*(b-1)/4)*k
      LET r=ABS(a)
      LET a=MOD(b,r)
      LET b=r
   LOOP
   IF b>1 THEN LET Kro=0 ELSE LET Kro=k
END FUNCTION


SET WINDOW 1,101,1,101
FOR n=1 TO 100
   FOR m=1 TO 100
      SELECT CASE Kro(n,m) !色分け
      CASE 0
         SET AREA COLOR 0
      CASE 1
         SET AREA COLOR 1
      CASE -1
         SET AREA COLOR 4
      CASE ELSE
         PRINT "エラー";m;n
         STOP
      END SELECT
      DRAW DOT WITH SHIFT(n,m) !点を描く
   NEXT m
   PRINT
NEXT n

PICTURE DOT !点
   PLOT AREA: 0,0; 1,0; 1,1; 0,1
END PICTURE

END
 

前景色と背景色の変更

 投稿者:イーグル  投稿日:2010年 4月18日(日)21時50分58秒
   初めまして。質問がありまして、投稿させて頂きました。
 十進BASICで、プログラム編集画面の前景色や背景色を
変更することは可能でしょうか。前景色とは文字の色のことです。
その目的は、目の負担を軽減することです。
 現状としては、カスタマイズが可能な外部エディタで
ソースファイルを編集した後に、そのファイルを/ORオプションと共に
十進BASICで指定して実行する、というのが妥当かとも思うのですが。
こちらのソフトウェアだけで完結できるのであれば、
便利なのではないかと思っています。
 メニューやヘルプ、ウェブサイトや掲示版を調べてみたのですが、
解決方法を見付けることが出来ませんでした。
 どなたかご存知の方がいらっしゃいましたら、
お教え頂ければ幸いに存じます。宜しくお願い致します。
 

Re: 前景色と背景色の変更

 投稿者:白石 和夫  投稿日:2010年 4月19日(月)08時55分47秒
  > No.1191[元記事へ]

いたずら目的であれば,Win32APIを使ってできるかもしれません。
(ただし,エディタ本体のRichEditコントロールのハンドルの取得が難しいかもしれません)

実用目的であれば,Lazarus版のソースを公開しているので,
好みに合うように書き換えて使うのが確実です。
http://sourceforge.jp/projects/decimalbasic/releases/?package_id=8178
から,BASIC055JaSRC.zipを取得してください。
別途,Lazarusのインストールが必要です。
http://snapshots.lazarus.shikami.org/
Lazarusを起動したら,プロジェクト・メニューの「プロジェクトを開く」で
basic.lpiを指定してソースを読み込んでください。
 

Re: ヤコビ記号

 投稿者:永野護  投稿日:2010年 4月19日(月)10時43分48秒
  > No.1190[元記事へ]

ありがとうございました。
お忙しいところたびたびすみませんでした。
 

Re: 前景色と背景色の変更

 投稿者:イーグル  投稿日:2010年 4月19日(月)22時19分5秒
  > No.1192[元記事へ]

 ご返信ありがとうございます。

 「WIN32APIを使って」という方法の
概要が良く分からないのですが。
 何らかのツールで、既存の十進BASICを
改造するということなのかとも推察致しましたが、
方法も良く分からないので止めて置きます。

 Lazarus版を書き換えるという方法ですが。
win32 Lazarus + fpc 2.4.0をインストールし、
BASIC055JaSRC.zipを解凍したソースファイルから
プロジェクトを開くことは出来たのですが。
ビルドや実行をしようとすると、メッセージペインに
大量の情報と警告が出た後、最終的にはエラーが出て、
実行が出来ません。basic.rcやmanifest.rcが
開けないというエラーだったので、
ダミーファイルを作成しましたが、
外のエラーが出て止まってしまいます。
 外のバージョンのBASIC054JaSRC.zipや、
49や48を試してみたのですが、
どれも同じような状態です。
 試しに、ボタンだけの単純なプロジェクトを
作ってみた所、実行は出来ました。
 しかし、以上の問題が解決したとしても、
この環境に関する知識がなく、
書き換えには、非常に手間隙が掛かりそうなので、
ここで止めて置きます。

 尚、その後、ふと思い浮かんだ方法を試しました。
Windows自体の設定を変更する方法です。
デザインの設定に於ける詳細設定で
ウィンドウの配色を変更すると、目的が達成されそうです。
 これはこれで、影響の及ぶ範囲が広く、
思わぬ問題点も出て来るでしょうが、
暫くはこの方法で使わせて頂こうと思います。

 いきなりの質問に対して、解決策の方針を
お教え下さいまして、ありがとうございました。
 

Re: 前景色と背景色の変更

 投稿者:白石 和夫  投稿日:2010年 4月20日(火)09時21分16秒
  > No.1194[元記事へ]

イーグルさんへのお返事です。

Win32APIを使う例は
http://hp.vector.co.jp/authors/VA008683/QA_WindowPos.htm
にあります。また,十進BASIC過去ログ
http://www.geocities.jp/thinking_math_education/log/logs.html
にはより高度な手法が見出されると思います。
ただし,この方法で目的の処理ができるという保証はありません。

Lazarusで再コンパイルする方法は確実ですが,
Lazarusの扱いに慣れるのに時間がかかると思います。
manifest.rcがないためにエラーになる問題は,
basic.lprの65行目にある
{$IFDEF WINDOWS}{$R manifest.rc}{$ENDIF}
を削除すれば解決すると思います。
プログラム編集画面のソースはmainfrm.pasです。Lazarusのファイルメニューでmainfrm.pasを開いてください。
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 4月22日(木)13時53分34秒
  > No.1185[元記事へ]

問題
 Aが2個、Bが2個、Cが1個から、2個選ぶ組合せ
答え
 AA,AB,AC,BB,BC より、5通り


●「組合せ」を列挙する
LET E1=2 !Aの数
LET E2=2 !Bの数
LET E3=1 !Cの数

FOR i=0 TO E1 !「組合せ」のすべてを生成する
   FOR j=0 TO E2
      FOR k=0 TO E3
         PRINT i+j+k; REPEAT$(" A",i);REPEAT$(" B",j);REPEAT$(" C",k)
      NEXT k
   NEXT j
NEXT i

END

特に、それぞれの個数が1の場合の「異なるn個のものからr個選ぶ組合せ」は、
 nビットの2進数で表現できる。
 comb(n,r)は、r個の1と(n-r)個の0で表される数の個数である。
 その組は、ビットパターンである。

 2^n=comb(n,0)+comb(n,1)+comb(n,2)+ … +comb(n,n)=Σ[r=0,n]comb(n,r)
 パスカルの三角形の各段の和
   1 → 2^0
   1 1 → 2^1
  1 2 1 → 2^2
  1 3 3 1 → 2^3
 1 4 6 4 1 → 2^4
   :

ビットパターンを列挙すると
                     {}
             {0}             {1}
       {00}           {01,10}            {11}
  {000}       {001,010,100}       {011,101,110}        {111}
{0000} {0001,0010,0100,1000} {0011,0101,0110,1001,1010,1100} {0111,1011,1101,1110} {1111}
                                          :

それぞれの個数が異なる場合、変則のカウンタ(計数器)となる。


●組合せを表す母関数

次の多項式を展開する。
(1+a*x+a^2*x^2)*(1+b*x+b^2*x^2)*(1+c*x)
=1 + a*x + a^2*x^2 + a^2*b*x^3 + a^2*b^2*x^4 + a^2*b^2*c*x^5
     b*x + a*b*x^2 + a^2*c*x^3 + a^2*b*c*x^4
     c*x + a*c*x^2 + a*b^2*x^3 + a*b^2*c*x^4
           b^2*x^2 + a*b*c*x^3
           b*c*x^2 + b^2*c*x^3

x^2の係数に着目すると、a^2,a*b,a*c,b^2,b*c

上記の式で、a=b=c=1とすると、場合の数は
母関数(1+x+x^2)*(1+x+x^2)*(1+x)のx^2の係数となる。
展開して、与式=1+3*x+5*x^2+5*x^3+3*x^4+x^5より、5
LET E1=2 !Aの数 ※次数
DIM P1(0 TO E1) !多項式 1+x+x^2
MAT P1=CON

LET E2=2 !Bの数
DIM P2(0 TO E2) !多項式 1+x+x^2
MAT P2=CON

LET E3=1 !Cの数
DIM P3(0 TO E3) !多項式 1+x
MAT P3=CON

DIM P(0 TO E1+E2+E3) !展開した多項式
MAT P=ZER
LET E=0

CALL PolyMul(E1,P1,E2,P2, E,P) !P1*P2 → P
CALL PolyMul(E,P,E3,P3, E,P) !P*P3 → P

MAT PRINT P;
PRINT "場合の数=";P(2)

END

EXTERNAL SUB PolyMul(AA,A(),BB,B(), CC,C()) !1変数多項式の乗算 C=A*B
DIM W(0 TO AA+BB) !作業用
MAT W=ZER
FOR i=0 TO AA !最高次数まで
   FOR j=0 TO BB
      LET W(i+j)=W(i+j)+A(i)*B(j) !※筆算参照
   NEXT j
NEXT i
LET CC=AA+BB !copy it
MAT C=W
END SUB

「異なるn個のものからr個選ぶ組合せ、COMB(n,r)通り」は、

 (1+a*x)*(1+b*x)* … *(1+c*x)=1 + (a+b+ … +c)*x + … + (a*b* … *c)*x^n

 母関数(1+x)*(1+x)* … *(1+x)=(1+x)^nのx^rの係数 ※パスカルの三角形を参照のこと
     └── N個 ──┘

 LET N=5
 LET R=2
 DATA 1,1,1,1,1 !異なるものが各々1個ずつ

となる。

また
 「異なるn個のものからr個選ぶ順列、PERM(n,r)通り」は
  指数型母関数(1+x)^nのx^r/r!の係数
となる。


●「異なるn個」と「それぞれの個数」、「r個選ぶ」を指定する方式にすると、、、
LET N=3
LET R=2
DATA 2,2,1 !※{A,A,B,B,C}の意

DIM C(N) !それぞれの個数
MAT READ C

LET S=0 !総数
FOR i=1 TO N
   LET S=S+C(i)
NEXT i
IF S<R THEN
   PRINT "数が足りません。";S
   STOP
END IF


DIM G(N) !(A,B,C)の個数
MAT G=ZER
CALL gen_comb(N,C,R, 1,G) !再帰呼出しで「カウンタ」を実現する


DIM P(0 TO S)
MAT P=ZER !定数1 → T
LET P(0)=1
LET E=0

DIM T(0 TO S) !1変数多項式の乗算を連続で行う
MAT T=CON !1+x+x^2+ … +x^ci → T
FOR i=1 TO N
   CALL PolyMul(E,P,C(i),T, E,P) !P*T → P
NEXT i

MAT PRINT P; !debug
PRINT "場合の数=";P(R)

END


EXTERNAL SUB gen_comb(N,C(),R, p,G()) !「組合せ」のすべてを生成する
FOR i=C(p) TO 0 STEP -1 !辞書式順序
   LET G(p)=i !まずp桁目を決める
   IF p=N THEN !すべて確定したら
      MAT PRINT G; !(A,B,C)
   ELSE
      CALL gen_comb(N,C,R, p+1,G) !次の桁へ
   END IF
   !!LET G(p)=0
NEXT i
END SUB

EXTERNAL SUB PolyMul(AA,A(),BB,B(), CC,C()) !1変数多項式の乗算 C=A*B
DIM W(0 TO AA+BB) !作業用
MAT W=ZER
FOR i=0 TO AA !最高次数まで
   FOR j=0 TO BB
      LET W(i+j)=W(i+j)+A(i)*B(j) !※筆算参照
   NEXT j
NEXT i
LET CC=AA+BB !copy it
MAT C=W
END SUB
 

Re: 前景色と背景色の変更

 投稿者:イーグル  投稿日:2010年 4月23日(金)00時47分30秒
  > No.1195[元記事へ]

白石 和夫さんへのお返事です。

 ありがとうございます。

> イーグルさんへのお返事です。
>
> Win32APIを使う例は
> http://hp.vector.co.jp/authors/VA008683/QA_WindowPos.htm
> にあります。また,十進BASIC過去ログ
> http://www.geocities.jp/thinking_math_education/log/logs.html
> にはより高度な手法が見出されると思います。
> ただし,この方法で目的の処理ができるという保証はありません。

 なるほど。Win32APIをBASICプログラムから使えるということですか。
私の頭には、本体となるWindowは変更できないという先入観が
あったために、これらの記述を見過ごしており、気付くことができませんでした。
 Win32APIを使ったことが無いので、こちら
http://wisdom.sakura.ne.jp/system/winapi/win32/index.html
のサイトさんで調べて、試そうともしてみましたが、お手上げ状態です。
このサイトさん、或いは書籍を一通り学べば、取っ掛かりとなるのかも知れませんが。

> Lazarusで再コンパイルする方法は確実ですが,
> Lazarusの扱いに慣れるのに時間がかかると思います。
> manifest.rcがないためにエラーになる問題は,
> basic.lprの65行目にある
> {$IFDEF WINDOWS}{$R manifest.rc}{$ENDIF}
> を削除すれば解決すると思います。
> プログラム編集画面のソースはmainfrm.pasです。Lazarusのファイルメニューでmainfrm.pasを開いてください。

 ご教示の通りにすると、エラーが出なくなりました。
その後なのですが、今度は
   windres: no resources
   basic.lpr(125,1) Error: Error while compiling resources
   basic.lpr(125,1) Fatal: There were 1 errors compiling module, stopping
というエラーが出てしまいました。
この1行目をクリックすると、「ファイル""が見つかりません~後略~」と出ます。
 windresが無いのが問題なのかと思い、cygwinのbinutilsパッケージを
インストールし、windresにPathを通してみましたが、的外れだったようで。
 やはり難しい。こういったエラーを
自力で解決できないのですから、どうにも、不勉強を感ずる次第です。
 Pascalを細々と学び始めようかなと思って、適当に本を選んでみました。
 こちらの方法にしても、大分時間が掛かりそうな感じがします。

 返信頂き、ありがとうございました。
 

Re: 前景色と背景色の変更

 投稿者:白石 和夫  投稿日:2010年 4月23日(金)08時54分22秒
  > No.1197[元記事へ]

>    windres: no resources
>    basic.lpr(125,1) Error: Error while compiling resources
>    basic.lpr(125,1) Fatal: There were 1 errors compiling module, stopping
このエラーは,こちらでは再現しないのでなんともいえませんが,Lazarusあるいはfpcシステム固有(さらにはおそらくOS依存)の問題なので,Pascalの基本をいくら学んでも解決しないと思います。
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 4月24日(土)09時17分22秒
  > No.1196[元記事へ]

続き

カウンタによる「各桁の値」と多項式の展開による「係数の列挙」は等価なため
リスト処理が苦手なBASICでは、カウンタによる方法を使った方がプログラムが簡単である。

高校数学程度で扱う順列、組合せをまとめると


               順列    組合せ
異なるn個から
         すべて   n!     1
  重複を許さず r個選ぶ  PERM(n,r)  COMB(n,r)
  重複を許して r個選ぶ  n^r     COMB(n+r-1,r)
同じものがp個、q個、…、r個ずつから
         すべて (p+q+ … +r)!/p!*q!* … *r!  1
  重複を許さず r個選ぶ  ①     ②

 (1+x+x^2+ … +x^p)*(1+x+x^2+ … +x^q)* … *(1+x+x^2+ … +x^r)を展開したときのx^r/r!の係数

 (1+x+x^2+ … +x^p)*(1+x+x^2+ … +x^q)* … *(1+x+x^2+ … +x^r)を展開したときのx^rの係数

●サンプル・プログラム
!問題
! BASEBALLの8文字から4文字選ぶ組合せ、順列
!答え
! 26通り、354通り

LET N=5 !異なる文字の数
LET R=4
DATA 2,2,1,2,1 !(A,B,E,L,S)の個数

PUBLIC STRING S$
LET S$="ABELS"


DIM C(N) !それぞれの個数
MAT READ C

LET S=0 !総数
FOR i=1 TO N
   LET S=S+C(i)
NEXT i
IF S<R THEN
   PRINT "数が足りません。";S
   STOP
END IF


DIM G(N) !(A,B,E,L,S)の個数
MAT G=ZER

DIM CC(0 TO S),PP(0 TO S) !各Rに対する組合せ、順列
MAT CC=ZER
MAT PP=ZER
CALL gen_comb(N,C,R, 1,G, CC,PP) !再帰呼出しで「カウンタ」を実現する

!!!MAT PRINT CC; !debug
!!!MAT PRINT PP;
PRINT "場合の数=";CC(R);PP(R)


END


EXTERNAL FUNCTION SUM(G(),S,E) !Σ[k=S,E]{G(k)}
LET t=0
FOR k=S TO E
   LET t=t+G(k)
NEXT k
LET SUM=t
END FUNCTION

EXTERNAL SUB gen_comb(N,C(),R, p,G(), CC(),PP()) !「組合せ」のすべてを生成する
FOR i=C(p) TO 0 STEP -1 !辞書式順序
   LET G(p)=i !p桁目を決める
   IF p=N THEN !すべて確定したら
   !MAT PRINT G; !debug
      LET S=SUM(G,1,N)
      IF S=R THEN !該当するものを表示する
         PRINT "(";
         FOR k=1 TO N
            PRINT REPEAT$(" "&S$(k:k),G(k)); !※G()は、使用する個数
         NEXT k
         PRINT " ) 組"

         CALL gen_perm(G,N) !同じものを含む順列を生成する
      END IF

      LET CC(S)=CC(S)+1 !組合せ
      LET PP(S)=PP(S)+PermFactorialM(G,N) !順列
   ELSE
      CALL gen_comb(N,C,R, p+1,G, CC,PP) !次の桁へ
   END IF
   !!LET G(p)=0
NEXT i
END SUB

EXTERNAL SUB gen_perm(B(),M) !「同じものを含む順列」をすべてを生成する
LET N=SUM(B,1,M)
DIM A(N)
FOR i=0 TO PermFactorialM(B,M)-1
   CALL Num2PermFactorialM(i, A,N,B,M)

   FOR k=1 TO N !表示する
      PRINT S$(A(k):A(k));
   NEXT k
   PRINT
NEXT i
END SUB

EXTERNAL FUNCTION PermFactorialM(B(),M) !同じものを含む順列の「場合の数」 (p+q+ … +r)!/(p!*q!* … *r!)通り
LET s=B(1) !総数 p+q+ … +r
LET t=FACT(B(1)) !階乗の積 p!*q!* … *r!
FOR i=2 TO M
   LET s=s+B(i)
   LET t=t*FACT(B(i))
NEXT i
LET PermFactorialM=FACT(s)/t
END FUNCTION

EXTERNAL SUB Num2PermFactorialM(h, A(),N,B(),M) !番号から順列パターンを生成する ※辞書式順序
DIM w(M)
MAT w=B !copy it
LET v=h
FOR i=1 TO N
   FOR j=1 TO M !左端を1~Mとして
      IF w(j)>0 THEN !その左端を除いた残りで最大の順列をつくる
         LET w(j)=w(j)-1
         !!!MAT PRINT w;
         LET t=PermFactorialM(w,M) !その順列の番号を求める
         IF v<t THEN EXIT FOR
         LET v=v-t
         LET w(j)=w(j)+1
      END IF
   NEXT j
   LET A(i)=j !次へ
NEXT i
END SUB


●他の利用例

A,B,C,D,Eの5枚のカードから3枚取り出し、横1列に並べる  答え 60通り
A,B,C,D,Eの5枚のカードから3枚取り出し、袋に入れる  答え 10通り
  LET N=5 !異なる文字の数
  LET R=3
  DATA 1,1,1,1,1 !(A,B,C,D,E)の個数
  LET S$="ABCDE"

重複を許す場合は、Rに対して個数が十分あればいいので(R個で良い)
  LET N=5 !異なる文字の数
  LET R=3
  DATA 3,3,3,3,3 !(A,B,C,D,E)の個数
  LET S$="ABCDE"

aが4個、bが3個、cが2個、合計9個の文字全部を1列に並べる
  LET n=3 !異なる文字の数
  LET r=9
  DATA 4,3,2 !(A,B,C)の個数
  LET S$="ABC"
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 4月25日(日)10時26分2秒
  > No.1199[元記事へ]

つづき

別解
 以下の2つの改修を行う

1.同じものを含む順列の「場合の数」 (p+q+ … +r)!/(p!*q!* … *r!)通り
   EXTERNAL FUNCTION PermFactorialM(B(),M)
  の計算

 たとえば、aaabbcccの8文字の並べ方は何通りか。

 まず、aは8つの中から3個所に置けるので、comb(8,3)通りある。
 次に、bは残った5つの中から2つ置けるので、comb(5,2)通りある。
 残ったcは最後の3個に必ず入りますから、comb(3,3)=1通り。
 comb(8,3)*comb(5,2)*1通りになる。

 comb関数の積で求まる。最初、全体数は見えないので、c~aの順に計算する。


2.カウンタの実現方式
 インクリメントカウンタ(+1)を使って、繰り返し文で表現する。
 カウンタ値G()が0からオーバーフローになるまで行う。
 ディクリメントカウンタ(-1)でも可能。
!問題
! BASEBALLの8文字から4文字選ぶ組合せ、順列
!答え
! 26通り、354通り

LET N=5 !異なる文字の数
LET R=4
DATA 2,2,1,2,1 !(A,B,E,L,S)の個数

PUBLIC STRING S$
LET S$="ABELS"


DIM C(N) !それぞれの個数
MAT READ C

LET S=0 !総数
FOR i=1 TO N
   LET S=S+C(i)
NEXT i
IF S<R THEN
   PRINT "数が足りません。";S
   STOP
END IF


DIM G(N) !(A,B,E,L,S)の個数
MAT G=ZER

DIM CC(0 TO S),PP(0 TO S) !各Rに対する組合せ、順列
MAT CC=ZER
MAT PP=ZER


LET CY=0 !桁上がり
DO UNTIL CY=1 !加算オーバーフローなら、終了する

!MAT PRINT G; !debug

   LET S=SUM(G,1,N)
   IF S=R THEN !該当するものを表示する
      PRINT "(";
      FOR k=1 TO N
         PRINT REPEAT$(" "&S$(k:k),G(k));
      NEXT k
      PRINT " ) 組"

      DIM A(R) !同じものを含む順列を生成する
      FOR i=0 TO PermFactorialM(G,N)-1
         CALL Num2PermFactorialM(i, A,R,G,N)

         FOR k=1 TO R !表示する
            PRINT S$(A(k):A(k));
         NEXT k
         PRINT
      NEXT i
   END IF

   LET CC(S)=CC(S)+1 !組合せ
   LET PP(S)=PP(S)+PermFactorialM(G,N) !順列


   LET CY=1 !インクリメント・カウンタ(+1)
   FOR k=N TO 1 STEP -1 !下の桁から
      LET W=G(k)+CY !加算する
      LET RADIX=C(k)+1 !基数

      LET CY=INT(W/RADIX) !この桁
      LET G(k)=W-CY*RADIX

      IF CY=0 THEN EXIT FOR !「桁上げ」なし
   NEXT k

LOOP

!!!MAT PRINT CC; !debug
!!!MAT PRINT PP;
PRINT "場合の数=";CC(R);PP(R)


END


EXTERNAL FUNCTION SUM(G(),S,E) !Σ[k=S,E]{G(k)}
LET t=0
FOR k=S TO E
   LET t=t+G(k)
NEXT k
LET SUM=t
END FUNCTION

EXTERNAL FUNCTION PermFactorialM(B(),M) !同じものを含む順列の「場合の数」 (p+q+ … +r)!/(p!*q!* … *r!)通り
LET s=B(M) !総数 r, … ,q+ … +r,p+q+ … +r
LET t=1 !組合せ comb(r,r), … ,comb(q+ … +r,q),comb(p+q+ … +r,p)
FOR i=M-1 TO 1 STEP -1
   LET s=s+B(i)
   LET t=t*COMB(s,B(i)) !組合せ順列
NEXT i
LET PermFactorialM=t
END FUNCTION

EXTERNAL SUB Num2PermFactorialM(h, A(),N,B(),M) !番号から順列パターンを生成する ※辞書式順序
DIM w(M)
MAT w=B !copy it
LET v=h
FOR i=1 TO N
   FOR j=1 TO M !左端を1~Mとして
      IF w(j)>0 THEN !その左端を除いた残りで最大の順列をつくる
         LET w(j)=w(j)-1
         !!!MAT PRINT w;
         LET t=PermFactorialM(w,M) !その順列の番号を求める
         IF v<t THEN EXIT FOR
         LET v=v-t
         LET w(j)=w(j)+1
      END IF
   NEXT j
   LET A(i)=j !次へ
NEXT i
END SUB
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 4月26日(月)11時11分5秒
  > No.1200[元記事へ]

かくらん順列(完全順列、乱列)の数、モンモール数(Montmort number)
!●場合の数 d[n]

FOR n=0 TO 10
   PRINT n; Derangements(n); Derangements2(n); Derangements3(n)
NEXT n

FOR n=0 TO 10 !lim[n→∞]{d(n)/n!}
   PRINT n; Derangements(n)/FACT(n)
NEXT n
PRINT EXP(-1)


!●並びの列挙

LET N=4 !n個の並び
DIM A(N)

LET c=0

LET i=0 !順列0~(FACT(N)-1)通りの中から
DO WHILE i<=FACT(N)-1
   CALL Num2PermFactorial(i, A,N) !番号から順列を生成する

   FOR k=1 TO N !変化しない要素を除く
      IF A(k)=k THEN EXIT FOR
   NEXT k
   IF k>N THEN !該当するなら
      LET c=c+1
      MAT PRINT A;
      LET i=i+1
   ELSE
      LET i=i+FACT(N-k) !スキップする
   END IF
LOOP

PRINT "場合の数=";c


!●パスカルの三角形
! 累乗根表、対数表、三角関数表のようにこの表を使った計算

!反転公式 a[n]=Σ[k=0,n]comb(n,k)*b[k] ⇔ b[n]=Σ[r=0,n](-1)^(n-r)*comb(n,r)*a[r]

LET N=10 !段数
DIM P(0 TO N,0 TO N) !パスカルの三角形 ※下三角行列

MAT P=ZER
LET P(0,0)=1 !左詰め
FOR i=1 TO N
   LET P(i,0)=1 !comb(n,n)=comb(n,0)=1
   FOR j=1 TO i !comb(n,r)=comb(n-1,r-1)+comb(n-1,r)
      LET P(i,j)=P(i-1,j-1)+P(i-1,j) !左上+上
   NEXT j
NEXT i
MAT PRINT USING(REPEAT$("#### ",N+1)): P !※桁数が多い場合、#を増やす

DIM b(0 TO N) !順列の「場合の数」 ※階乗数
FOR i=0 TO N
   LET b(i)=FACT(i)
NEXT i

DIM T(0 TO N,0 TO N),x(0 TO N) !P*x=bを解く
MAT T=INV(P)
MAT x=T*b

MAT PRINT x; !モンモール数


END


EXTERNAL FUNCTION Derangements(n) !かくらん順列(完全順列、乱列)の数
LET t=0
FOR k=0 TO n
   LET t=t+FACT(n)*(-1)^k/FACT(k) !FACT(n)*Σ{(-1)^k/FACT(k)}
NEXT k
LET Derangements=t
END FUNCTION

EXTERNAL FUNCTION Derangements2(n) !かくらん順列(完全順列、乱列)の数 ※漸化式による
LET d1=1 !第1項
IF n=0 THEN
   LET d=d1
ELSE
   FOR k=2 TO n !第2項以降
      LET d=k*d+(-1)^k !d[n]=n*d[n-1]*(-1)^n
      LET d1=d
   NEXT k
END IF
LET Derangements2=d
END FUNCTION

EXTERNAL FUNCTION Derangements3(n) !かくらん順列(完全順列、乱列)の数 ※漸化式による
LET d1=1 !第1項
IF n=0 THEN
   LET d=d1
ELSE
   LET d2=0 !第2項
   IF n=1 THEN
      LET d=d2
   ELSE
      FOR k=2 TO n !第3項以降
         LET d=(k-1)*(d2+d1) !d[n]=(n-1)*(d[n-1]+d[n-2])
         LET d1=d2
         LET d2=d
      NEXT k
   END IF
END IF
LET Derangements3=d
END FUNCTION

EXTERNAL SUB Num2PermFactorial(h, A(),N) !番号から順列パターンを生成する ※辞書式順序
LET v=h !非負の10進数整数を階乗進数へ
FOR j=N TO 1 STEP -1 !下の桁から順に
   LET w=N-j+1
   LET t=INT(v/w)
   LET A(j)=v-t*w +1 !階乗進数の各桁の値+1 A[1..N]=(N-1)! … 3! 2! 1! 0!
   LET v=t
NEXT j
FOR j=N-1 TO 1 STEP -1 !順列パターンへ
   FOR k=j+1 TO N
      IF A(k)>=A(j) THEN LET A(k)=A(k)+1
   NEXT k
NEXT j
END SUB
 

パターン数は?

 投稿者:GAI  投稿日:2010年 4月26日(月)20時29分31秒
  次のような問題を解決できるためには、どんな構成のプログラムなのか知りたい。

(1)白2個、赤2個、青2個(見分けが付かないと仮定する。)
を円順列にした場合の違いのパターン数は?
実際の配列と、これを一般化(個数を変えたり、種類を増やしたりできるように・・・)
するにはどんなプログラムなのか?


(2)同じものがそれぞれたくさんある3色のビーズで、腕輪を作るとする。
ビーズをP個使って作るとすれば、腕輪は何通り出来るか?

P:4,5,6,7,8,9での実際の配列を作り出してもらいたい。

またこれを一般化して異なるm色のビーズで合計p個のビーズの腕輪を作ると異なるものは何個になるのでしょうか?
これは式で書けるのでしょうか?(ただし、裏返しは考えないものとします。)
 

Re: 前景色と背景色の変更

 投稿者:白石 和夫  投稿日:2010年 4月27日(火)08時12分37秒
  > No.1198[元記事へ]

> >    windres: no resources
> >    basic.lpr(125,1) Error: Error while compiling resources
> >    basic.lpr(125,1) Fatal: There were 1 errors compiling module, stopping
ソースを マイ ドキュメント に置くと再現しました。
FPC,Lazarusでは,Windowsのロングファイル名は使えないことになっています。
ソースをマイドキュメントとかデスクトップに置くのはトラブルの原因になると思います。
 

Re: パターン数は?

 投稿者:山中和義  投稿日:2010年 4月27日(火)10時37分52秒
  > No.1202[元記事へ]

GAIさんへのお返事です。

> 実際の配列と、これを一般化(個数を変えたり、種類を増やしたりできるように・・・)
> するにはどんなプログラムなのか?

No.1199[元記事へ] または No.1200[元記事へ]では、
(直線)順列が生成できるので、これを元に作成できると思います。
ただ、符号化・復号化、辞書順による生成ができませんので、
「パターンそのもの」を記録して、既出のものかどうかのチェックになると思います。
具体例は以下のプログラムを参考にしてください。

「問題1」は、(1つ前段階ですので)そのサンプルを掲載します。
「エラトステネスの篩い」のように、辞書順(自然数の小さい順)にパターンを生成して、
その対称のもの(倍数)を除いていきます。
「篩い」は、符号化・復号化して「0以上の整数」で管理しています。

!白2個、赤2個、青2個を円順列にした場合の数は?


LET N=3 !異なる色の数
DATA 2,2,2 !(白,赤,青)の個数

!PUBLIC STRING S$
LET S$="白赤青"


DIM C(N) !それぞれの個数
MAT READ C

LET S=0 !総数
FOR i=1 TO N
   LET S=S+C(i)
NEXT i
IF S<R THEN
   PRINT "数が足りません。";S
   STOP
END IF

DIM G(S) !(白,赤,青)の並び
MAT G=ZER

DIM F(0 TO PermFactorialM(C,N)-1) !篩い
MAT F=ZER

LET x=0
FOR i=0 TO PermFactorialM(C,N)-1 !「同じものを含む順列」を円型に並べる

   CALL Num2PermFactorialM(i, G,S,C,N)
   IF F(i)=0 THEN

   !MAT PRINT G;
      FOR k=1 TO S !「素」の並びを表示する
         PRINT S$(G(k):G(k));
      NEXT k
      PRINT
      LET x=x+1 !+1

      !!!CALL FilterNecklace(F,G,S,C,N) !反転(裏返し) ※数珠順列 ←←←←←

      FOR j=1 TO S-1 !篩いにかける
         LET w=G(1) !右シフト ※時計まわりに回転する
         FOR k=1 TO S-1
            LET G(k)=G(k+1)
         NEXT k
         LET G(S)=w

         LET F(PermFactorialM2Num(G,S,C,N))=1 !この並びは対称なため削除する

         !!!CALL FilterNecklace(F,G,S,C,N) !反転(裏返し) ※数珠順列 ←←←←←
      NEXT j

   END IF

NEXT i

PRINT "場合の数=";x

END


EXTERNAL SUB FilterNecklace(F(),G(),S,C(),N) !反転(裏返し)の篩い
DIM GR(S)
MAT GR=G !反転(裏返し)
CALL reverse(GR,S)
LET F(PermFactorialM2Num(GR,S,C,N))=1 !この並びは対称なため削除する
END SUB

EXTERNAL SUB reverse(A(),N) !並びを逆順にする
FOR i=1 TO INT(N/2)
   LET t=A(i) !swap it
   LET A(i)=A(N-i+1)
   LET A(N-i+1)=t
NEXT i
END SUB


EXTERNAL FUNCTION PermFactorialM(B(),M) !同じものを含む順列の「場合の数」 (p+q+ … +r)!/(p!*q!* … *r!)通り
LET s=B(M) !総数 r, … ,q+ … +r,p+q+ … +r
LET t=1 !組合せ comb(r,r), … ,comb(q+ … +r,q),comb(p+q+ … +r,p)
FOR i=M-1 TO 1 STEP -1
   LET s=s+B(i)
   LET t=t*COMB(s,B(i)) !組合せ順列
NEXT i
LET PermFactorialM=t
END FUNCTION

EXTERNAL FUNCTION PermFactorialM2Num(A(),N,B(),M) !順列パターンに番号を付ける ※辞書式順序
DIM w(M)
MAT w=B !copy it
LET v=0
FOR i=1 TO N-1 !左端に着目する
   LET t=A(i)
   FOR j=1 TO t-1 !左端を1~A(i)-1として
      IF w(j)>0 THEN !その左端を除いた残りで最大の順列をつくる
         LET w(j)=w(j)-1
         !!!MAT PRINT w; !debug
         LET v=v+PermFactorialM(w,M) !その順列の番号を求める
         LET w(j)=w(j)+1
      END IF
   NEXT j
   LET w(t)=w(t)-1 !左端を消して、次へ
NEXT i
LET PermFactorialM2Num=v
END FUNCTION

EXTERNAL SUB Num2PermFactorialM(h, A(),N,B(),M) !番号から順列パターンを生成する ※辞書式順序
DIM w(M)
MAT w=B !copy it
LET v=h
FOR i=1 TO N
   FOR j=1 TO M !左端を1~Mとして
      IF w(j)>0 THEN !その左端を除いた残りで最大の順列をつくる
         LET w(j)=w(j)-1
         !!!MAT PRINT w;
         LET t=PermFactorialM(w,M) !その順列の番号を求める
         IF v<t THEN EXIT FOR
         LET v=v-t
         LET w(j)=w(j)+1
      END IF
   NEXT j
   LET A(i)=j !次へ
NEXT i
END SUB


> これは式で書けるのでしょうか?

               円順列  数珠順列
異なるn個から
  すべて          (n-1)!  (n-1)!/2
  重複を許さず r個選ぶ  comb(n,r)*(r-1)!  comb(n,r)*(r-1)!/2
  重複を許して r個選ぶ  ?    ? ← 問題2
同じものがp個、q個、…、r個ずつから
         すべて   ?    ? ← 問題1
  重複を許さず r個選ぶ  ?    ?


問題1は、メビウス関数、オイラー関数を使って表現できたと思います。
 

Re: パターン数は?

 投稿者:山中和義  投稿日:2010年 4月27日(火)12時55分56秒
  > No.1204[元記事へ]

>(2)同じものがそれぞれたくさんある3色のビーズで、腕輪を作るとする。
> ビーズをP個使って作るとすれば、腕輪は何通り出来るか?

問題2の方がさらに簡潔に記述できます。
同様に(直線)重複順列から「篩い」を使って対称を排除しています。
!n色の玉からr個使って数珠をつくるとき、その「場合の数」は?

!参考サイト
! 3色 http://www.research.att.com/~njas/sequences/A001867
! 4色 http://www.research.att.com/~njas/sequences/A001868
! 5色 http://www.research.att.com/~njas/sequences/A001869

LET N=3 !異なる色の数
LET R=5 !選ぶ数

!PUBLIC STRING S$
LET S$="白赤青黒黄紫緑"


DIM G(R) !(白,赤,青,…)の並び
MAT G=ZER

DIM F(0 TO N^R-1) !篩い
MAT F=ZER

LET x=0
FOR i=0 TO N^R-1 !「同じものを含む順列」を円型に並べる

   CALL Num2ReptPerm(i, G,N,R)
   IF F(i)=0 THEN

   !MAT PRINT G;
      FOR k=1 TO R !「素」の並びを表示する
         PRINT S$(G(k):G(k));
      NEXT k
      PRINT
      LET x=x+1 !+1

      !CALL FilterNecklace(F,G,N,R) !反転(裏返し) ※数珠順列 ←←←←←

      FOR j=1 TO R-1 !篩いにかける
         LET w=G(1) !右シフト ※時計まわりに回転する
         FOR k=1 TO R-1
            LET G(k)=G(k+1)
         NEXT k
         LET G(R)=w

         LET F(ReptPerm2Num(G,N,R))=1 !この並びは対称なため削除する

         !CALL FilterNecklace(F,G,N,R) !反転(裏返し) ※数珠順列 ←←←←←
      NEXT j

   END IF

NEXT i

PRINT "場合の数=";x

END


EXTERNAL SUB FilterNecklace(F(),G(),N,R) !反転(裏返し)の篩い
DIM GR(R)
MAT GR=G !反転(裏返し)
CALL reverse(GR,R)
LET F(ReptPerm2Num(GR,N,R))=1 !この並びは対称なため削除する
END SUB

EXTERNAL SUB reverse(A(),N) !並びを逆順にする
FOR i=1 TO INT(N/2)
   LET t=A(i) !swap it
   LET A(i)=A(N-i+1)
   LET A(N-i+1)=t
NEXT i
END SUB


!「順列と組合せ」の符号化・復号化などによる列挙」より
! http://6317.teacup.com/basic/bbs/1088
! http://6317.teacup.com/basic/bbs/1089

EXTERNAL FUNCTION ReptPerm2Num(A(),N,R) !順列パターンに番号を付ける ※辞書式順序
LET v=A(1)-1
FOR i=2 TO R !N進法R桁の数を10進法へ
   LET v=v*N+A(i)-1
NEXT i
LET ReptPerm2Num=v
END FUNCTION

EXTERNAL SUB Num2ReptPerm(h, A(),N,R) !番号から順列パターンを生成する ※辞書式順序
LET v=h
LET i=R !桁位置
DO UNTIL v=0 !10進法の数をN進法R桁へ
   LET t=INT(v/N)
   LET A(i)=v-t*N+1 !1~N ※剰余
   LET v=t
   LET i=i-1
LOOP
FOR k=i TO 1 STEP -1 !残りの桁を埋める
   LET A(k)=1
NEXT k
END SUB
 

Re: パターン数は?

 投稿者:山中和義  投稿日:2010年 4月27日(火)14時31分39秒
  > No.1205[元記事へ]

つづき

●同じものを含む円順列の「場合の数」
LET N=3 !異なる色の数
DATA 2,2,2 !(白,赤,青)の個数

DIM C(N) !それぞれの個数
MAT READ C


!1/S * Σ[j|L]{φ(j) * FACT(S/j)/( FACT(p/j)*FACT(q/j)* … *FACT(r/j) )}
!ただし、S=p+q+ … +r、L=gcd(p,q,…,r)。
!また、j|Lとは、jはLの約数の意。 φ(j)は、オイラー関数。

LET S=0 !総数
FOR i=1 TO N
   LET S=S+C(i)
NEXT i

LET L=C(1)
FOR i=2 TO N
   LET L=gcd(L,C(i))
NEXT i
LET x=0
FOR j=1 TO L
   IF MOD(L,j)=0 THEN !jはLの約数
      DIM B(N)
      MAT B=(1/j)*C
      LET x=x+eul(j)*PermFactorialM(B,N)
   END IF
NEXT j
LET x=x/S

PRINT "場合の数=";x

END

EXTERNAL FUNCTION PermFactorialM(B(),M) !同じものを含む順列の「場合の数」 (p+q+ … +r)!/(p!*q!* … *r!)通り
LET s=B(M) !総数 r, … ,q+ … +r,p+q+ … +r
LET t=1 !組合せ comb(r,r), … ,comb(q+ … +r,q),comb(p+q+ … +r,p)
FOR i=M-1 TO 1 STEP -1
   LET s=s+B(i)
   LET t=t*COMB(s,B(i)) !組合せ順列
NEXT i
LET PermFactorialM=t
END FUNCTION


!整数論関連 ※UBASICより

EXTERNAL FUNCTION eul(n) !オイラー関数 φ(n)(1から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 gcd(a,b) !最大公約数
DO UNTIL b=0
   LET t=b
   LET b=MOD(a,b)
   LET a=t
LOOP
LET gcd=a
END FUNCTION


●n色の玉からr個使って数珠をつくるとき、その「場合の数」は?

参考サイト
 3色 http://www.research.att.com/~njas/sequences/A001867
 4色 http://www.research.att.com/~njas/sequences/A001868
 5色 http://www.research.att.com/~njas/sequences/A001869
に式が掲載されています。
LET N=3 !異なる色の数

FOR R=1 TO 10 !選ぶ数

!1/R * Σ[j|R]{φ(j) * N^(R/j)}
!ただし、j|Rとは、jはRの約数の意。 φ(j)は、オイラー関数。

   LET x=0
   FOR j=1 TO R
      IF MOD(R,j)=0 THEN !jはRの約数
         LET x=x+eul(j)*N^(R/j)
      END IF
   NEXT j
   LET x=x/R

   PRINT R;x

NEXT R

END

!eul関数は略(上記参照)
 

Re: 前景色と背景色の変更

 投稿者:イーグル  投稿日:2010年 4月28日(水)12時36分32秒
  > No.1203[元記事へ]

白石 和夫さんへのお返事です。

 ご返信頂きありがとうございます。

> このエラーは,こちらでは再現しないのでなんともいえませんが,
> Lazarusあるいは fpcシステム固有(さらにはおそらくOS依存)の問題なので,
> Pascalの基本をいくら学んでも解決しないと思います。

 ご指摘頂きありがとうございます。

>ソースを マイ ドキュメント に置くと再現しました。
>FPC,Lazarusでは,Windowsのロングファイル名は使えないことになっています。
>ソースをマイドキュメントとかデスクトップに置くのはトラブルの原因になると思います。

 ロングファイル名ということですが、この場合は、ファイル名だけでなく、
フォルダ名やパス名が問題になってくるということなのでしょうか。
 私はソースを、マイドキュメントやデスクトップには置いていませんが、
例えば、「D:\hoge\piyopiy\BASIC\BASIC055JaSRC」という
パスのフォルダに置いています。
因みにlazarusとfpcは、例えば
D:\piyopiy\Pascal\lazarus
D:\piyopiy\Pascal\lazarus\fpc\2.4.0
というパスにインストールしました。OSはWindows Vista Business 32bitです。

 以上のことから、以前からのパスのフォルダ、
並びに、D:\hoge\BASIC055JaSRCのフォルダ、
そしてD:\hoge\BASIC055のフォルダで、再度実行してみたのですが、
何故か今度はwindresのエラーが再現せず、
debugdg.pas(239,23) Error: Identifier not found "HasDebugMark"
debugdg.pas(241,29) Error: Identifier not found "SetDebugMarks"
debugdg.pas(251,27) Error: Identifier not found "SetDebugMarks"
debugdg.pas(302) Fatal: There were 3 errors compiling module, stopping
というエラーが出てしまいました。

 このプロジェクトは、正常な環境で実行すれば
情報や警告やエラーが出ずに実行されるものなのでしょうか。
 少し試しで、Linux系のDistributionで一般的な
Ubuntuに於いて、環境を作って実行してみましたが、
そちらは別のエラーで実行できませんでした。

 エラーの報告ばかりで申し訳ありません。
 

Re: 前景色と背景色の変更

 投稿者:白石 和夫  投稿日:2010年 4月28日(水)13時02分29秒
  > No.1207[元記事へ]

FPCは,Lazarus同梱のものには含まれていないようですが,単独で配布されているバージョンには詳しい説明書がついています。そこにWindowsでのファイル名のことも書いてあったと思います。(当然,パス全体の記述の問題です。)
十進BASICのLazarus版はWindows上で開発して,Linux上,および,MAC上でそれぞれ向けの実行ファイルを作っています。その限りにおいては,多様な環境に対応していますが,Lazarus自体が開発途上で十分に安定しているとは言えないので,その保証はありません。
なお,コンパイラは大量の警告を発しますが,それらは無視してください。
 

Re: 前景色と背景色の変更

 投稿者:白石 和夫  投稿日:2010年 4月28日(水)18時35分4秒
  > No.1207[元記事へ]

> debugdg.pas(239,23) Error: Identifier not found "HasDebugMark"
> debugdg.pas(241,29) Error: Identifier not found "SetDebugMarks"
> debugdg.pas(251,27) Error: Identifier not found "SetDebugMarks"
> debugdg.pas(302) Fatal: There were 3 errors compiling module, stopping
> というエラーが出てしまいました。
これらのエラーが出るのは,Lazarusの新バージョンでsyneditコンポーネントのパスが変更されたか,もしくは,basic.lprを読み込んでコンパイルしようとしたかのいずれかだと思います。
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 4月29日(木)11時43分32秒
  > No.1201[元記事へ]

高校数学程度で扱う円順列、数珠順列をまとめると

               円順列  数珠順列
異なるn個から
  すべて          (n-1)!  (n-1)!/2
  重複を許さず r個選ぶ  comb(n,r)*(r-1)!  comb(n,r)*(r-1)!/2
  重複を許して r個選ぶ  式1   ?
同じものがa個、b個、…、c個ずつから
  すべて          式2   ?
  重複を許さず r個選ぶ  ?    ?


式1
 1/R * Σ[j|R]{φ(j) * N^(R/j)}
 ただし、j|Rとは、jはRの約数の意。 φ(j)は、オイラー関数。

 参考 http://6317.teacup.com/basic/bbs/1206

式2
 1/S * Σ[j|L]{φ(j) * FACT(S/j)/( FACT(a/j)*FACT(b/j)* … *FACT(c/j) )}
 ただし、S=a+b+ … +c、L=gcd(a,b,…,c)。 また、j|Lとは、jはLの約数の意。

 参考 http://6317.teacup.com/basic/bbs/1206 の上


●並びを生成するサンプル・プログラム
!例題

!異なるn色の玉から(重複を許さず)r個選び、円形に並べる「場合の数」は?
!LET N=5 !異なる色の数
!LET R=3 !選ぶ数
!DATA 1,1,1,1,1 !(白,赤,青,…)の個数

!異なるn色の玉から重複を許してr個選び、円形に並べる「場合の数」は?
LET N=3 !異なる文字の数
LET R=6 !選ぶ数
DATA 10,10,10,10,10 !(白,赤,青,…)の個数 ※Rに対して十分多く

!白2個、赤2個、青2個からすべて選び、円形に並べる「場合の数」は?
!LET N=3 !異なる色の数
!LET R=6 !選ぶ数
!DATA 2,2,2 !(白,赤,青,…)の個数

!白3個、赤2個、青1個から3個選び、円形に並べる「場合の数」は?
!LET N=3 !異なる色の数
!LET R=3 !選ぶ数
!DATA 3,2,1 !(白,赤,青,…)の個数


PUBLIC STRING S$
LET S$="白赤青黒黄紫緑"


DIM C(N) !それぞれの個数
MAT READ C

LET S=SUM(C,1,N) !総数
IF S<R THEN
   PRINT "数が足りません。";S
   STOP
END IF


DIM G(N) !(白,赤,青,…)の個数
MAT G=ZER

LET x=0

LET CY=0 !桁上がり
DO UNTIL CY=1 !加算オーバーフローなら、終了する

!MAT PRINT G; !debug

   LET S=SUM(G,1,N)
   IF S=R THEN !該当するものを表示する
      PRINT "(";
      FOR k=1 TO N
         PRINT REPEAT$(" "&S$(k:k),G(k));
      NEXT k
      PRINT " ) 組"

      CALL gen_CircularPerm(G,N,R,C,x) !同じものを含む円順列、数珠順列を生成する
   END IF


   LET CY=1 !インクリメント・カウンタ(+1)より、次の組へ
   FOR k=N TO 1 STEP -1 !下の桁から
      LET W=G(k)+CY !加算する
      LET RADIX=C(k)+1 !基数

      LET CY=INT(W/RADIX) !この桁
      LET G(k)=W-CY*RADIX

      IF CY=0 THEN EXIT FOR !「桁上げ」なし
   NEXT k

LOOP


PRINT "場合の数=";x


END


EXTERNAL FUNCTION SUM(G(),S,E) !Σ[k=S,E]{G(k)}
LET t=0
FOR k=S TO E
   LET t=t+G(k)
NEXT k
LET SUM=t
END FUNCTION


EXTERNAL SUB gen_CircularPerm(G(),N,R,C(),x) !同じものを含む円順列、数珠順列を生成する
DIM A(R) !並び

DIM F(0 TO PermFactorialM(G,N)-1) !篩い
MAT F=ZER

FOR i=0 TO PermFactorialM(G,N)-1 !「同じものを含む順列」を円形に並べる

   CALL Num2PermFactorialM(i, A,R,G,N)
   IF F(i)=0 THEN

   !MAT PRINT A;
      FOR k=1 TO R !「素」の並びを表示する
         PRINT S$(A(k):A(k));
      NEXT k
      PRINT
      LET x=x+1 !+1

      !!!CALL FilterNecklace(F,A,R,G,N) !反転(裏返し) ※数珠順列 ←←←←←

      FOR j=1 TO R-1 !篩いにかける
         LET w=A(1) !右シフト ※時計まわりに回転する
         FOR k=1 TO R-1
            LET A(k)=A(k+1)
         NEXT k
         LET A(R)=w

         LET F(PermFactorialM2Num(A,R,G,N))=1 !この並びは対称なため削除する

         !!!CALL FilterNecklace(F,A,R,G,N) !反転(裏返し) ※数珠順列 ←←←←←
      NEXT j

   END IF

NEXT i
END SUB

EXTERNAL SUB FilterNecklace(F(),G(),S,C(),N) !反転(裏返し)の篩い
DIM GR(S)
MAT GR=G !反転(裏返し)
CALL reverse(GR,S)
LET F(PermFactorialM2Num(GR,S,C,N))=1 !この並びは対称なため削除する
END SUB

EXTERNAL SUB reverse(A(),N) !並びを逆順にする
FOR i=1 TO INT(N/2)
   LET t=A(i) !swap it
   LET A(i)=A(N-i+1)
   LET A(N-i+1)=t
NEXT i
END SUB


!「順列と組合せ」の符号化・復号化などによる列挙」より
! http://6317.teacup.com/basic/bbs/1088
! http://6317.teacup.com/basic/bbs/1089

EXTERNAL FUNCTION PermFactorialM(B(),M) !同じものを含む順列の「場合の数」 (p+q+ … +r)!/(p!*q!* … *r!)通り
LET s=B(M) !総数 r, … ,q+ … +r,p+q+ … +r
LET t=1 !組合せ comb(r,r), … ,comb(q+ … +r,q),comb(p+q+ … +r,p)
FOR i=M-1 TO 1 STEP -1
   LET s=s+B(i)
   LET t=t*COMB(s,B(i)) !組合せ順列
NEXT i
LET PermFactorialM=t
END FUNCTION

EXTERNAL FUNCTION PermFactorialM2Num(A(),N,B(),M) !順列パターンに番号を付ける ※辞書式順序
DIM w(M)
MAT w=B !copy it
LET v=0
FOR i=1 TO N-1 !左端に着目する
   LET t=A(i)
   FOR j=1 TO t-1 !左端を1~A(i)-1として
      IF w(j)>0 THEN !その左端を除いた残りで最大の順列をつくる
         LET w(j)=w(j)-1
         !!!MAT PRINT w; !debug
         LET v=v+PermFactorialM(w,M) !その順列の番号を求める
         LET w(j)=w(j)+1
      END IF
   NEXT j
   LET w(t)=w(t)-1 !左端を消して、次へ
NEXT i
LET PermFactorialM2Num=v
END FUNCTION

EXTERNAL SUB Num2PermFactorialM(h, A(),N,B(),M) !番号から順列パターンを生成する ※辞書式順序
DIM w(M)
MAT w=B !copy it
LET v=h
FOR i=1 TO N
   FOR j=1 TO M !左端を1~Mとして
      IF w(j)>0 THEN !その左端を除いた残りで最大の順列をつくる
         LET w(j)=w(j)-1
         !!!MAT PRINT w;
         LET t=PermFactorialM(w,M) !その順列の番号を求める
         IF v<t THEN EXIT FOR
         LET v=v-t
         LET w(j)=w(j)+1
      END IF
   NEXT j
   LET A(i)=j !次へ
NEXT i
END SUB
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 5月 2日(日)10時55分20秒
  > No.1210[元記事へ]

N個のさいころを振ったとき、和がWになる「場合の数」

●6進法、6進カウンタ
LET N=3 !振る回数

DIM R(0 TO N*6)
MAT R=ZER

FOR i=0 TO 6^N-1 !6進法
   LET a=i
   LET t=0
   DO WHILE a>0 !進数変換
      LET aa=INT(a/6)
      LET t=t+(a-aa*6) !mod(a,6)
      LET a=aa
   LOOP
   LET t=N*6-t !0~5を1~6へ
   LET R(t)=R(t)+1
NEXT i

FOR W=0 TO N*6 !和
   PRINT W; R(W)
NEXT W

END

●一般式
LET N=3 !振る回数

FOR W=0 TO N*6 !和
   LET A=W-N
   LET t=0
   FOR k=0 TO INT(A/6)
      LET t=t+(-1)^k*COMB(N+(A-6*k)-1,A-6*k)*COMB(N,k) !一般式による
   NEXT k
   PRINT N+A; t
NEXT W

END

●漸化式
LET N=3 !振る回数

FOR W=0 TO N*6 !和
   PRINT W; S(N,W) !漸化式による
NEXT W

END

EXTERNAL FUNCTION S(N,W)
LET t=0
IF N=1 THEN !S(1,1)=S(1,2)=S(3,1)=S(4,1)=S(5,1)=S(6,1)=1
   IF W>=1 AND W<=6 THEN LET t=1
ELSE
   FOR i=1 TO 6 !1つ目のさいころは1~6、残りは(N-1)個のさいころとの和
      LET t=t+S(N-1,W-i)
   NEXT i
END IF
LET S=t
END FUNCTION
回数Nが増えると、この再帰処理では同じ値を何回も計算することになる。


●母関数
LET N=3 !振る回数

!N*6次多項式 (x+x^2+x^3+x^4+x^5+x^6)^N を展開したとき、x^W の係数

DIM P(0 TO N*6)
MAT P=ZER !定数1
LET P(0)=1
LET PP=0 !次数

DIM Q(0 TO 6)
LET Q(0)=0 !x+x^2+x^3+x^4+x^5+x^6
FOR i=1 TO 6
   LET Q(i)=1
NEXT i
LET QQ=6

FOR i=0 TO N-1 !Q(x)^N
   CALL PolyMul(PP,P,QQ,Q, PP,P)
NEXT i

FOR W=0 TO N*6 !和
   PRINT W; P(W)
NEXT W

END

EXTERNAL SUB PolyMul(AA,A(),BB,B(), CC,C()) !1変数多項式の乗算 C=A*B
DIM W(0 TO AA+BB) !作業用
MAT W=ZER
FOR i=0 TO AA !最高次数まで
   FOR j=0 TO BB
      LET W(i+j)=W(i+j)+A(i)*B(j) !※筆算参照
   NEXT j
NEXT i
LET CC=AA+BB !copy it
MAT C=W
END SUB

これは、筆算での次の表の「和」を「次数」、「場合の数」を「係数」に対応できる。

 和     2回目      場合の数
    目 1 2 3 4 5 6     目 1 2 3 4 5 6
    1 2  3  4  5  6  7     1 1  1  1  1  1  1
    2 3  4  5  6  7  8     2 1  1  1  1  1  1
1回目 3 4  5  6  7  8  9     3 1  1  1  1  1  1
    4 5  6  7  8  9 10     4 1  1  1  1  1  1
    5 6  7  8  9 10 11     5 1  1  1  1  1  1
    6 7  8  9 10 11 12     6 1  1  1  1  1  1

 まとめると、
       和 0 1 2 3 4 5 6 7 8 9 10 11 12 ←次数
    場合の数 0 0 1 2 3 4 5 6 5 4 3  2  1  ←係数


 和     3回目      場合の数
    目 1 2 3 4 5 6     目 1 2 3 4 5 6
    2  3  4  5  6  7  8     2 1  1  1  1  1  1
    3  4  5  6  7  8  9     3 2  2  2  2  2  2
2回目 4  5  6  7  8  9 10     4 3  3  3  3  3  3
    5  6  7  8  9 10 11     5 4  4  4  4  4  4
    6  7  8  9 10 11 12     6 5  5  5  5  5  5
        :             :
   12 13 14 15 16 17 18    12 1  1  1  1  1  1

 まとめると、
       和 0 1 2 3 4 5 6  7  8  9  10 11 12 13 14 15 16 17 18
    場合の数 0 0 0 1 3 6 10 15 21 25 27 27 25 21 15 10 6  3  1

同様に表をつくっていく。
 

Re: センター試験程度のプログラム演習

 投稿者:GAI  投稿日:2010年 5月 3日(月)10時19分35秒
  > No.1211[元記事へ]

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

> ●一般式
> <PRE>
> LET N=3 !振る回数
>
> FOR W=0 TO N*6 !和
>    LET A=W-N
>    LET t=0
>    FOR k=0 TO INT(A/6)
>       LET t=t+(-1)^k*COMB(N+(A-6*k)-1,A-6*k)*COMB(N,k) !一般式による
>    NEXT k
>    PRINT N+A; t
> NEXT W
>
> END
> </PRE>

いったいこの一般式はどこからどう出てくるものなのでしょうか?
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 5月 3日(月)12時42分4秒
  > No.1212[元記事へ]

GAIさんへのお返事です。

> LET t=t+(-1)^k*COMB(N+(A-6*k)-1,A-6*k)*COMB(N,k) !一般式による
> いったいこの一般式はどこからどう出てくるものなのでしょうか?

(x+x^2+x^3+x^4+x^5+x^6)^n
={x * (1+x+x^2+x^3+x^4+x^5)}^n  xで括る
=x^n * (1+x+x^2+x^3+x^4+x^5)^n  n乗を分配
=x^n * {(1-x^6)/(1-x)}^n  初項a,公比rの等比数列{a*r^k}の和 Σ[k=0,n]{a*r^k}=a*(1-r^(n+1))/(1-r)より
=x^n * (1-x^6)^n * (1-x)^(-n)  n乗を分配
=x^n * ∑[k=0,n]{COMB(n,k)*(-1)^n*x^(6*n)} * ∑[r=0,∞]{COMB(n+r-1,r)*x^r}
    二項係数より           負の二項係数より

x^wの係数は、w=n+aとすると
第1項x^nはnを表し、第2と3項でx^aを表すと考えると、x^(6*n)とx^rより、a=6*n+r
したがって、r=a-6*n
また、r=a-6*n≧0(0以上の整数)より、n≦INT(a/6)
これより
∑[k=0,INT(a/6)](-1)^k*COMB(n,k)*COMB(n+(a-6*k)-1,(a-6*k))
となる。

また、aを消去すると
∑[k=0,INT((w-n)/6)](-1)^k*COMB(n,k)*COMB(w-6*k-1,w-n-6*k)
となる。
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 5月 4日(火)19時06分22秒
  > No.1211[元記事へ]

N個のさいころを振ったとき、積がMになる「場合の数」

 M=2^a*3^b*5^c と素因数分解する。
 3変数多項式 (1+x+x^2+y+z+x*y)^N を展開したとき、x^a*y^b*z^c の係数

参考サイト
「数学のいずみ」 http://izumi-math.jp/
 「数学トピックス」 ※左上
  「サイコロの目の積の場合の数」 ※上から1/2あたり
   http://izumi-math.jp/H_Katou/saikoro/seki.pdf

mathematicaに負けないように多変数多項式を展開してみました。
LET N=4 !振る回数
LET M=24 !積 2^3*3^1*5^0

DIM Q(6,2) !第p項 K*x^a*y^b*z^c の係数と次数
CALL MPolySet(1, 1,0,0,0, Q) !  1=1*x^0*y^0*z^0(=1、x=2,y=3,z=5)
CALL MPolySet(2, 1,1,0,0, Q) !  x=1*x^1*y^0*z^0(=2)
CALL MPolySet(3, 1,2,0,0, Q) !x^2=1*x^2*y^0*z^0(=4)
CALL MPolySet(4, 1,0,1,0, Q) !  y=1*x^0*y^1*z^0(=3)
CALL MPolySet(5, 1,0,0,1, Q) !  z=1*x^0*y^0*z^1(=5)
CALL MPolySet(6, 1,1,1,0, Q) !x*y=1*x^1*y^1*z^0(=6)
LET QQ=6 !項の数

DIM P(1000,2) !※高々
MAT P=ZER !定数1
CALL MPolySet(1, 1,0,0,0, P)
LET PP=1

FOR i=1 TO N !Q(x,y,z)^n
   CALL MPolyMul(PP,P, QQ,Q,  PP,P)

   PRINT PP !debug
   FOR k=1 TO PP
      PRINT P(k,1);P(k,2)
   NEXT k
NEXT i


FOR i=1 TO PP !結果を表示する
   IF P(i,2)=M THEN EXIT FOR
NEXT i
IF i>PP THEN
   PRINT "積=";M;" 0 通り"
ELSE
   PRINT "積=";M; P(i,1);"通り"
END IF

END


!補助ルーチン

EXTERNAL FUNCTION Degree2Num(a,b,c) !次数(a,b,c)を自然数へ符号化する
LET Degree2Num=2^a * 3^b * 5^c !※n変数ならn番目までの素数を使う
END FUNCTION


!演算関連

EXTERNAL SUB MPolySet(p, K,a,b,c, X(,)) !第p項 K*x^a*y^b*z^c を定義する
LET X(p,1)=K !係数
LET X(p,2)=Degree2Num(a,b,c) !次数
END SUB

EXTERNAL SUB MPolyMul(AA,A(,),BB,B(,), XX,X(,)) !多変数多項式の積 A*B→X
LET WW=AA*BB !作業用
DIM W(WW,2)
FOR i=1 TO AA !項どうしを掛け合わす
   LET t=(i-1)*BB
   FOR j=1 TO BB
      LET W(t+j,1)=A(i,1)*B(j,1) !係数
      LET W(t+j,2)=A(i,2)*B(j,2) !次数
   NEXT j
NEXT i
CALL MPolySimplify(WW,W) !同類項をまとめる
CALL MPolyCopy(WW,W, XX,X) !結果を返す
END SUB

EXTERNAL SUB MPolySimplify(AA,A(,)) !同類項をまとめる
LET WW=0
FOR i=1 TO AA
   IF A(i,1)>0 THEN !係数が0のものを篩う
      LET WW=WW+1
      LET A(WW,1)=A(i,1) !copy it
      LET A(WW,2)=A(i,2)

      LET t=A(i,2) !同類項を探す
      FOR j=i+1 TO AA
         IF t=A(j,2)THEN !次数が同じなら、同類項
            LET A(WW,1)=A(WW,1)+A(j,1) !前方へ吸収する
            LET A(j,1)=0 !後方は削除する
            LET A(j,2)=0
         END IF
      NEXT j

      IF A(WW,1)=0 THEN LET WW=WW-1 !係数が0なら、無効!
   END IF
NEXT i
LET AA=WW
END SUB

EXTERNAL SUB MPolyCopy(AA,A(,), BB,B(,)) !代入 A→B
MAT B=ZER
FOR i=1 TO AA !copy it
   LET B(i,1)=A(i,1)
   LET B(i,2)=A(i,2)
NEXT i
LET BB=AA
END SUB
 

USBメモリから起動できますか

 投稿者:kikiriri  投稿日:2010年 5月 6日(木)06時28分52秒
  USBフラッシュメモリーにダウンロード、インストールして、
USBにさしてTBのように利用することは可能ですか?
 

レゾルベント

 投稿者:TOSA  投稿日:2010年 5月 6日(木)13時56分14秒
  行列の固有値を一般化したものとしてスペクトルやレゾルベントがあるということを
ある本で見ました。固有値は分かるのですがスペクトルとレゾルベントが分かりません。
行列を  {{2,3},{5,6}}という2×2行列とした場合どのような計算をすればスペクトルとレゾルベントがもとまるのでしょうか。計算方法を教えていただけないでしょうか。
 

懸垂曲線について教えてください

 投稿者:北城文弘メール  投稿日:2010年 5月 7日(金)17時28分14秒
  懸垂曲線について教えてください。

  曲線の式 y=a*COSH(x/a)

教えてほしいのは、
  a (パラメータ,カテナリー数,媒介数と多くの名前)
    を決める、

1) T=張力の大きさ
2)θ=水平方向と垂直方向の張力を決める
3)他必要と思われるもの(曲線の全長とか)

  ここに

   X=T*cosθ(水平張力)
   W=単位重量(Kg/M)
   g=重力加速度(m/sec^2)

  とおくと
          a=X/(W*g)
                   になるようです。

   私なりに調べてみましたが、微分積分が出てきて
   さっぱり解りません。(記憶が薄くなっている、忘れた?)

何方様か詳しく教えてくだされば幸いです。

後先になりましたが大変お世話(仕事に使用)になっている、
(仮称)十進 BASIC の益々の発展を願っています。
 

Re: 懸垂曲線について教えてください

 投稿者:山中和義  投稿日:2010年 5月 7日(金)20時39分14秒
  > No.1217[元記事へ]

北城文弘さんへのお返事です。

aと懸垂曲線の導出が紹介されています。

http://teenaka.at.webry.info/200612/article_5.html
 

Re: USBメモリから起動できますか

 投稿者:白石 和夫  投稿日:2010年 5月 8日(土)09時01分42秒
  > No.1215[元記事へ]

kikiririさんへのお返事です。

USBメモリにインストールして使うことは可能ですが,
「TBのように利用する」というのがどういうことかわからないので,
それ以上はなんともいえません。
 

Re: USBメモリから起動できますか

 投稿者:kikiriri  投稿日:2010年 5月 8日(土)09時44分35秒
  > No.1220[元記事へ]

白石 和夫さんへのお返事です。

> kikiririさんへのお返事です。
>
> USBメモリにインストールして使うことは可能ですが,
> 「TBのように利用する」というのがどういうことかわからないので,
> それ以上はなんともいえません。

USBメモリにインストールして使えるというだけでありがたい情報です。

ありがとうございます。

早速試してみます。

白石 和夫さんへ

 kikiririより

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

Re: USBメモリから起動できますか  すみません編集しました

 投稿者:kikiriri  投稿日:2010年 5月 8日(土)10時44分5秒
  > No.1221[元記事へ]

白石 和夫さんへのお返事です。



> > kikiririさんへのお返事です。
> >
> > USBメモリにインストールして使うことは可能ですが,
> > 「TBのように利用する」というのがどういうことかわからないので,
> > それ以上はなんともいえません。
>
> USBメモリにインストールして使えるというだけでありがたい情報です。
>
> ありがとうございます。
>
> 早速試してみます。
>
> 白石 和夫さんへ
>
>  kikiririより
>
>  早速のご返信ありがとうございます。

成功しました2台あるうちのwindows7機でダウンロードインストールして、
XP機でサンプルプログラム動作しました。

ただ、ダウンロードに失敗するので、右クリック対象を保存、保存先にメモリースティック
で成功しましたが、途中で、メッセージが出てきて、はいをクリックしたら、
よくわからない状態になりました。(お気に入りにショートカットができていた??)

ちなみに、windows7機には、最初からハードディスクにインストールしてありました。

乱文失礼

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

電車の流れをシュミレーション(部分複線化)

 投稿者:会社員2  投稿日:2010年 5月 8日(土)23時19分51秒
  ゴールデンウィーク中、単線区間のある電車に乗りました。

電車に乗ってみると線路は部分複線化がされていて比較的スムースに電車は進んでいきました。

全区間を複線化するとおそらく自由度が広がり、電車を能力限界付近まで動かすことができ、もっとスムースになりそうでした。

 でも、実際には複線化しようとすると橋梁やトンネルになるような場所など環境上限界があるところや幅員するための土地取得をする際に所有者の理解が得られなかったり、或いは、所有者の理解を得られたとしても その場所が都市部にあり土地単価が高く経済的に設置が困難な時もあります。

こうした社会的要因を少し抽象化いくと この問題は、情報工学では情報量の流れ、交通工学では車の流れと言った形式の問題として扱われ、
応用数学では「待ち行列」とか言った問題に近い問題になりそうです。
電車の「複線化」は、車で言えば「上下線」を作ったり、「2車線化」、「3車線化」することであり、電車の駅での「停車」は 車での「信号待ち」と言えます。

 ただ電車での複線化問題は 道路では比較的見られず、類似する問題は街中の狭い路地裏通りや人里離れた農村の農道など少ない感じがします。 路地裏のような道が比較的目に付くのは 急速に発展したため都市計画がうまくいかなかった都市や都市計画を立案すること自体が難しい昔ながらの城下町だったところなどが考えられ、こうした都市・町は 狭い路地裏を多数抱えていると思われます。


 又、車の場合、そうした「路地裏の一方通行」のような場所は車の運転中に随時で出会うが、電車では「発車時刻」が存在します。 その辺は、車と電車とで心理的にギャップを感じさせます。

そういう意味では情報通信系では通信手順に決まりごと(ネゴシエーション)があるので これが今回の電車での現象に近い印象を受けます。

日常使うパソコンのLAN通信でも物理的には上り下り2つのペア線はあるものの、上りデータの処理をしているとき、下りの処理をしていないようなので電車の単線区間と動きが非常に似ています。


そんなこんなを考えているとこの問題を抽象化してBASICでシュミレーションしたくなってきました。

本当はプログラムを書き込むべき場所とは思いますが、現在、頭を整理中です。

何をどうしたいか もやもやを晴らす意味でちょっと書き込みさせていただきました。

プログラムはでき次第、書き込むことにします。
 

Re: 前景色と背景色の変更

 投稿者:イーグル  投稿日:2010年 5月 9日(日)00時30分45秒
  > No.1209[元記事へ]

白石 和夫さんへのお返事です。

> > debugdg.pas(239,23) Error: Identifier not found "HasDebugMark"
> > debugdg.pas(241,29) Error: Identifier not found "SetDebugMarks"
> > debugdg.pas(251,27) Error: Identifier not found "SetDebugMarks"
> > debugdg.pas(302) Fatal: There were 3 errors compiling module, stopping
> > というエラーが出てしまいました。
> これらのエラーが出るのは,Lazarusの新バージョンでsyneditコンポーネントのパスが変更されたか,もしくは,basic.lprを読み込んでコンパイルしようとしたかのいずれかだと思います。

 ご返信ありがとうございます。

 プロジェクトを開く際にbasic.lpiを指定しているので、
恐らくは、前者に該当するかと思われます。

 syneditコンポーネントというのは、プログラムの部品で、
エディターに当たる部分なのだろうと推察致します。
 とりあえず、syneditに関連する例である
lazarus\examples\synedit1.lpiを実行し、
手を加えて、どこまで理解できるか試してみましたが。
syneditコンポーネントのパスというのは、
捉えるのが中々難しそうです。
 

Re: 前景色と背景色の変更

 投稿者:白石 和夫  投稿日:2010年 5月 9日(日)10時51分14秒
  > No.1225[元記事へ]

Lazarusのプロジェクトメニューにある「コンパイラオプション」で,
その他のユニットファイルで目的のコンポーネントのユニットファイルへのパスを指定します。
右端の…マークのボタンをクリックするとパスエディタが表示されるので,その4行目の
\components\synedit\units
を実態に合うように修正してください。(Explorerでフォルダ構成を調べて・・・という意味です。)
なお,basic049は,syneditを使っていないので,synedit関連のエラーはでないはずです。そちらを先に試してみると原因がはっきりすると思います。

・・・・・・というか,Lazarusの環境をコンパイルが成功する状態にまで戻すのが先でしょう。
それから,basic.lpiは配布ファイルに含まれるものを使っていますか?
basic.lpiの日付の確認も必要かと思います。
 

Re: 前景色と背景色の変更

 投稿者:山中和義  投稿日:2010年 5月10日(月)10時04分22秒
  > No.1225[元記事へ]

イーグルさんへのお返事です。

私もやってみました。参考まで、、、


概要
 WindowsMe、PentiumⅢ700MHz、192MB にて
 Lazarus fixes + fpc 2.4.0(Lazarus-0.9.28.3-25244-fpc-2.4.0-20100508-win32.exe)をインストールして
 basic.lpr の65行目と67行目をコメントアウトすると、basic.exeが作成できました。
 (日々更新されているので数字の部分は違いますが、「fixes版を選択する」ということです。)

 他の2つの最新版(Lazarus + fpc 2.4.0 または Lazarus + fpc 2.4.1)では
  debugdg.pas(239,23) Error: Identifier not found "HasDebugMark" など
 のエラーが発生してコンパイルできませんでした。
 最新版は避けた方がいいでしょう。(先に進めないので、避けざるを得ない。)
 極力障害を避けるため、インストーラが要求するフォルダ(C:\lazarus)にインストールすることを薦めます。

 また、掲示板での報告「フォルダ(ディレクトリ)名の問題」で発生するエラーの関連性はないようです。
 マイドキュメント内(C:\My Documents\hoge\BASIC055JaSRC など)でもコンパイル・リンク可能です。


詳細
●実行モジュール作成環境(フォルダ)
ソースファイル
 D:\hoge\BASIC055JaSRC\BASIC055JaSRC

コンパイラ・リンカ
 C:\lazarus
 C:\lazarus\fpc\2.4.0

 Lazarus fixes + fpc 2.4.0(Lazarus-0.9.28.3-25244-fpc-2.4.0-20100508-win32.exe)をインストール


コンパイル・リンク方法
[step1]
 lazarus を起動して、「Project」-「Open Project ...」から、basic.lpi を開く。
 または
 lazarus を起動して、「File」-「Open ...」から、basic.lpi を開く。
 または
 D:\hoge\BASIC055JaSRC\BASIC055JaSRC 内の basic.lpi をダブルクリックしてlazarus を起動する。


[step2]
 「File」-「Open ...」から、basic.lpr を開く。(Source Editor上に表示される)

 basic.lpr の65行、67行

  {$IFDEF WINDOWS}{$R manifest.rc}{$ENDIF}
  {$IFDEF WINDOWS}{$R basic.rc}{$ENDIF}
 を
  //{$IFDEF WINDOWS}{$R manifest.rc}{$ENDIF}
  //{$IFDEF WINDOWS}{$R basic.rc}{$ENDIF}
 のようにコメントアウトする。(青字に変わる)


[step3]
 「Run」-「Build all」を選ぶ。
 または
 「Run」-「Build」を選ぶ。



●実行環境(フォルダ)
 D:\hoge\BASIC055JaSRC

コンパイル・リンクしたBASIC本体を、下位階層 D:\hoge\BASIC055JaSRC\BASIC055JaSRC から
 basic.exe ファイルサイズ 24.0MB
を移動(またはコピー)する。

C:\BASICw32 内(十進BASIC内)から、次の5つの補助ファイル
 BASIC.INI
 BASIC.KW1
 BASIC.KW2
 BASIC.kwF
 BASIC.kwS
をコピーする。


実行方法
 basic.exe をダブルクリックして、「lazarus版十進BASIC」を実行する。
 

Re: 前景色と背景色の変更

 投稿者:山中和義  投稿日:2010年 5月10日(月)12時18分41秒
  > No.1227[元記事へ]

つづき(文字色、背景色の変更)

「DOSプロンプト」画面ふ~の色(黒地に白)にしてみました。
Windowsアプリケーション開発の経験がなければ少し難しいかも、、、


詳細
 「File」-「Open ...」から、MainFrm.pas を開く。(Source Editor上に表示される)

[step1]
「フォーム BASIC」ウインドウ内(「プログラムを編集する画面」にあたる)
 白い部分をクリックして、アクティブにする

Object Inspector ウインドウ内
 Propertiesタグ内
  Color
   clBlack を選ぶ。背景色が黒になる。

  Font
   Color
    clWhite を選ぶ。文字色が白になる。 ※BASIC画面で設定可能なため、特に修正は必要でない

  SelectedColor
   Backgroud
    clHighlightText を選ぶ。背景色が白系になる。
   Foreground
    clHighlight を選ぶ。文字色が黒系になる。


[step2]
「フォーム BASIC」ウインドウ内(BASIC画面での「プログラムを編集する画面」にあたる)
 アイコン SynAnySyn1 をクリックして、アクティブにする

Object Inspector ウインドウ内
 Propertiesタグ内
  StringAttr
   Foreground
    clNone を選ぶ。「Font」色になる。 ※BASIC画面でFONT色の設定と連動できる。


[step3]
 「Run」-「Build all」を選ぶ。
 または
 「Run」-「Build」を選ぶ。

 警告画面 Missing Events が表示されるので、Cancel以外を選ぶ。


●技術メモ
エディタモジュールをよく見ると

StringAttr  → ”で囲まれた文字列
Keyword、KeyAttr  → 命令
Objects、ObjectAttr  → 関数

と解釈して変更することで、機能語(命令や関数など)を色分けすることが可能です。
ただし、文法ではなく文字列による解釈となります。

.
 

Re: 前景色と背景色の変更

 投稿者:イーグル  投稿日:2010年 5月11日(火)18時39分48秒
  > No.1226[元記事へ]

白石 和夫さんへのお返事です。

> Lazarusのプロジェクトメニューにある「コンパイラオプション」で,
> その他のユニットファイルで目的のコンポーネントのユニットファイルへのパスを指定します。
> 右端の…マークのボタンをクリックするとパスエディタが表示されるので,その4行目の
> \components\synedit\units
> を実態に合うように修正してください。(Explorerでフォルダ構成を調べて・・・という意味です。)
> なお,basic049は,syneditを使っていないので,synedit関連のエラーはでないはずです。そちらを先に試してみると原因がはっきりすると思います。
>
> ・・・・・・というか,Lazarusの環境をコンパイルが成功する状態にまで戻すのが先でしょう。

 パスの設定方法はおろか、syneditの概念さえも
良く分からなかったもので、まずはsyneditについて調べてみた次第です。
 御助言を頂きましたので、パスを確認してみました。該当するパスは
$(LazarusDir)\components\synedit\units\i386-win32\
であると思われまして、実態としては、
D:\piyopiy\Pascal\lazarus\components\synedit\units\i386-win32でしたので、
特に問題はないように思われました。
絶対パスも入れてみましたが、特に変化はなかったように思われます。
 コンパイルが成功した状態というのは、なかったように思われます。

> それから,basic.lpiは配布ファイルに含まれるものを使っていますか?
> basic.lpiの日付の確認も必要かと思います。

 basic.lpiは、ソース一式に同梱されていた物を使いました。
作成日時は2010年4月28日、11:40:04でした。

 ご返信頂きありがとうございました。
 

Re: 前景色と背景色の変更

 投稿者:イーグル  投稿日:2010年 5月11日(火)18時45分41秒
  > No.1228[元記事へ]

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

 Lazarusを一旦アンインストールし、御助言の通り、
http://snapshots.lazarus.shikami.org/のwin32に於ける
Lazarus fixes + fpc 2.4.0
Lazarus-0.9.28.3-25285-fpc-2.4.0-20100510-win32.exe
(66.3Mo) をインストールしました。
 プロジェクトを開き、basic.lprの一部コメントアウトの後、
「全ての構築」に成功しました。
 そして、新フォルダに実行形式ファイルをコピーし、
十進BASICのフォルダから補助ファイルもコピーしまして、
無事に実行することができました。

 以前話題に挙がっていたMainFrm.pasを開きまして、
コードの中身は良く分からなかったのですが。
同時に出現したプレビューのような画面で入力部分を
クリックすることで、オブジェクトインスペクタで
対応する項目が選択されることが分かりました。
それはMemo1: TSynEditという項目でして、
その下部でプロパティタブのColorを編集すれば、
背景色が変えられることが分かりました。
 その後、全ての構築から、
上記と同様の方法で実行することができました。

 詳しい説明と共に、スクリーンショットを交えて、
背景色だけでなく、キーワード配色の設定までご教示頂き、
ありがとうございます。補助ファイルの部分は、
恐らく自分で解決するのは難しかったでしょうから、
教えて頂いて助かりました。
 これで目標としていた機能を得ることが出来ました。
皆様ありがとうございました。
 

補数について

 投稿者:H.T  投稿日:2010年 5月14日(金)09時48分52秒
  補数という言葉には10を基準とした場合3の補数は7,2の補数は8,100を基準とした場合25の
補数は75という使い方と、5の補数は-5,7の補数は-7という使い方と二通りの使い方があるのでしょうか。
 

Re: 補数について

 投稿者:SECOND  投稿日:2010年 5月17日(月)03時48分45秒
  > No.1231[元記事へ]

! ご参考になれれば・・

!● MOD() の補数 動作

! 10を「法」とした 数空間(0~9)にした場合、

!  -7のように(0~9)範囲外の剰余が、残る場合、
!  MOD() は、「法」 の補数に変換して出力する。

PRINT "MOD(3,10)=";MOD(3,10), "MOD(-7,10)=";MOD(-7,10) !→(+3)になる
PRINT
PRINT "MOD() による8bit 数での、Signed → Unsigned"
FOR Signed= -3 TO 2
   LET Unsigned= MOD(Signed, 256)
   PRINT Signed; "→Unsigned="; Unsigned, right$("0000000"& BSTR$(Unsigned,2),8)
NEXT Signed

!※左側の Signed が負の範囲の Unsigned については、慣習上「2の補数」
! と呼ばれている。が、実態は、上の 8bit の例で言えば、2^8 を、
! 32bit なら 2^32 を、「法」とする補数になっている。

! 8bit の例で、-1 の補数形である 255 は、-1 そのものが形を変えただけとも、言えて、
! 元の -1 に加えても、合計は、254 で、「法」の 256 には、ならない。
! 区間距離の合計が、「法」 の 256 に、なるようです。

! なぜ、255 が -1 の代りになるか、8bit( 256) の「法」のもとで加算してみる。
PRINT
PRINT "MOD(10+255, 256)=";MOD(10+255, 256); !→9になる。

! 「法」の数空間は、不自然なようで、実は、有りきたりの日常です。
! マイコン内部のようなディジタル計算回路には、adder と呼ばれる加算器があって、
! 減算器というのは、ありません。減算命令を受けた時、彼は、負数を補数に変えて、
! 加算器に送っています。
! 補数に変える方法は簡単で、bit を全て反転し、+1する。

! レジスターは、有限桁なので、「法」の剰余だけが、残る数値。

END
 

補数について

 投稿者:H.T  投稿日:2010年 5月17日(月)11時25分23秒
  丁寧な回答ありがとうございました。  

CHAIN文の使い方

 投稿者:  投稿日:2010年 5月17日(月)11時31分31秒
  十進BASICの独自拡張であるPLAY 文字列式 とASSOC PRINT 文字列式
の使い方を簡単なプログラム例で教えてもらえないでしょうか。
それとよろしければCHAIN文の使い方も簡単なプログラム例をひとつ
お願いしたいのですが。
 

Re: CHAIN文の使い方

 投稿者:白石 和夫  投稿日:2010年 5月17日(月)15時51分11秒
  > No.1234[元記事へ]

虹さんへのお返事です。

> 十進BASICの独自拡張であるPLAY 文字列式 とASSOC PRINT 文字列式
> の使い方を簡単なプログラム例で教えてもらえないでしょうか。
> それとよろしければCHAIN文の使い方も簡単なプログラム例をひとつ
> お願いしたいのですが。

もし,c:\windows\clock.avi が存在すれば,
10 PLAY "c:\windows\clock.avi"
20 END
を実行すると,play というコマンドに関して拡張子.aviに関連付けられたアプリケーションが起動して play コマンドに指定された動作を実行します。
つまり,使い方は簡単ですが,何が起こるかは環境依存です。
ASOCC PRINTも同様で,関連付けを利用してprintコマンドを実行します。printコマンドにどのアプリケーションが関連付けられ,どう処理するかは環境依存なので,実機で実験してみてください。

chain文のプログラム例は,たとえば,
10 CHAIN "FRACTAL\DRAGON.BAS"
20 END
です。ファイル指定は,相対パスでうまくいかないときは,絶対パスで指定してください。
たとえば,
10 CHAIN "C:\BASICw32\FRACTAL\DRAGON.BAS"
あるいは,
10 CHAIN "C:\Program Files\Decimal BASIC\BASICw32\FRACTAL\DRAGON.BAS"
のように。
 

CHAIN文の使い方

 投稿者:  投稿日:2010年 5月17日(月)16時30分9秒
  わかりやすい具体例をありがとうございました。  

毎日コツコツ素数づくり

 投稿者:名和長泰メール  投稿日:2010年 5月19日(水)17時56分22秒
  2010年1月はじめから、十進BASIC(2進およそ16桁モード)で素数を作っています。
ファイルに書き出し、適当な大きさで止めて、新たなファイルに書き出しています。
PC(Pentium D 2.80GHz, 1.2GB RAM)を走らせ続け、
5ヶ月かかってようやく10億個めの素数をこえました。

ご参考まで、9桁の素数(10億+1個目からの100個)までの一部です。
 

Re: 毎日コツコツ素数づくり

 投稿者:山中和義  投稿日:2010年 5月21日(金)15時37分12秒
  > No.1237[元記事へ]

名和長泰さんへのお返事です。

> 2010年1月はじめから、十進BASIC(2進およそ16桁モード)で素数を作っています。
> ファイルに書き出し、適当な大きさで止めて、新たなファイルに書き出しています。

私も作ってみました。

概要
5000個の素数を予め求めておく。(試行割算法の実用範囲)
この素数を使って、√nまでの篩いを行う。
「篩い」表の全体をメモリに実装できないので、分割して部分的に定義する。
1~約23億までの範囲の素数を求めることができる。

WindowsMe、PentiumⅢ700MHz、192MB 2進モードにて計測すると、
10万個なら 24 秒、100万個なら 315 秒(5.2分)となる。
※手続き PrimeList の場合、100万個なら20分程度となる。
ファイル出力なし、n番目の素数のみ表示では、100万個なら 17 秒、1千万個なら 305 秒(5分)となる。

出力を1つのテキストファイルにすると、10万個なら1.62MB、100万個なら18.2MBとなる。
1億個なら容量は2GB程度が予想される。いくつかに分割する必要もある。

!nまでの素数

LET t0=TIME


LET CP=5000 !※範囲を広げる場合は増やす 10,000で100億
DIM P(CP) !「篩い」の素数列
CALL PrimeList(CP,P) !2,3,5,7,11,13,17,19,23,…
!!!MAT PRINT P; !debug
LET N=P(CP)^2
PRINT USING "1 ~ ###,###,###,### までが対象範囲です。": N


!OPEN #1: NAME "TEST.TXT" !素数表
!!!OPEN #1: TextWindow1 !debug
!ERASE #1
!FOR i=1 TO CP !1~√n
!PRINT #1: i; P(i)
!NEXT i


LET SZ=4096
DIM F(SZ) !「篩い」表(奇数列 1,3,5,7,9,11,13,15,17,19,21,…) 0:素数でない、1:素数

LET c=CP !!100000001 !100,000,001番目 2,038,074,751
LET M=P(c) !!2038074751

LET top=M+1 !1~Nを範囲[top,btm]に分割する
IF MOD(top,2)=0 THEN LET top=top+1
IF top<3 THEN
   LET c=1 !2は素数
   !PRINT #1: 1; 2
END IF
DO
   LET btm=top+2*(SZ-1)
   !!!PRINT top; btm !debug

   MAT F=CON !エラトステネスの篩い
   IF top=1 THEN LET F(1)=0 !1を除く

   FOR x=2 TO CP !3~√nの素数で
      LET t=P(x)
      IF t*t>btm THEN EXIT FOR
      LET tt=MAX( INT((top-1)/t)+1, t )
      IF MOD(tt,2)=0 THEN LET tt=tt+1
      FOR k=t*tt TO btm STEP 2*t !2乗以上の倍数を削除する
         LET F(MOD((k-M)/2-1,SZ)+1)=0
      NEXT k
   NEXT x


   FOR k=1 TO SZ !この範囲での素数を表示する
      IF F(k)=1 THEN
         LET c=c+1 !c番目の素数
         !PRINT #1: c; (top-1)+2*k-1
         !!!PRINT c; (top-1)+2*k-1 !debug

         IF c=1000001 THEN !指定の個数なら終了!
         !!IF c=100000100 THEN !指定の個数なら終了!
            PRINT c;"番目"; (top-1)+2*k-1 !!!
            !CLOSE #1

            PRINT "計算時間=";TIME-t0
            STOP
         END IF
      END IF
   NEXT k


   LET top=top+2*SZ !次へ
LOOP

END


!試行割算法

EXTERNAL FUNCTION PrimeQ(n) !素数判定 1:素数、0:素数でない
LET PrimeQ=0
IF n<2 OR n<>INT(n) THEN EXIT FUNCTION !引数を確認する
!2以上の自然数なら
IF MOD(n,2)=0 THEN !2の倍数
   IF n=2 THEN LET PrimeQ=1 !2は素数
ELSEIF MOD(n,3)=0 THEN !3の倍数
   IF n=3 THEN LET PrimeQ=1 !3は素数
ELSE
   LET k=5
   DO WHILE k*k<=n !√nまで検証する
      IF MOD(n,k)=0 THEN !5,11,17,23,29,…
         EXIT FUNCTION
      ELSEIF MOD(n,k+2)=0 THEN !7,13,19,25,31,…
         EXIT FUNCTION
      END IF !+1,+3,+5は2の倍数(偶数)、+1,+4は3の倍数、+5は5の倍数
      LET k=k+6
   LOOP
   LET PrimeQ=1 !最後まで割り切れなければ、素数である
END IF
END FUNCTION


EXTERNAL SUB PrimeList(n,p()) !n個の素数列を返す
IF n<1 THEN EXIT SUB !引数を確認する

LET c=1 !見つけた個数
LET p(c)=2 !2は素数
IF n=1 THEN EXIT SUB

LET c=2
LET p(c)=3
IF n=2 THEN EXIT SUB

LET k=5
DO
   IF PrimeQ(k)<>0 THEN !5,11,17,23,29,… が素数なら
      LET c=c+1
      LET p(c)=k
      IF c=n THEN EXIT DO
   END IF
   IF PrimeQ(k+2)<>0 THEN !7,13,19,25,31,…
      LET c=c+1
      LET p(c)=k+2
      IF c=n THEN EXIT DO
   END IF
   !+1,+3,+5は2の倍数(偶数)、+1,+4は3の倍数、+5は5の倍数

   LET k=k+6 !次へ
LOOP
END SUB
 

複素数モードの制限

 投稿者:寒川光メール  投稿日:2010年 5月27日(木)12時27分15秒
  数学教育で十進BASIC を使用しています.複素数演算を,Fortran のように使えると思っていたのですが,配列は複素数にならないようです.この理解で正しいでしょうか.また,外部関数の引数に複素数を使用したら,うまく渡りませんでした.こちらも制限事項と考えればよろしいでしょうか.  

Re: 複素数モードの制限

 投稿者:白石 和夫  投稿日:2010年 5月27日(木)12時54分37秒
  > No.1239[元記事へ]

OPTION ARITHMETIC COMPLEX を書いたプログラム単位では,添字付き変数(配列要素)を含めてすべての数値変数が複素数の変数になります。
数値の扱いはプログラム単位ごとに独立しています。数値の扱いが十進数である外部関数に複素数を渡すことはできません(翻訳時のエラーになります)。面倒なことを考えたくないときは,ツールバーで数値モードを複素数に設定してください。そうすれば,OPTION ARITHMETIC文を書かないプログラム単位で数値がすべて複素数になります。
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 5月30日(日)08時49分1秒
  > No.1214[元記事へ]

「エラトステネスの篩い」について、メモリ性能、時間性能を検証する。

●元のプログラム
!エラトステネスの篩い法

LET t0=TIME


LET N=10000000 !1からNまでの素数

DIM F(N) !素数候補として、自然数 1,2,3,4,5,6,7,8,9,10,11,12, … を用意する
MAT F=ZER
LET F(1)=1 !1は素数でない

LET c=0
FOR t=2 TO N !2以上
   IF F(t)=0 THEN !c番目の素数
      LET c=c+1
      !!PRINT c; t

      FOR k=t*t TO N STEP t !その2乗以上の倍数を削除する
         LET F(k)=1
      NEXT k
   END IF
NEXT t
PRINT c !個数


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

END

●改修内容
 例1
  「篩い」に使用するメモリを1/2する。2乗以上の奇数倍で「篩い」を行う。
 例2
  「篩い」に使用するメモリを1/3する。2乗以上の奇数倍で「篩い」を行う。

●測定
 WindowsMe、PentiumⅢ700MHz、192MB 2進モードにて計測すると、
 1000万個なら、元は16.8 秒。 例1は7.4 秒。 例2は10.6 秒となる。

●考察
 例1
  期待どおりに倍の値を示す。
 例2
  時間が期待はずれ。「篩い」のとき、判断処理があるのでここでロス。

例1
!エラトステネスの篩い法

!2は素数
!3以上なら、2*k+1(k=1,2,3,…)が素数かどうかを検証する

!WindowsMe、PentiumⅢ700MHz、192MB 2進モードにて計測すると、
!100万個なら 0.8 秒、1000万個なら 7.4 秒となる。

!技術メモ
!i:1,2,3,4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,…
!t:3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,33,35,37,39,41,43,45,47,49,51,53,55,57,59,… 奇数
!  3     *        *        *        *        *        *        *        *        *
!        ↑(t+1)*i から t ずつ
!    5                           *              *              *              *
!      7                                                             *

LET t0=TIME


LET N=10000000 !1からNまでの素数

LET M=INT((N-1)/2)
DIM F(M) !素数候補として、奇数 3,5,7,9,11,13,15,… を用意する
MAT F=ZER

LET c=0
IF N>1 THEN
   LET c=1 !2は素数
   !PRINT 1; 2
END IF

FOR i=1 TO M !3以上
   IF F(i)=0 THEN !c番目の素数
      LET t=2*i+1 !自然数に換算する

      LET c=c+1
      !!PRINT c; t

      FOR k=(t+1)*i TO M STEP t !その2乗以上の奇数倍を削除する ※偶数倍は偶数となる
         LET F(k)=1
      NEXT k
   END IF
NEXT i
PRINT c !個数


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

END

例2
!エラトステネスの篩い法

!2は素数
!3は素数
!4以上なら、6*k±1(k=1,2,3,…)が素数かどうかを検証する

LET t0=TIME


LET N=10000000 !1からNまでの素数

LET M=INT(N/3)
DIM F(M) !素数候補として、奇数 5,7, 11,13, 17,19, 23,25, … を用意する
MAT F=ZER

LET c=0
IF N>1 THEN
   LET c=1 !2は素数
   !PRINT 1; 2
END IF
IF N>2 THEN
   LET c=2 !3は素数
   !PRINT 2; 3
END IF

FOR i=1 TO M !4以上
   IF F(i)=0 THEN !c番目の素数
      LET t=6*INT((i+1)/2)+(-1)^i !自然数に換算する

      LET c=c+1
      !!PRINT c; t

      FOR k=t*t TO N STEP 2*t !その2乗以上の奇数倍を削除する ※偶数倍は偶数となる
         LET tt=MOD(k,6)
         IF tt=1 OR tt=5 THEN LET F(INT(k/3))=1
      NEXT k
   END IF
NEXT i
IF 6*INT((M+1)/2)+(-1)^M > N THEN LET c=c-1 !数え過ぎ
PRINT c !個数


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

END
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 5月31日(月)10時11分31秒
  > No.1241[元記事へ]

つづき

メモリ確保ができれば、1~Nの範囲で効率的に処理できる。
篩いに使っている変数は、FULL BASICの仕様で整数型になっているが、
素数かどうかの2値でいいので、論理型でよい。

逆手にとって、「篩い」で整数範囲の値を扱うことで関連する処理に応用してみた。

●例1
!自然数Nの素因数の個数と和、素因数分解 - 篩いによる
!例 8=2*2*2より個数は3、和は6となる
LET N=1000 !1~N


DIM F(N) !単方向リスト(線形リストなのでポインタは不要)
MAT F=ZER
LET F(1)=1

FOR i=2 TO N !2以上
   IF F(i)=0 THEN !素数なら
      FOR k=i TO N STEP i !倍数に対して
         LET F(k)=i !最大の素因数で上書きされる ※素数の場合は、その数自身となる
      NEXT k
   END IF
NEXT i
!!!MAT PRINT F; !debug


FOR i=1 TO N !結果を表示する
   LET c=0
   LET w=0
   LET p=i !単方向リストを辿る
   DO
      LET T=F(p)
      LET c=c+1 !累計
      LET w=w+T
      LET p=p/T !次へ
   LOOP UNTIL p=1

   PRINT i; c; w !個数、和
NEXT i


FOR i=1 TO N !結果を表示する
   PRINT i;

   LET p=i !単方向リストを辿る
   DO
      LET T=F(p)
      PRINT T; !素因数を列挙する
      IF p>T THEN PRINT "*";
      LET p=p/T !次へ
   LOOP UNTIL p=1
   PRINT
NEXT i

END

●例2
!自然数Nの素因数の個数 - 篩いによる
!例 8=2*2*2 3個、12=2*2*3 3個
LET N=1000 !1~N

DIM F(N) !篩い
MAT F=CON

PRINT 1; F(1) !1

FOR i=2 TO N !2以上
   LET Fi=F(i) !結果を表示する
   PRINT i; Fi

   IF Fi=1 THEN !素因数が1個かなら(素数なら)
      FOR j=2 TO N !その倍数について
         LET t=i*j
         IF t>N THEN EXIT FOR !範囲外

         LET F(t)=Fi+F(j) !(a*bの素因数の個数)=(aの素因数の個数)+(bの素因数の個数)
      NEXT j
   END IF
NEXT i

END

●例3
!ハミング数 2^a*3^b*5^c、a,b,c≧0
!初期値として、f={1}
!i=1のとき、f=f∪{2,3,5} ※i*2,i*3,i*5を追加する
!i=2のとき、f=f∪{4,6,10}
!i=3のとき、f=f∪{6,9,15}
!i=4のとき、f=f∪{8,12,20}
! :

LET N=1000 !1~N ※10^8の場合、1105個

LET m=3 !m番目までの素数
DATA 2,3,5
DIM P(m)
MAT READ P

DIM F(N) !篩い
MAT F=ZER
LET F(1)=1 !f={1}

LET c=0 !個数
FOR i=1 TO N !小さい順に検索する
   IF F(i)=1 THEN
      LET c=c+1 !結果を表示する
      PRINT c; i

      FOR k=1 TO m !i*2,i*3,i*5を追加する
         LET t=i*P(k)
         IF t<=N THEN LET F(t)=1 !f=f∪{i*2,i*3,i*5}
      NEXT k
   END IF
NEXT i

END
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 6月 1日(火)19時27分59秒
  > No.1242[元記事へ]

続き

「篩い」によって、まとめて処理できるだけではなく、
約数や素因数などを除算で求めるのでなく、倍数(乗算)に置き換えることができる。
これによって、計算時間の短縮が期待できる。

「篩い」表に約数の和を設定すると、、、

●例1
!完全数(自分自身を除く約数の和が、自分自身になる自然数) 6,28,496,8128,33550336,…
LET N=100000 !1~N


DIM F(N) !篩い
MAT F=ZER

FOR i=1 TO N/2 !自分自身を除く約数の候補
   FOR k=2*i TO N STEP i !倍数に対して
      LET F(k)=F(k)+i !自分自身を除く約数の和
   NEXT k
NEXT i
!!!MAT PRINT F; !debug


FOR i=1 TO N !1~N
   IF F(i)=i THEN PRINT i !自分自身を除く約数の和がその数なら
NEXT i


END

●例2
!友愛数(Amicable Number )
!異なる2つの自然数の組で、自分自身を除いた約数の和が、互いに他方と等しくなるような数
!(220,284)、(1184,1210)、(2620,2924)、(5020,5564)、(6232,6368)、…

!参照 SAMPLE\AMICABLE.BAS
LET N=100000 !1~N


DIM F(N) !篩い
MAT F=ZER

FOR i=1 TO N/2 !自分自身を除く約数の候補
   FOR k=2*i TO N STEP i !倍数に対して
      LET F(k)=F(k)+i !自分自身を除く約数の和
   NEXT k
NEXT i
!!!MAT PRINT F; !debug


LET c=0
FOR i=1 TO N !1~N
   LET t=F(i)
   IF (i<t AND t<=N) AND F(t)=i THEN !互いに他方と等しいなら
      LET c=c+1
      PRINT c; i;t !組
   END IF
NEXT i


END
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 6月 5日(土)09時07分4秒
  > No.1243[元記事へ]

a*x+b*yで表現される整数

!●その1

!a,bは自然数とする。ただし、gcd(a,b)=1
!非負整数 x,y で表現される整数 c=a*x+b*y は?

!初期値として、f={3,5}
!i=3のとき、f=f∪{6,8} ※i+3,i+5を追加する
!i=5のとき、f=f∪{8,10}
!i=6のとき、f=f∪{9,11}
!i=8のとき、f=f∪{11,13}
! :
LET a=3 !5
LET b=5 !8

LET M=a*b
DIM F(M) !篩い
MAT F=ZER
LET F(a)=1 !f={3,5}
LET F(b)=1

LET c=0 !個数
FOR i=1 TO M !小さい順に検索する a<bとすると、{a,…,b,…,(a-1)*(b-1),…,(a-1)*b,…,a*(b-1),…,a*b,…}
   IF F(i)=1 THEN
      LET c=c+1 !結果を表示する
      PRINT c; i !(a-1)*(b-1)/2番目の数(a-1)*(b-1)

      IF i=(a-1)*(b-1) THEN PRINT "以降はすべて表現可能"

      LET t=i+a
      IF t<=M THEN LET F(t)=1 !f=f∪{i+3}
      LET t=i+b
      IF t<=M THEN LET F(t)=1 !f=f∪{i+5}
   END IF
NEXT i

END

!●その2

!a,bは自然数、cは正の整数とする。
!方程式 a*x+b*y=c が非負整数解 x,y をもたないような c の全体、最大の c は?
!ただし、gcd(a,b)=1、cはaの倍数でもbの倍数でもない

!     ai
!     ↓         ↓
!     +1         +2         +0 (mod 3)
!                            0=3*0+5*0
!     *1         *2          3=3*1+5*0
!     *4       → 5=3*0+5*1  6=3*2+5*0
!     *7          8=3*1+5*1  9=3*3+5*0
!bj→ 10=3*0+5*2 11=3*2+5*1 12=3*4+5*0
!     13=3*1+5*2 14=3*3+5*1 15=3*5+5*0=3*0+5*3
!   :
LET a=3 !5
LET b=5 !8

FOR j=1 TO a-1 !aを法とする完全剰余
   LET bj=b*j !gcd(a,b)=1より、aを法とする完全剰余 ※各列にbの倍数は重複なく現れる
   !c≡b*j mod a、0<j<a-1が成立して、cはbの倍数でないのでc<b*jまたはb*j<c
   FOR ai=MOD(bj,a) TO bj-1 STEP a !c<b*j
      PRINT ai; !cの全体
   NEXT ai
   PRINT
   !またb*j<cでは、あるx,y>0でa*x+b*y=cとなる
NEXT j


PRINT a*b-(a+b) !最大のc


END
 

BASファイル化

 投稿者:しばっち  投稿日:2010年 6月 5日(土)22時00分49秒
  どんなファイルもbasファイルに変換します。(※十進BASIC読み込み可能サイズまで)

!'binary TO bas
OPTION CHARACTER BYTE
FILE GETNAME F$, "ファイル|*.*"
IF F$="" THEN STOP
OPEN #1:NAME F$
OPEN #2:NAME F$ & ".bas"
PRINT #2:"OPTION CHARACTER BYTE"
PRINT #2:"OPEN #1:NAME ";CHR$(34);F$;CHR$(34)
PRINT #2:"DO"
PRINT #2:"READ IF MISSING THEN EXIT DO: X$"
PRINT #2:"FOR I=1 TO LEN(X$) STEP 2"
PRINT #2:"PRINT #1:CHR$(BVAL(MID$(X$,I,2),16));"
PRINT #2:"NEXT I"
PRINT #2:"LOOP"
PRINT #2:"DATA ";CHR$(34);
DO
   SET #1 : IF MISSING THEN EXIT DO
   CHARACTER INPUT #1:A$
   LET K=ORD(A$)
   LET L=L+1
   PRINT #2:RIGHT$("0" & BSTR$(K,16),2);
   IF MOD(L,25)=0 THEN
      PRINT #2:CHR$(34)
      PRINT #2:"DATA ";CHR$(34);
   END IF
LOOP
CLOSE #1
IF MOD(L,25)<>0 THEN PRINT #2:CHR$(34);
PRINT #2
PRINT #2:"CLOSE #1"
PRINT #2:"END"
CLOSE #2
END

上記プログラムでバイナリー形式であるzipファイルを変換すると
下記のように出力され、また実行することで変換元となったファイルを復元できる。
(※生成されたファイルのウィルスチェックは不要)

OPTION CHARACTER BYTE
OPEN #1:NAME "sample.zip"
DO
READ IF MISSING THEN EXIT DO: X$
FOR I=1 TO LEN(X$) STEP 2
PRINT #1:CHR$(BVAL(MID$(X$,I,2),16));
NEXT I
LOOP
DATA "504B03041400000008008596C53CE791CD643D030000240700"
DATA "000D00000083CE8C768E5A8EAE322E4241537595DD6EF23810"
DATA "86CF91B8871C12A288F9F1CCD807AC4429D55275531658A947"
DATA "DFFD5FC6BE0E490BADDA54F1C4F6D8F3F3CCF07CD8BFEDCE87"
DATA "E6F0713D9C87DD5BF3F2DFB0BF1EDF8766FFFECFD372F1FCEB"
DATA "FAE9B45CBC1DAE4D73D9D272F1F27E6E862D37D7F78609DF4D"
DATA "D34C8B974ED7A7D36A6837F5C43ACA9FD5D073BB5C0C38B519"
DATA "9AE5E2743E0ED76675E985348A646A379188C4968BE992DDD6"
DATA "55DD48B2B294E0528A654BE222D461522348385126CA492879"
DATA "1673A2F5E5DFF3CADA4E739AC47160CA8543B21973E03F0B41"
DATA "2592BAB06831A1C24E9ACD7108479772509142D92D72661231"
DATA "8A506CD064893DE710566331A3345FDA4EA63F6D23A7529812"
DATA "761777C15EF851221522EAA04696DD61845351A94BF55A4F5F"
DATA "E68BB115CFE3A732D3CD0B87825056D1C8388A5DBD145511B7"
DATA "84BFBA96859D3B89526AEC42C9092B82AF0821875A30361917"
DATA "12B56F86EFB73D428A8D883579754F12F5054794440AEF3D65"
DATA "5299B47AE4C51F835CB20902142541DBA81ACAAA9C5368970A"
DATA "4B241783D182B88725A740EC31FFDD8EFDB64EF4FB359E79F2"
DATA "63CB9FFCED7EE7EF63FBB15EF97A68C737A8BB8D328D3A8D69"
DATA "1AAD7D50DDAC14AAE31BAAB751DACD303EFBFA3C928EBB76DD"
DATA "13547EB0BDDF6F2E77300333B0EBD918790114D6B18DB94C15"
DATA "6BCE36E55E90FBFB98A6CA18154F881760AC94B32773260686"
DATA "563A4526011290344F5A6B0565115A6B451354A753BFD8E4AC"
DATA "25A2A8691076409D3A5602EEE0B502E220F7CE1A1C8AD24C53"
DATA "86A74C33908247E1C82F49AA947B749932E863E418A4A0DEC8"
DATA "E28701AFDB1508F4C4815AB34E501CA86A1593F9065437E5FB"
DATA "18C0BB8A397B44F6CC5D169417422081EAF559AD6DFF68D3CC"
DATA "01DFDDD1F2D9ADE89E96E34B33FC8599BF0FC3F83DA715AABB"
DATA "DD233CFA09CB6644EBFEFD5377A2E5755C390CCFB8E9119A7A"
DATA "FC2FD48CF5BE7E6D2B3B50AD007D36E2C74EBD1AE6885E2ED5"
DATA "D7EAE1F1782B88E1EE3E5C7859AF627D3CF6DE4E82CD429A05"
DATA "9D0599059E04B8695FC3581476DB38093A0B0982DCB6CA6DEB"
DATA "E4DEF138A7A51A0E7B46DF3EDDF9C5C9F12764D23B9DB67D06"
DATA "E0815EC2EB617E003FDA490AB49979AA9752BB5D41C39EF630"
DATA "A144D06ECA38D14346FF43271A97D026D1D3BEDBF33F504B03"
DATA "04140000000800B9B6C33C03DB26BC04090000312600000C00"
DATA "000083CE8C768E5A8EAE2E424153DD59DB729C3813BE7795DF"
DATA "814B492C069D18E682BF4A4C9C0AB183BDC6DE727231EFFF18"
DATA "7FAB254002CD29D9ABCD38C341A0EEAFF5F549F3FCF89E6563"
DATA "5BDDDF3DDB33D3F2FBBBAF2F6FD9D056D9FB4BA6EFEFB22CEB"
DATA "BF66C3FFE0FADBE380D7F0CF3F5D18466A3650FC2EB83F0A7F"
DATA "94FEA8FC51D3D5EBA62412DEC66F78DB1D052D07FCD4AA92A2"
DATA "8A0F38C1E3F0C5EA84E7CF0EC09883265CEA3D57D53ED74AC3"
DATA "914B0593DFDF0D8F9FEFD9008FBFBEF5C37BA644DD34151BFF"
DATA "7E23BCAA2A4DCBF1FEEEFEEE4BFF23FB200DF596F8209CB66A"
DATA "BE1074B6D10791E185A26D21E62B0D577CBEAAA3AB5DF85AB3"
DATA "5CA0F99DD1391ABD5A9075ED8F972F64F82B6BE8B4145DEB96"
DATA "627AA0090CF14FFB413A1A1BE61F3025AF8F009D0C65B3B507"
DATA "A25F302FFA02E64286A0039C2A1AD3E16B358DE994C408965F"
DATA "B4B4441009CCF549CC35DC3E8FDA308B7BD8A2856537DD4864"
DATA "CD464A67E85D2B22FD44A45E172A27983A024B99380E48227B"
DATA "65B66615386872554A463A78621196F43767161DA18009443E"
DATA "D2C8524C6C44657013A589620CA5B89B92CEC2E48C969F615C"
DATA "D1C5A6EC9828110B38A86043CE570AEDCF506A0C2455185278"
DATA "36BE3FBE66D62F162144E61A66267672E6856034C8953F829B"
DATA "4A366ECD2CF3B1ACAB585ED2B47AC538366CD12071B668ACC9"
DATA "DDACF3CA99852F55C8E7205466EE3910041F51CEA80406252F"
DATA "32929832DF29A608C0B3024478CE4BA2AC3C08A62B58C1C806"
DATA "A029AF91688365B5B215E30E4F842E1711418AAD45151B7319"
DATA "88D48C5882695A8885AC0F3A918A70ECB3D5E51812E8674B3E"
DATA "31FBD8EF7CB70CFC6AC983669F8CFCCCAD809FEC67A1E0123E"
DATA "94D223E1A58E541DD9C84CA1C1B1ED6B042E2167E19BA3BB02"
DATA "8F0226529A45F1073C4D9784FCCA3FCB5F48E0F92C41585E9A"
DATA "193998B86C1A119AFE02A7F046685BFB3EFE97623566D091D0"
DATA "2C2A384A9F5EF1699749E345259C0B990BAEEACA66F6C4EA05"
DATA "74E95A609D5B3B5A8A0056B738A43D3F195AD13DCA0E3E1191"
DATA "2EFA642998C6F0D621DD52EC85ACE72F0EABB286072A1CDAC3"
DATA "CB8F4E9081C64B0A865002030F3BE0C7446A975067D489C50D"
DATA "3D493E7055FA38D14F4E14CB38BC8C6426499F0A397E9EB3B3"
DATA "8CFD909CE586398A7773718E446488881AA0721665260E0C71"
DATA "E600F2F2AD095D5DC6C6D4A23E05D15D70C1777AC7AB3D7779"
DATA "AE06D7E735DC515AEC76B2D64BB29370BD6FAA662FEA5DF070"
DATA "05EF3742C088D8E949C6A1255A407D4884ACEB9DCA65059FE9"
DATA "1D081A530EFD86E9F940234BC8B5C3463EF9D4164F7F502F3F"
DATA "B54F67EBE543E0D22B2A835803791C5EFD96E02CB1163C599E"
DATA "78ABA005B0063FCA18F47FA049B0B6BBDE2C5DEBEAAA026BAE"
DATA "256375AC3BEF176F95750A221AF0855DE19948C14DC2D08306"
DATA "EBE2CFB6BA2C211FC90B25E50925242AC1A52DAB1ABA8A6B4C"
DATA "D94FD968F7B711DCB8A8DB403D467803F9D299E28F34E1181A"
DATA "368A945C6CE53BF11A03CA2DC245281C6A5C29B02002B9852B"
DATA "8D724973A1EBD2061FBC5D2B7F0E0B3D9DEAE574476D4D85A7"
DATA "FB55BAEA622836CE5542257258AD82526061D7A582C0BD607C"
DATA "7F6002E99DA3A628CC4625C2410F703A685B223B9BD02CDD96"
DATA "69D724809571C14435DAD05AA876A6F567FAA2A99A849D263F"
DATA "BB5591798D737F26683EAFF62545120B76BB06608AC6D149B8"
DATA "33857C6B1C97FC597D5E97749A8C8AC8A5B18BDBD888311DAA"
DATA "E3CA35A28ACE46A2BCA361A7606C1033B938120CB5D2B226EC"
DATA "AC1D4362F69CA96FCF3613B1B70FBE1F2B362D920BDC89565E"
DATA "7AF767AB75B9DC6E0E6C16255D7922DD994D4A443BC6A69BCD"
DATA "D861675127859976983BCD3CB14D002B62B02E4A20D8B4ADBE"
DATA "91F36DF2F42D966F26F11C4362A2AE52D0C5E452EB922B7529"
DATA "6AFAFD8878997CD21DD62A2D055F522EAE935050D5957C7749"
DATA "F0F992722A24AF7011B926C6754C94D9BA113033BE243A6BF3"
DATA "D1F655EAE42A6EE02C26BB96D8FC5AFDE7AE6FA23816383EFC"
DATA "AD805DB0D9D532178E27B6004E747000711FD657C69CDD830B"
DATA "13957DF4E8E515365861AFFDF7757B71C6449B714B8D0BBDAC"
DATA "AFEBF8D2CB8E1B62466AC0A48275B494519825906E0DC451A8"
DATA "E32098DB61DC6C58E71C229DEA853C5AD78137CC29C4C9D42C"
DATA "99B11D162F2CFD8E83BD3A01CCE27AD074C6F420F405541D8D"
DATA "B664DD1480278650D84D50020635D41F6E028072989306040D"
DATA "C99088AE552ABA4EE16061DF3551D6AC2CD2B5E64CA5E51FCE"
DATA "1F348B8AADB64BC43B61B73B6631AB2DD8CE6EC19E7624014B"
DATA "D895688F50CC62FA95AC20D3F2768A1AA5CA838D986D40BA14"
DATA "5F1727D6D744D991170F3BCDC2C4F8A02F485DEF928671CBEF"
DATA "03A975089E371056F2EB4B51FE44EFA15C2BE60AFC2B8ABFE6"
DATA "D226E9093935CA916E2FFBBA1E87703D7536D8E6FC56C29C00"
DATA "D6728F0D0DAFD6304DB9DFCF7F1B25F64D859BBBAEF6FE3325"
DATA "9A64CADECA9CBCE5F74C3DEFD719868D762CADDE2E29AF9382"
DATA "C097AAD35EBAEC1706D2793BE2E6FBB0295CE1E6610A4E6045"
DATA "BE5DEC86CFE97ECE125BFFB952919544E693B13BC665E164D4"
DATA "92377374723FF4CCE1EAD0426A81AEB8B41D8A57B7E8B08180"
DATA "B45628B0F4C171D484B135D1BF8A64D920B2B0D43A05C82476"
DATA "672C55FED44C89592191DA0560FB898822809588A5E96AE86A"
DATA "58C95F28B1326AE264E899FFDA4ADF13D89488D93048D25F9F"
DATA "5BA7887DF4BB7B1426C4A2E695D2F0791783EDCFACAF7F7DA7"
DATA "D38FABD3503021CFC2BB8F9FFDBB9D7DBA15FC7C8020BE4FD1"
DATA "DDAAB20EEFD6415E1981108FBF4593572CB3664ABE2E09D46C"
DATA "57B6C732E06443D75B0EF64878BE346EFD4CDAD10E899BA7C5"
DATA "00D8D37C997E5C4F6D8DCBEB4D78BC62723B25740D47E1841C"
DATA "455A77D7B2DF3E7DEF27F6D9BCC7289012E00A7134D12C25A8"
DATA "7AF54921F0503EBAB43DC118E038117A9A69B4C9D4075C1B6F"
DATA "8134560C3CF3F8369867A0D9C77078EF5F866CF1138701B5B0"
DATA "B5424450E754F6D1D6E9E258E927C1F991946823FF6347D8B0"
DATA "8246A875DFFB2EA9EF69D9F7F03759A69FA2A393323AA50311"
DATA "49ED31D34F1E1B14DFDD7C7A987F874AE8656CBD3CEB553ABD"
DATA "96E1CE16D05047D86181FB16D1304C7D38F861BE0C4F782640"
DATA "6FB51502131D0ED76152FF062665B59258E2A7309D82EC31A9"
DATA "6958C5982648EA4648F2DF80545BA5EC2E74FD3B90EA69B84E"
DATA "43923742AAD6906EE3D85A7CD5622F8AEDE85AFCFF01504B03"
DATA "0414000000080096A0C43CC1FF4C4BAB000000E00000000800"
DATA "000043414C432E424153F30F70F5535036B4F273F47555504A"
DATA "29CDCDADD44B4A2C56E2E572F1E7E5525050F0F40B080D5150"
DATA "0808F2F70D085150EA5BD7F461F29FE9679BB6361D695ADBB4"
DATA "AF6973D322052B252B856015887237204BC15641494921C403"
DATA "68B46B84678802D4A880204FBF1090650A4A10A692B582B347"
DATA "908A86B189A635509BB582922D8A9092B59235D8601F7FFF00"
DATA "5E2EB87E25573F17A00B9D7DFC835D817C20CBC3D1D30FD5F9"
DATA "40250A405B01504B0304140000000800B096C53C638F5E8837"
DATA "040000DE1900000A00000083708359838B2E424153E558BB8E"
DATA "E33614ED0DF81FB86E76BC5116A444595482296C8F7622406B"
DATA "1B96362327DD7629022C90FC40E02A4815044891CF4B95329F"
DATA "10D124255EEA92968DEDD28C499E73C9FB382435DCAEAB8A3C"
DATA "97BBB27958253412195DCE6775D190EDBEDA1F49369F1DD6E5"
DATA "AE2134A2F359D58D93CD63AA5B6DFD98BED9E8CEA97E6454F6"
DATA "B672C6AADC150F6DFDC5E60D8D4EF227CDA256FF9ED4B05CC8"
DATA "E10EE0A5CB18EF8D11B60DC301D9400CE880DEC5A7216F5CB2"
DATA "58A98158606CCE149A69762EFA3EC2367375BF931CF7F2B5EB"
DATA "AF5E3FD7EB6F0BB2387F3A9FCEBF9D7FFAE5FB73FBF6E38F9F"
DATA "161159B08F3FFCBCE834D0EC0FF3999EFA2681AC77F54B717C"
DATA "1CF4C2DE268362626A4B26FE5F49A67C6792C348F34DB19BCF"
DATA "0821B7E9686C70454A6383AB6ABAC1440756EC9E48F94ECAC5"
DATA "57E6409D75E978DFC5F60BCE6568952D54791F640B1F3BC983"
DATA "F40E86ABE17CEEE5C77190DFC14010381DE6C5E1DEA237B39C"
DATA "89AF9395476F6E40C622CFAF58088656EF9A789234201E16C3"
DATA "9D26D06DC90714F475901E36D7FE8A38C4B650D047753C80AD"
DATA "C9BA9F6CA1B02F830EF1DDA478F89EA4E8144E118F9B57139E"
DATA "F01D246E6A472121678F6698987A93553A493EE984B387C549"
DATA "B00E09CEE6613AD77CC142740B057DB64237BC0DC3DD84F36D"
DATA "18962078D07278A2E0649C4B27CB0716C144267C274F2A6019"
DATA "28746E2C0496012584BE4F6108310D6D1889826479E8DCC79F"
DATA "5A2A11E60B2F7FE2D53291EF5EBA93D8F78AC15C126EECFE9B"
DATA "6B74B166F9343DC4A1AF4F236A233A7C0758A8D6A4B0E3764F"
DATA "06EA28B8733D30B9D40D9CFD467E3F20C27C016B86B329CAE5"
DATA "D30B9C3B075D7F90EBF5C61676BC6A20CBAF98780BC2BD8BD0"
DATA "700DAFCA289922A36177A03706BCE86F22CB0D1210850D4F11"
DATA "510F8B7BF9594845160AFA9EC933E87BF036C20FA01B04EAFA"
DATA "96031D205A73BC733385AC10BBC5801F8057B5C69380D68CDF"
DATA "22241F01B3248229B5D0FBB4B68A03AE58E8A51FF3F071C583"
DATA "C7D5940A73271E277AAC60A3438B815511139E3A26FD7FCF13"
DATA "8B9C86FEE1B9A7C8310D7DDE5A281AA22F259FAF0C76963F5B"
DATA "1DC242C7EE01F7B63585F4952DA193DFB2CC946C15DA0F03AA"
DATA "5CD6E74B8C3F440C28B44ED117471B06F6027F151950682E1B"
DATA "A1E965C38EDCC3A70E3BCE43DE58A86D8D473A80C016CFA285"
DATA "C27A4DD5B23B819356FF2D93A5CA204BFBBEE79A811F8D8E2A"
DATA "8C2C5FBD76BD25FA91F7D77FFFF80B3CEE92A2AA0B83FEF9F7"
DATA "EFFF384FBFDD9452E645DB14C7DDBA22A4FEB0D14FC06D5D7E"
DATA "5774EB777F97EA19785336EFD707224788852AF0A5DC3DED5F"
DATA "08A12452E097AC6B9D542B2254B10E7BF9805C37A7AA2084D9"
DATA "AFCBEFF74F9D8BC7E2F943B53E2E0052B60F74295F9D23EA8E"
DATA "3335CEDCF1784918C64FD4F888CFE53C6CCC4FD5F888BF92F3"
DATA "20FC4C8D77FC6D55AC8FAA665D4EC749D645EF5218B55D228B"
DATA "68BBB427DBCE67876ADF5C68B5DDFE8A5C8CBEBE1859F3FF07"
DATA "504B0304140000000800C69EC53C9365EE4CB6000000380100"
DATA "0016000000838C8380836A83588350815B83678EFC97A62E42"
DATA "4153758DB10AC2301445F740FEE13999A684F4451DBB192150"
DATA "D2D20452105C05BF42C92AAEFE815FE960935A2882CBBB0FEE"
DATA "E59C467B70355272687B3035826F615755152500D0E4D271B6"
DATA "E5A6C857602173AA294B2C28B17AF06028E97A633D28EE28A1"
DATA "A4F9012768822338AF3B10B83030553295152A23A55B50D324"
DATA "D48A332C31179326C06A1DEFF11A2F7188DDED18CF8FF7F335"
DATA "9BC36CB6F57FF138122139ADD8142725D337E6576D6752906A"
DATA "96A20C9468BBA7E403504B0304140000000800F299C53C5B74"
DATA "8C5EC8010000330400000D000000974C979D909489BB322E42"
DATA "41538D53DB6E9C30107D47E21F26B455EC04428854A9EAAE2B"
DATA "8D17EF6204B60B4EC253FAFF7F515FB86DA22AF503F29C99F1"
DATA "CC99C36863A556C07114F098263A9A3848DBF4C2CA13D4E224"
DATA "7BECFE34F2D2A449272CF43875E24574EC874BA8650F862C10"
DATA "8D111333324D6E6EE37DFC3D1023E935F0B4B38907BED3FB8A"
DATA "964FF1016453BC7056A5893C031E39D84628481300185FD100"
 

Re: BASファイル化

 投稿者:しばっち  投稿日:2010年 6月 5日(土)22時01分49秒
  > No.1245[元記事へ]

続き


DATA "E63C183EACF361EE7E73EB3E6690CA42564109243BA4895035"
DATA "C8739A9CF500927560F54A617DC01049994B235872BAA29C33"
DATA "2CBCEB6E2B85C8760643DCA219E76B17B1099F7B5831C7431E"
DATA "97D291CEDCEB3DACDD2A315908D39B9D833002ED5792D12C5F"
DATA "920B3F691FE339B5ACBAE614A6E03B1A99212D9D8148BF2D42"
DATA "F0238C561828AAD9B94B904E88729CF15D370BA7E751AA0B64"
DATA "C5B7872FFF7DFCFBBB84B770B29F633E15A15228D346893ED0"
DATA "59C71BC9ACA38F92FF8BD6466A556C5395DF059E7815B668F9"
DATA "5ECE6506335EB3CBA926EEEF8BBDC4A1F0B23E646576C0B2CE"
DATA "77F0C7592DD4A7829738ABDD867FD40BEA2C3128EC1CAD6775"
DATA "0AABE88BF5B9A29FEF66ADE1B5919D0005C75F7E99E786C102"
DATA "835EBB672007456173F4CEA1365339D3BABDD3DAC4EDF3C559"
DATA "1F376869284DFE02504B0304140000000800E99AC53CAC02E4"
DATA "4CE80100001A0400000C000000976A93FA8C9F8DF52E424153"
DATA "9D91BD6ED44014857B4B7E879B51246CEC6CFC936511CE2045"
DATA "CCAC58E119AF3C8E9CA1A7E10520ED4A29C2AEAC0847E14128"
DATA "78024A5251A44C857886ADB8335EAFD6A0A4C0C5FC7C73CE9D"
DATA "33D77B4FDE7D8C47A0344DA22802C5718E23108AC620380EC0"
DATA "941DEDBAA613D7D9434BF28825B196D45A52B48C5D6726E7A7"
DATA "15C0BC2CC4BC02B2FCF5E927C0B5F4547552562197CCA7E485"
DATA "D2A1E20F6857CD502B54281ED2B6EBA196A990A1765ECE246A"
DATA "A2D168D4AEBFBC6FD764CB6264AB66C8126497B7439622BBBA"
DATA "18B223643777433646B6BC1FB267E6DEF3219B18EFD7E6C3E7"
DATA "DFE49FB718A539C107D4783885FAF8E504AAD75C42CE2BA839"
DATA "7FB34FC58CED7BA45DAF9ACBDBAB8B9BBBE57D7B4EC23A88C3"
DATA "D8779D695182A64A435580E92C001824A85006890E6D28A3CC"
DATA "52B6A5F8999BA0AEE95B9EE7BCF4742842E6EF9C9B5874936A"
DATA "076F9C8F66EC43EE9ABAB6E88C5C4B92898CAC1A92B10CBD8B"
DATA "1F24B3D532DB97C5F7C537B263E5B9E2C34A26584DEB2ED97F"
DATA "97950C0BF540F2B30A98DDD9A5701D3B6BD741A1EBE07456F1"
DATA "529EE4303D95AFAA5921E1AFBE612A719CDA50B68E6992D654"
DATA "1FC4DBADC0BF13C40916EBDFD48B06127BA70D6748770D1505"
DATA "F3B40EF0B1381D1EF9079B551C45FE96F66B2F4E9F0A113CF7"
DATA "0FC77EC0C289DF95ECA3BBCE1F504B0102140B140000000800"
DATA "8596C53CE791CD643D030000240700000D0000000000000001"
DATA "00200000000000000083CE8C768E5A8EAE322E424153504B01"
DATA "02140B140000000800B9B6C33C03DB26BC0409000031260000"
DATA "0C000000000000000100200000006803000083CE8C768E5A8E"
DATA "AE2E424153504B0102140B14000000080096A0C43CC1FF4C4B"
DATA "AB000000E00000000800000000000000010020000000960C00"
DATA "0043414C432E424153504B0102140B140000000800B096C53C"
DATA "638F5E8837040000DE1900000A000000000000000100200000"
DATA "00670D000083708359838B2E424153504B0102140B14000000"
DATA "0800C69EC53C9365EE4CB60000003801000016000000000000"
DATA "00010020000000C6110000838C8380836A83588350815B8367"
DATA "8EFC97A62E424153504B0102140B140000000800F299C53C5B"
DATA "748C5EC8010000330400000D00000000000000010020000000"
DATA "B0120000974C979D909489BB322E424153504B0102140B1400"
DATA "00000800E99AC53CAC02E44CE80100001A0400000C00000000"
DATA "000000010020000000A3140000976A93FA8C9F8DF52E424153"
DATA "504B050600000000070007009C010000B51600000000"
CLOSE #1
END
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 6月 7日(月)11時12分45秒
  > No.1244[元記事へ]

問題
 最小公倍数L=p^a*q^b* … *r^cになるN個の正の整数x,y,…,zの組は、並びは?

答え
 個数 {(a+1)^N-a^N}*{(b+1)^N-b^N}* … *{(c+1)^N-c^N}

2つの正の整数 (x,y)、x<y の場合
 最後の(L,L)を除いて、x>yとx<yが同数ずつあるので、その個数はN=2より
 ( {(a+1)^2-a^2}*{(b+1)^2-b^2}* … *{(c+1)^2-c^2} - 1 )/2
=( (2*a+1)*(2*b+1)* … *(2*c+1) - 1 )/2
となる。
LET L=30
LET N=3

DIM D(500) !約数列 ※昇順
CALL Divisors(L, C,D) !最小公倍数の約数が候補となる
!!!PRINT C !debug


LET s=0 !解の個数
DIM F(N)
FOR i=0 TO C^N-1 !C進法N桁で、すべての組合せを検証する
   LET t=i
   LET k=0 !進数変換
   DO WHILE t>0
      LET k=k+1
      LET F(k)=MOD(t,C)
      LET t=INT(t/C)
   LOOP

   LET w=D(F(1)+1) !LCM(x,y,…,z)
   FOR k=2 TO N
      LET t=F(k)
      IF k>1 AND t<=F(k-1) THEN EXIT FOR !条件x<y<…<z
      LET w=LCM(w,D(t+1))
   NEXT k
   IF k>N AND w=L THEN
      LET s=s+1 !結果を表示する
      PRINT "No.";s; " (";
      FOR k=1 TO N
         PRINT D(F(k)+1);
      NEXT k
      PRINT ")"
   END IF

NEXT i



!個数 {(a+1)^N-a^N}*{(b+1)^N-b^N}* … *{(c+1)^N-c^N}

DIM P(20),E(20)
CALL FactorInteger(L, P,E,C) !素因数分解する
!!!MAT PRINT P; !debug
!!!MAT PRINT E; !debug
!!!PRINT C !debug

LET t=1 !総数
FOR i=1 TO C
!pの累乗eの因数の選び方
! 指数を0~eから重複してN個選び、このうちp^eを少なくとも1つ含む場合になる
   LET x=E(i) !累乗
   LET t=t * ((x+1)^N-x^N) !その積
NEXT i
PRINT "個数=";t


END


EXTERNAL SUB Divisors(N, C,D()) !正の約数を列挙する ※N≧1
LET C=0 !個数
IF N<1 OR N<>INT(N) THEN EXIT SUB !引数を確認する
!1以上の整数なら
LET C=1
LET D(1)=1 !1

LET i=2
DO WHILE i*i<=N !2~√N
   IF MOD(N,i)=0 THEN !割り切れるなら
      LET C=C+1
      LET D(C)=i !除数
   END IF
   LET i=i+1
LOOP

LET M=C !残りの片方を求める
IF D(C)*D(C)=N THEN LET M=M-1 !D=SQR(N)の場合

FOR i=1 TO M
   LET D(C+i)=N/D(M-i+1) !商
NEXT i

LET C=C+M !個数
END SUB


EXTERNAL SUB FactorInteger(N, P(),E(),C) !素因数分解して、素因数とその個数を返す ※N≧2
LET C=0 !個数
IF N<2 OR N<>INT(N) THEN EXIT SUB !引数を確認する
!2以上の整数なら
MAT P=ZER
MAT E=ZER
LET x=N

IF MOD(x,2)=0 THEN !2の倍数
   CALL div(x,2)
   IF x=1 THEN EXIT SUB
END IF

IF MOD(x,3)=0 THEN !3の倍数
   CALL div(x,3)
   IF x=1 THEN EXIT SUB
END IF

LET k=5
DO WHILE k*k<=N !√nまで検証する
   IF MOD(x,k)=0 THEN !5,11,17,23,29,…
      CALL div(x,k)
      IF x=1 THEN EXIT DO
   END IF
   IF MOD(x,k+2)=0 THEN !7,13,19,25,31,…
      CALL div(x,k+2)
      IF x=1 THEN EXIT DO
   END IF
   !+1,+3,+5は2の倍数(偶数)、+1,+4は3の倍数、+5は5の倍数
   LET k=k+6
LOOP
IF x>1 THEN !1以外なら、因数
   LET C=C+1
   LET P(C)=x
   LET E(C)=1
END IF

SUB div(x,k) !マクロ
   LET C=C+1
   LET P(C)=k !因数
   DO WHILE MOD(x,k)=0 !この因数で割り切る ※べき乗部分を取り除く
      LET E(C)=E(C)+1 !べき乗
      LET x=x/k
   LOOP
END SUB
END SUB



!※「UBASICの整数論関連の組込み関数の実装」より 抜粋

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
 

Win.版 サンプル閲覧実行ツール746

 投稿者:SECOND  投稿日:2010年 6月 9日(水)08時51分25秒
  !Win.版 サンプル閲覧実行ツール746
!----------------------------------------------------------
!各 ウィンドウの、左上位置(x0,y0)と、幅(xw,yw)。
CALL SetWindowPos( WinHandle("MAIN"       ),0,   0,  0, 720,600, 0)
CALL SetWindowPos( WinHandle("TEXT"       ),0,   0, 70, 514,670, 0)
CALL SetWindowPos( WinHandle("GRAPHICS"   ),0, 515,172,   0,  0, 1)

SUB SetWindowPos( handle, C2, x0,y0,xw,yw, nFLG ) !nFLG: 0=x0y0xwyw 1=x0y0 2=xwyw
   ASSIGN "user32.dll","SetWindowPos"
END SUB

!----------------------------------------------------------
!SET directory "C:\BASICw32"                      !アーカイブ版の多く。
!SET directory "C:\WINDOWS\デスクトップ\BASIC746"     !私の場合。
SET directory "C:\Program Files\Decimal BASIC\BASICw32"   !インストール版の、デフォルト。

!ここで、エラー停止した方、または、表示が出ない方 は、
!上のパス名を、ご自身の 十進BASICフォルダー に直して下さい。
!このプログラム自体が、そこから起動される場合は、削除しても可。
!
!----------------------------------------------------------
SET BITMAP SIZE 501,501
LET V=5                    !表示列数
SET WINDOW 0, V, 27,-6
SET AREA COLOR 5
DIM p$(5*V),wild$(5*V),names$(200)

DATA TEXTFILE\, Tutorial\, UserLib\,  COMM\, Complex\
DATA FRACTAL\ , FUNCTION\, Library\,  Math\, MICROSFT\
DATA "Q&A\",    SAMPLE\,   STATEMEN\, ".\"
!                                      ↑ BASIC フォルダー自体
FOR f=1 TO 25
   READ IF MISSING THEN EXIT FOR: w$
   FILE splitname(w$) p$(f), name$, ext$    !ext$は語頭に"."含む。
   IF ext$="" THEN LET wild$(f)="*.*" ELSE LET wild$(f)=name$& ext$
NEXT f
!
LET w=12                   !最初に開くフォルダー、1~?番目(上のDATA 文)
CALL basfiles
!----------------------------------------------------------
OPEN #9 :TextWindow2
ERASE #9
CALL SetWindowPos( WinHandle("TEXTWINDOW2"),0, 515,  0, 509,180, 0)
PRINT #9 :"フォルダーを、選んで"
PRINT #9 :"ファイル名を、左クリックすると、内容表示する。"
PRINT #9 :"  ↑ 重ねて、左クリックすると、(.BAS ならば、)"
PRINT #9 :" BASIC を、新しく起動、実行できます。 閉じると、続行。"& CHR$(0)
DO
   MOUSE POLL mx,my,mlb,mrb
   IF mrb=1 THEN EXIT DO   !右クリック
   IF mlb=1 THEN           !左クリック
      IF -1< my THEN
         IF 0< my THEN LET b=INT(mx)*27+CEIL(my) ELSE LET b=bak+1
         IF b=< n THEN
            IF b<>bak THEN
               CALL sampdisp
            ELSEIF UCASE$(right$(names$(b),4))=".BAS" THEN
               execute "BASIC.EXE" WITH("/NR",p$(m)& names$(b))
               CALL SetWindowPos( WinHandle("MAIN"       ),0,   0,  0, 720,600, 0)
               CALL SetWindowPos( WinHandle("TEXT"       ),0,   0, 70, 514,670, 0)
               CALL SetWindowPos( WinHandle("GRAPHICS"   ),0, 515,172,   0,  0, 1)
               CALL SetWindowPos( WinHandle("TEXTWINDOW2"),0, 515,  0, 509,180, 0)
            END IF
         END IF
      ELSEIF my< -1 THEN
         LET w=INT(my+6)*V+CEIL(mx)
         IF w< f THEN CALL basfiles
      END IF
      LET i=0
      DO
         WAIT DELAY .02
         MOUSE POLL mx,my,mlb,mrb
         IF mlb=0 AND mrb=0 THEN LET i=i+1 ELSE LET i=0
      LOOP UNTIL 5< i      !マウスボタンが離れるまで待つ。
   END IF
   WAIT DELAY 0            !クロックアップを押える
LOOP
PLOT AREA:0,-1;V,-1;V,0;0,0
SET TEXT BACKGROUND "TRANSPARENT"      !background none
PLOT TEXT,AT V*.3,0 :"終了しました。"

!-------------
SUB basfiles
   LET m=w
   CLEAR
   PLOT AREA:0,-1;V,-1;V,0;0,0
   SET TEXT BACKGROUND "TRANSPARENT"   !background none
   PLOT TEXT,AT V*.17,0 :"ココを左クリックすると順送り。 右クリックで、終了。"
   FOR i=0 TO 4
      FOR j=1 TO V
         LET w=i*V+j
         IF w=m THEN PLOT AREA:j-1,i-5;j,i-5;j,i-6;j-1,i-6
         IF wild$(w)="*.*" THEN LET w$=p$(w) ELSE LET w$=p$(w)& wild$(w)
         PLOT TEXT,AT j-1+0.03,i-5 :w$ !p$(w)& wild$(w)
      NEXT j
   NEXT i
   IF m>0 THEN LET n=files(p$(m)& wild$(m))
   IF n>0 THEN file list p$(m)& wild$(m), names$
   SET TEXT BACKGROUND "OPAQUE"        !background color 0
   FOR w=1 TO n
      PLOT TEXT,AT IP((w-1)/27)+0.03, MOD((w-1),27)+1 :"|"& names$(w)
   NEXT w
   LET bak=0
END SUB

!-------------
SUB sampdisp
   LET x=IP((bak-1)/27)
   LET y=MOD((bak-1),27)
   SET LINE COLOR 0
   PLOT LINES:x,y; x+1-0.03,y; x+1-0.03,y+1; x,y+1; x,y
   LET x=IP((b-1)/27)
   LET y=MOD((b-1),27)
   SET LINE COLOR 2
   PLOT LINES:x,y; x+1-0.03,y; x+1-0.03,y+1; x,y+1; x,y
   PRINT
   PRINT "!*******************************"
   PRINT "!"& p$(m)& names$(b)
   PRINT "!*******************************"
   WHEN EXCEPTION IN
      OPEN #1: NAME p$(m)& names$(b),ACCESS INPUT
      FOR L=1 TO 500      !最大 表示行数
         LINE INPUT #1,IF MISSING THEN EXIT FOR :w$
         FOR i=1 TO LEN(w$)
            IF w$(i:i)< " " AND w$(i:i)<>CHR$(9) THEN CAUSE EXCEPTION 1
         NEXT i
         PRINT w$
      NEXT L
   USE
      PRINT "******* テキストではない、表示の中止。"
   END WHEN
   CLOSE #1
   LET bak=b
END SUB

END
 

あるパズルの質問

 投稿者:GAI  投稿日:2010年 6月11日(金)18時30分9秒
  9個の数字 111222333 が右のように並んでいる。             (111,222,333)

これに対して下のような操作を何回か行って右の形にしたい。  (123,231,312)

3つの成分(111等を成分と呼ぶことにする)のうちの1つから後ろから何個かを取ってそれを順序を変えないで他の成分の後ろに付け加える。

できるだけ短い手数でするにはどのようにすればよいか。

これに対して次のようにすれば6手でできる。

(111,222,333)→(1,222,33311)→(12,22,33311)→(12,2,333112)→(12,23112,33)→(123,23112,3)→(123,231,312)

これに対して
(1111,2222,3333,4444)に対して上の操作をできるだけ少ない回数行って

(1234,2341,3412,4123)にする手順を探したいのですが、可能ですか?
 

Re: あるパズルの質問

 投稿者:山中和義  投稿日:2010年 6月11日(金)23時22分48秒
  > No.1249[元記事へ]

GAIさんへのお返事です。

> (1234,2341,3412,4123)にする手順を探したいのですが、可能ですか?

元の数は剰余とみて
( 1111, 2222, 3333, 4444 )

( 1555, 2266, 3337, 4444 )
のように変更して考えてみると
 12 手 ( 1234, 2345, 3456, 4567 )
 11 手 ( 1234, 2345567, 3456, 4 )
 10 手 ( 1234, 23, 3456, 445567 )
  9 手 ( 1234456, 23, 3, 445567 )
  8 手 ( 1234456, 2, 33, 445567 )
  7 手 ( 1, 2234456, 33, 445567 )
  6 手 ( 15567, 2234456, 33, 44 )
  5 手 ( 15567, 223, 33, 444456 )
  4 手 ( 15567, 22, 333, 444456 )
  3 手 ( 1556, 22, 3337, 444456 )
  2 手 ( 1556, 226, 3337, 44445 )
  1 手 ( 155, 2266, 3337, 44445 )
  0 手 ( 1555, 2266, 3337, 4444 )
「場合の数」を減ら工夫
・成分の一番左は基準のため不動とする。
・移動先の数値に連続するように移動する数字の数を選ぶ。
(元からの順を考慮すると、並びは左から昇順になる)

また、3つの数字では(提示された例とは異なりますが、上の規則を適用すると)
 6 手 ( 123, 234, 345 )
 5 手 ( 12334, 2, 345 )
 4 手 ( 1, 22334, 345 )
 3 手 ( 145, 22334, 3 )
 2 手 ( 145, 22, 3334 )
 1 手 ( 14, 225, 3334 )
 0 手 ( 144, 225, 333 )
 

Re: あるパズルの質問の質問

 投稿者:GAI  投稿日:2010年 6月12日(土)11時35分9秒
  > No.1250[元記事へ]

山中和義さんへの質問

> 元の数は剰余とみて
>  ( 1111, 2222, 3333, 4444 )
> を
>  ( 1555, 2266, 3337, 4444 )
> のように変更して考えてみると



この発想はどのようにして思いつかれるものなのですか?
山中さんの頭の中に巡る考え方の筋道や手順が、
どこから生まれ、なにがポイントと見えているのか、
言語でご説明しにくいでしょうが、まさにそこが知りたい部分なので可能な限りで
構いませんので教えて下さい。
 

Re: あるパズルの質問の質問

 投稿者:山中和義  投稿日:2010年 6月12日(土)19時42分7秒
  > No.1251[元記事へ]

GAIさんへのお返事です。

> この発想はどのようにして思いつかれるものなのですか?

幅優先探索で検証することを考えました。
これは手を進めていく方法で、「場合の数」を樹形図で表現することと同じです。
そうすると、この数が多いと計算時間がかかり過ぎるので、減らすことにしました。→枝刈り

たとえば、1手目を考えると

(111,222,333)の場合
 111の1は、222と333の右端に移動できる。2通り(移動可能かどうかで判断)
 111の11は、222と333の右端に移動できる。2通り
 これが、222,333でも同じ。したがって、(2+2)*3=12通り

(144,225,333)の場合
 144の4は、333の右端に移動できる。1通り(前述の規則を適用)
 144の44は、333の右端に移動できる。1通り
 225の5は、144の右端に移動できる。1通り
 したがって、1+1+1=3通り

となります。
最初の場合は、対称性がありますが、2番目の場合は除外したものになります。
これは、225の2と5などのように数字を区別することで、
左移動や右移動を制限でき、最終位置への移動を明示できます。→盤面の展開、進行

また、プログラムしやすいように数字の並びを調整しました。→番兵、マジックナンバー

この2つを同時に解決する数字がこの案です。

そうは言っても、n=5は苦闘中です、、、12手で16万の盤面パターンがあります。
 

5色混合

 投稿者:GAI  投稿日:2010年 6月14日(月)19時41分43秒
  0:(11111,22222,33333,44444,55555)
1:(1,22222,33333,44444,555551111)
2:(1,22,33333,44444,555551111222)
3:(12,2,33333,44444,555551111222)
4:(12,2,333,44444,55555111122233)
5:(123,2,33,44444,55555111122233)
6:(123,2,33,4444,555551111222334)
7:(1234,2,33,444,555551111222334)
8:(1234,23,3,444,555551111222334)
9:(1234,234,3,44,555551111222334)
10:(1234,234,34,4,555551111222334)
11:(123455551111222334,234,34,4,5)
12:(12345,2345551111222334,34,4,5)
13:(12345,2345,34551111222334,4,5)
14:(12345,2345,345,451111222334,5)
15:(12345,2345111222334,345,451,5)
16:(12345,23451,34511222334,451,5)
17:(12345,23451,3451,4511222334,5)
18:(12345,23451,3451,451,51222334)
19:(12345,23451,345122334,451,512)
20:(12345,23451,34512,4512334,512)
21:(12345,23451,34512,45123,51234)

機械的に移動させていくと21手かかってしまいます。
これを20手にすることは可能ですか?
 

Re: 5色混合

 投稿者:山中和義  投稿日:2010年 6月14日(月)20時25分19秒
  > No.1253[元記事へ]

GAIさんへのお返事です。

> 機械的に移動させていくと21手かかってしまいます。
> これを20手にすることは可能ですか?

中間列を経由させると展開が機械的に可能のようです。

n=3の場合
(111,222,333)
  ↓ 3回 一般式(n-1)*n/2
(12,2,333112)
  ↓ 3回 一般式(n-1)*n/2
(123,231,312)


n=4の場合
(1111,2222,3333,4444)
  ↓ 6回
(123,23,3,4444111223)
  ↓ 6回
(1234,2341,3412,4123)


n=5の場合
(11111,22222,33333,44444,55555)
  ↓ 10回
(1234,234,34,4,555551111222334)
  ↓ 10回
(12345,23451,34512,45123,51234)


後半の展開
・右端成分の数字列を「並び」になるように数字列を分離する。
・その「並び」を置ける位置を探して移動させる。


n=4の場合
(123,23,3,4-4-4-41-1-12-23)


実際の操作
n=3
3 (12, 2, 3*3-31-12) *位置で切り出す
4 (12-3*31-12, 2, 3) 1へ
5 (12-3, 2-31*12, 3) 2へ
6 (12-3, 2-31, 3-12) 3へ

n=4
6 (123, 23, 3, 4*4-4-41-1-12-23)
7 (123-4*4-41-1-12-23, 23, 3, 4)
8 (123-4, 23, 3-4*41-1-12-23, 4)
9 (123-4, 23-41*1-12-23, 3-4, 4)
10 (123-4, 23-41, 3-4, 4-1*12-23)
11 (123-4, 23-41, 3-4-12*23, 4-1)
12 (123-4, 23-41, 3-4-12, 4-1-23)

n=5
10 (1234, 234, 34, 4, 5*5-5-5-51-1-1-12-2-23-34)
11 (1234-5*5-5-51-1-1-12-2-23-34, 234, 34, 4, 5) 1へ
12 (1234-5, 234-5*5-51-1-1-12-2-23-34, 34, 4, 5) 2へ
13 (1234-5, 234-5, 34-5*51-1-1-12-2-23-34, 4, 5) 3へ
14 (1234-5, 234-5, 34-5, 4-51*1-1-12-2-23-34, 5) 4へ
15 (1234-5, 234-5-1*1-12-2-23-34, 34-5, 4-51, 5) 2へ
16 (1234-5, 234-5-1, 34-5-1*12-2-23-34, 4-51, 5) 3へ
17 (1234-5, 234-5-1, 34-5-1, 4-51, 5-12*2-23-34) 5へ
18 (1234-5, 234-5-1, 34-5-1-2*23-34, 4-51, 5-12) 3へ
19 (1234-5, 234-5-1, 34-5-1-2, 4-51-23*34, 5-12) 4へ
20 (1234-5, 234-5-1, 34-5-1-2, 4-51-23, 5-12-34) 5へ
 

Re: あるパズルの質問の質問

 投稿者:山中和義  投稿日:2010年 6月15日(火)10時08分11秒
  > No.1252[元記事へ]

「並び」とは、たとえばn=3の場合12,23,31に並んだ数字列の数とする。
 例 開始パターン(111,222,333) 並びは0個
   終了パターン(123,231,312) 並びは123の12,23、231の23,31、312の31,12で6個

この問題を解くには、この「並び」を増やしていけばよい。

回数は、(終了-開始)の個数は必要である。(1回の移動で「並び」は-1,0,+1と変化するので)
その回数の例を示せば、それが最少の回数となる。一般式 (n-1)*n 回


操作例(樹形図)
0手目
(111,222,333) 並びは0個

1手目
(11,2221,333) 並びは2221の21で1個
(1,22211,333) 並びは22211の21で1個
(1112,22,333) 並びは1112の12で1個
(11122,2,333) 並びは11122の12で1個

2手目
(11,2221,333)から
 (1121,22,333) 並びは1121の12,21で2個
 (11,22,33321) 並びは33321の32,21で2個
 (11221,2,333) 並びは11221の12,21で2個
 (11,2,333221) 並びは333221の32,21で2個
(1,22211,333)から
  :(略)
  :

n手目にn個になるように、終了パターンの並びが増えるように移動させる。

●サンプル・プログラム
LET t0=TIME


LET N=3 !数字列の数

DIM M$(50000,N),P(50000,2) !盤面
!!RANDOMIZE

FOR i=1 TO N !初期状態
!!!LET M$(1,i)="0"&REPEAT$(STR$(i),N) !(123,123,123)型 ←←←←←
   LET M$(1,i)=REPEAT$(STR$(i),N) !(123,231,312)型
NEXT i
LET P(1,1)=0 !0手目
LET P(1,2)=0 !展開元へのリンク

LET CNT=1 !盤面の数


!!!LET PTN$="0" !終了パターン (123,123,123)型 ←←←←←
LET PTN$="" !終了パターン (123,231,312)型
FOR i=1 TO 2*N-1
   LET PTN$=PTN$&STR$(MOD(i-1,N)+1)
NEXT i
PRINT PTN$

DIM T$(N),B$(N)

LET no=1 !展開元の盤面の位置
DO WHILE no<=CNT !収束するまで
   LET nm=P(no,1)+1
   PRINT nm;"手目"; CNT !debug

   FOR k=1 TO N !copy it
      LET B$(k)=M$(no,k)
   NEXT k
   CALL move(nm,B$) !幅優先探索

   LET no=no+1 !次の盤面へ
LOOP

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


SUB move(nm,B$()) !盤面を展開する
   FOR x=1 TO N !各成分から
      LET XX$=M$(no,x)
      LET L=LEN(XX$)
      FOR i=1 TO L-1 !各数字列を順に
         LET w$=RIGHT$(XX$,i) !切り出す

         FOR yy=x+1 TO x+N-1 !移動させる
            LET y=MOD(yy-1,N)+1 !他の場所へ x<>y

            FOR k=1 TO N !copy it
               LET T$(k)=B$(k)
            NEXT k
            LET T$(x)=LEFT$(T$(x),L-i) !move it
            LET T$(y)=T$(y)&w$


            LET h=0 !評価関数 ※「並び」の数 例 1123なら、2。112456なら、3
            FOR j=1 TO N
               LET w1=VAL(T$(j)(1:1)) !1文字目
               FOR k=2 TO LEN(T$(j)) !2文字目以降
                  LET w2=VAL(T$(j)(k:k))
                  !!!IF w1+1=w2 THEN LET h=h+1 !(123,123,123)型 ←←←←←
                  IF w1+1=w2 OR w1+1=w2+N THEN LET h=h+1 !(123,231,312)型

                  LET w1=w2 !次の文字へ
               NEXT k
            NEXT j
            IF h>=nm THEN !!!
            !!IF h>=nm AND RND<0.3 THEN !!!確率で間引く ※nに応じて調整が必要である n=4

               FOR j=1 TO CNT !新しい盤面かどうか?
                  FOR k=1 TO N
                     IF M$(j,k)<>T$(k) THEN EXIT FOR
                  NEXT k
                  IF k>N THEN EXIT FOR
               NEXT j
               IF j>CNT THEN !新しい盤面を記録する
                  LET CNT=CNT+1
                  FOR k=1 TO N !copy it
                     LET M$(CNT,k)=T$(k)
                  NEXT k
                  LET P(CNT,1)=nm !手の番号
                  LET P(CNT,2)=no !リンク


                  FOR k=1 TO N !終了パターンかどうか?
                  !!!IF T$(k)<>LEFT$(PTN$,N+1) THEN EXIT FOR !(123,123,123)型 ←←←←←
                     IF T$(k)<>MID$(PTN$,k,N) THEN EXIT FOR !(123,231,312)型
                  NEXT k
                  IF k>N THEN CALL PrintOut(CNT) !盤面を表示する

               END IF

            END IF !手詰まり

         NEXT yy

      NEXT i
   NEXT x
END SUB

SUB PrintOut(CNT) !盤面を表示する
   LET j=CNT
   DO
      PRINT P(j,1);"手";
      PRINT " ( ";M$(j,1); !盤面
      FOR k=2 TO N
         PRINT ", ";M$(j,k);
      NEXT k
      PRINT " )"

      LET j=P(j,2) !リンクを遡る
   LOOP UNTIL j=0
END SUB

END

「場合の数」は指数関数的に増加する。

n=5以上では天文学的な数になるので、ヒューリスティックな問題解決が望まれる。
・「場合の数」を減らす工夫 No.1250 参照のこと
・中間列を経由して機械的に展開 No.1254 参照のこと
 

6色混合

 投稿者:GAI  投稿日:2010年 6月16日(水)06時00分0秒
  0:177777,228888,333999,4444xx,55555y,666666
1:1,228888,333999,4444xx,55555y,66666677777
2:1,22,333999,4444xx,55555y,666666777778888
3:12,2,333999,4444xx,55555y,666666777778888
4:12,2,333,4444xx,55555y,666666777778888999
5:123,2,33,4444xx,55555y,666666777778888999
6:123,23,3,4444xx,55555y,666666777778888999
7:123,23,3,4444,55555y,666666777778888999xx
8:123,23,3,4444,55555,666666777778888999xxy
9:1234,23,3,444,55555,666666777778888999xxy
10:1234,234,3,44,55555,666666777778888999xxy
11:1234,234,34,4,55555,666666777778888999xxy
12:12345,234,34,4,5555,666666777778888999xxy
13:12345,2345,34,4,555,666666777778888999xxy
14:12345,2345,345,4,55,666666777778888999xxy
15:12345,2345,345,45,5,666666777778888999xxy
16:1234566666777778888999xxy,2345,345,45,5,6
17:123456,23456666777778888999xxy,345,45,5,6
18:123456,23456,345666777778888999xxy,45,5,6
19:123456,23456,3456,4566777778888999xxy,5,6
20:123456,23456,3456,456,56777778888999xxy,6
21:123456,23456,3456,456,567,677778888999xxy
22:123456,234567778888999xxy,3456,456,567,67
23:123456,234567,3456778888999xxy,456,567,67
24:123456,234567,34567,45678888999xxy,567,67
25:123456,234567,34567,45678,567888999xxy,67
26:123456,234567,34567,45678,5678,6788999xxy
27:123456,234567,345678999xxy,45678,5678,678
28:123456,234567,345678,45678999xxy,5678,678
29:123456,234567,345678,456789,5678,67899xxy
30:123456,234567,345678,456789,56789xxy,6789
31:123456,234567,345678,456789,56789x,6789xy

どこを変更したらいいか教えて下さい。
 

Re: 6色混合

 投稿者:山中和義  投稿日:2010年 6月16日(水)07時22分13秒
  > No.1256[元記事へ]

GAIさんへのお返事です。

> どこを変更したらいいか教えて下さい。
  0 手 ( 111111, 222222, 333333, 444444, 555555, 666666 ) 0 → 0
  1 手 ( 1, 222222, 333333, 444444, 555555, 66666611111 ) 1 → 6  11111
  2 手 ( 1, 22, 333333, 444444, 555555, 666666111112222 ) 2 → 6  2222
  3 手 ( 1, 22, 333, 444444, 555555, 666666111112222333 ) 3 → 6  333
  4 手 ( 1, 22, 333, 4444, 555555, 66666611111222233344 ) 4 → 6  44
  5 手 ( 1, 22, 333, 4444, 55555, 666666111112222333445 ) 5 → 6  5

  6 手 ( 12, 2, 333, 4444, 55555, 666666111112222333445 ) 2 → 1  2
  7 手 ( 123, 2, 33, 4444, 55555, 666666111112222333445 ) 3 → 1  3
  8 手 ( 123, 23, 3, 4444, 55555, 666666111112222333445 ) 3 → 2  3
  9 手 ( 1234, 23, 3, 444, 55555, 666666111112222333445 ) 4 → 1  4
 10 手 ( 1234, 234, 3, 44, 55555, 666666111112222333445 ) 4 → 2  4
 11 手 ( 1234, 234, 34, 4, 55555, 666666111112222333445 ) 4 → 3  4
 12 手 ( 12345, 234, 34, 4, 5555, 666666111112222333445 ) 5 → 1  5
 13 手 ( 12345, 2345, 34, 4, 555, 666666111112222333445 ) 5 → 2  5
 14 手 ( 12345, 2345, 345, 4, 55, 666666111112222333445 ) 5 → 3  5
 15 手 ( 12345, 2345, 345, 45, 5, 666666111112222333445 ) 5 → 4  5


 16 手 ( 1234566666111112222333445, 2345, 345, 45, 5, 6 ) 6 → 1  66666111112222333445
 17 手 ( 123456, 2345, 3456666111112222333445, 45, 5, 6 ) 1 → 3  6666111112222333445
 18 手 ( 123456, 2345, 3456, 45666111112222333445, 5, 6 ) 3 → 4  666111112222333445
 19 手 ( 123456, 2345, 3456, 456, 566111112222333445, 6 ) 4 → 5  66111112222333445
 20 手 ( 123456, 23456111112222333445, 3456, 456, 56, 6 ) 5 → 2  6111112222333445
 21 手 ( 123456, 234561, 3456, 45611112222333445, 56, 6 ) 2 → 4  11112222333445
 22 手 ( 123456, 234561, 3456, 4561, 561112222333445, 6 ) 4 → 5  1112222333445
 23 手 ( 123456, 234561, 3456, 4561, 561, 6112222333445 ) 5 → 6  112222333445
 24 手 ( 123456, 234561, 345612222333445, 4561, 561, 61 ) 6 → 3  12222333445
 25 手 ( 123456, 234561, 345612, 4561, 561222333445, 61 ) 3 → 5  222333445
 26 手 ( 123456, 234561, 345612, 4561, 5612, 6122333445 ) 5 → 6  22333445
 27 手 ( 123456, 234561, 345612, 45612333445, 5612, 612 ) 6 → 4  2333445
 28 手 ( 123456, 234561, 345612, 456123, 5612, 61233445 ) 4 → 6  33445
 29 手 ( 123456, 234561, 345612, 456123, 56123445, 6123 ) 6 → 5  3445
 30 手 ( 123456, 234561, 345612, 456123, 561234, 612345 ) 5 → 6  45
 

N色混合(111,222,333)→(123,231,312)型

 投稿者:山中和義  投稿日:2010年 6月17日(木)11時06分36秒
  > No.1249[元記事へ]

攻略法の1つを示します。(必勝パターン)
!(111,222,333)→(123,231,312)型 ※N*(N-1)回

LET N=5 !成分の数


DIM P$(N) !各成分の初期値
FOR i=1 TO N
   LET P$(i)=REPEAT$(fnSTR1$(i),N)
NEXT i
LET S=0 !第s手目
CALL PrintOut(S)


!●前半 - 右端へ収集する 計(N-1)+Σ[k=1,N-2]{k}=N*(N-1)/2回

!■前半の展開
! 目標 10手 (1234,234,34,4,555551111222334)

!Step.1 ※(N-1)回
! 右端成分に、1つずつ連続する数字の個数が少なくなるように「並び」の順に数字を集める。

LET y=N !xからyへ移動
FOR i=1 TO N-1
   LET x=i
   LET w$=RIGHT$(P$(x),N-i) !target
   CALL move(x,y,w$,x) !move it
NEXT i
PRINT

!Step.2 ※Σ[k=1,N-2]{k}回
! 左端成分から右端手前の成分までは、残りの数字を使って、
! 各成分で1つずつ数字の個数が少なくなるように「並び」の順に数字を集める。
!理由
! (1,2-2,3-3-3,4-4-4-4,555551111222334)
!   ↑  ↑  ↑
!  1個、2個、3個をそれぞれ移動させる

FOR k=1 TO N-2
   LET x=k+1 !この位置の左側へ
   LET w$=RIGHT$(P$(x),k) !target
   FOR y=1 TO k
      CALL move(x,y,w$,1) !move it
   NEXT y
NEXT k
PRINT
PRINT



!●後半 - 右端 -5-5-5-51-1-1-12-2-23-34 を分配する Σ[k=1,N-1]{k}=N*(N-1)/2回

!■後半の展開
!・右端成分の数字列を「並び」になるように数字列を分割する。
! ※ハイフォンの数が移動回数となる。
!・その「並び」を置ける位置へ移動させる。最後の2文字を埋めるのは、「並び」が2文字に限る。
! 例 -51は、2番目の成分234を埋める。
! ※最終パターンを最後2文字が「並び」になるように分割する。これを目安にする。
!
! 目標 10手 (1234-5,234-51,34-5-12,4-5-1-23,5-1-2-34)
!
!理由
! -5-5-5-51 4個
! -1-1-12  3個
! -2-23   2個
! -34    1個をそれぞれ移動させる

LET x=N !右端の移動させる数字列
LET w$=RIGHT$(P$(x),N*(N+1)/2-1)

FOR k=N-1 TO 1 STEP -1

   LET w1=fnVAL1(LEFT$(w$,1))

   FOR j=1 TO k-1 !最初に1文字を埋める ※-5-5-5,-1-1,-2
      FOR y=1 TO N !左端から一巡内で順に探す
         LET t=LEN(P$(y))
         !PRINT x;y;w$;L !debug

         IF t>=N OR t=N-2 THEN !「N文字揃っている」か「残りが2文字」なら、スキップする
         !nop
         ELSE
            LET pp=fnVAL1(RIGHT$(P$(y),1)) !結合部分が「並び」になるなら
            IF pp+1=w1 OR pp+1=w1+N THEN
               CALL move(x,y,w$,1) !move it
               EXIT FOR
            END IF
         END IF
      NEXT y
      IF y>N THEN !場所がない(発生しないはず)
         PRINT "アルゴリズムのエラーです。"
         STOP
      END IF
   NEXT j


   LET y=N-k+1 !最後に2文字を埋める ※-51,-12,-23,-34
   CALL move(x,y,w$,2) !move it

NEXT k


SUB move(x,y,w$,L) !xからyへ移動
   LET P$(x)=LEFT$(P$(x),LEN(P$(x))-LEN(w$)) !move it
   LET P$(y)=P$(y)&w$

   LET S=S+1 !dump it
   CALL PrintOut(S)

   LET x=y !配置位置を記録する
   LET w$=RIGHT$(w$,LEN(w$)-L) !L文字切り出す。次へ
END SUB

SUB PrintOut(S) !成分を表示する
   PRINT USING "### 手 ( ":S;
   PRINT P$(1);
   FOR t=2 TO N
      PRINT ", ";P$(t);
   NEXT t
   PRINT " )";

   PRINT USING " ## → ## ":x,y; !移動詳細
   PRINT " ";w$
END SUB


!N進法表記

FUNCTION fnVAL1(x$) !1文字の数字を数値に変換する
   LET fnVAL1=POS("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",x$)
END FUNCTION

FUNCTION fnSTR1$(x) !1桁の数値を数字に変換する
   LET fnSTR1$=MID$("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",x+1,1)
END FUNCTION

END

実行結果
  0 手 ( 11111, 22222, 33333, 44444, 55555 )  0 →  0
  1 手 ( 1, 22222, 33333, 44444, 555551111 )  1 →  5  1111
  2 手 ( 1, 22, 33333, 44444, 555551111222 )  2 →  5  222
  3 手 ( 1, 22, 333, 44444, 55555111122233 )  3 →  5  33
  4 手 ( 1, 22, 333, 4444, 555551111222334 )  4 →  5  4

  5 手 ( 12, 2, 333, 4444, 555551111222334 )  2 →  1  2
  6 手 ( 1233, 2, 3, 4444, 555551111222334 )  3 →  1  33
  7 手 ( 123, 23, 3, 4444, 555551111222334 )  1 →  2  3
  8 手 ( 123444, 23, 3, 4, 555551111222334 )  4 →  1  444
  9 手 ( 1234, 2344, 3, 4, 555551111222334 )  1 →  2  44
 10 手 ( 1234, 234, 34, 4, 555551111222334 )  2 →  3  4


 11 手 ( 123455551111222334, 234, 34, 4, 5 )  5 →  1  55551111222334
 12 手 ( 12345, 234, 345551111222334, 4, 5 )  1 →  3  5551111222334
 13 手 ( 12345, 234, 345, 4551111222334, 5 )  3 →  4  551111222334
 14 手 ( 12345, 23451111222334, 345, 45, 5 )  4 →  2  51111222334
 15 手 ( 12345, 23451, 345, 45111222334, 5 )  2 →  4  111222334
 16 手 ( 12345, 23451, 345, 451, 511222334 )  4 →  5  11222334
 17 手 ( 12345, 23451, 3451222334, 451, 51 )  5 →  3  1222334
 18 手 ( 12345, 23451, 34512, 451, 5122334 )  3 →  5  22334
 19 手 ( 12345, 23451, 34512, 4512334, 512 )  5 →  4  2334
 20 手 ( 12345, 23451, 34512, 45123, 51234 )  4 →  5  34
 

N色混合(111,222,333)→(123,123,123)型

 投稿者:山中和義  投稿日:2010年 6月17日(木)11時08分53秒
  > No.1258[元記事へ]

攻略法の1つを示します。(必勝パターン)
!(111,222,333)→(123,123,123)型 ※(N^2-1)回

LET N=3 !成分の数

DIM P$(N) !各成分の初期値
FOR i=1 TO N
   LET P$(i)=REPEAT$(fnSTR1$(i),N)
NEXT i
LET S=0 !第s手目
CALL PrintOut(S)

!●前半 - 左端へ収集する (111222333,*,*) ※(N-1)回
LET y=1 !←←←←← ※LET y=N !(111,222,333)→(321,321,321)型
FOR x=2 TO N !←←←←← ※FOR x=N-1 TO 1 STEP -1
   LET w$=P$(x) !target

   LET P$(y)=P$(y)&P$(x) !move it
   LET P$(x)=""

   LET S=S+1 !dump it
   CALL PrintOut(S)
NEXT x
PRINT

!●後半 - 左端 -1-12-2-23-3-3 を右シフトで分配する ※(N-1)+(N-1)*N-(N-1)=(N^2-N)回
!理由
! 移動させる1の数 (N-1)個
! 移動させる2~Nの数 (N-1)*N個
! 「並び」23,34,…,(N-1)N の数 (N-1)個
LET x=1 !左端の移動させる数字列 ←←←←← ※LET x=N
LET w$=RIGHT$(P$(x),N^2-1)

FOR i=1 TO N^2-N !xからyへ移動する
   LET y=CalcPos(x+1) !右隣の位置

   !PRINT x;y;w$;L !debug
   LET P$(x)=LEFT$(P$(x),LEN(P$(x))-LEN(w$))
   LET P$(y)=P$(y)&w$ !move it

   LET S=S+1 !dump it
   CALL PrintOut(S)

   LET L=1 !「並び」から1文字か2文字の分割を選択する
   IF LEN(w$)>1 THEN
      LET w1=fnVAL1(LEFT$(w$,1))
      LET w2=fnVAL1(MID$(w$,2,1))
      IF w1+1=w2 THEN LET L=2 !←←←←← ※IF w1=w2+1 THEN LET L=2
   END IF

   LET w$=RIGHT$(w$,LEN(w$)-L) !次へ

   LET x=CalcPos(x+1) !右シフト
NEXT i


FUNCTION CalcPos(x) !位置を算出する
   LET CalcPos=MOD(x-1,N)+1 !1~N
END FUNCTION

SUB PrintOut(S) !成分を表示する
   PRINT USING "### 手 ( ":S;
   PRINT P$(1);
   FOR t=2 TO N
      PRINT ", ";P$(t);
   NEXT t
   PRINT " )";

   PRINT x;"→";y;" ";w$ !移動詳細
END SUB


!N進法表記

FUNCTION fnVAL1(x$) !1文字の数字を数値に変換する
   LET fnVAL1=POS("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",x$)
END FUNCTION

FUNCTION fnSTR1$(x) !1桁の数値を数字に変換する
   LET fnSTR1$=MID$("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",x+1,1)
END FUNCTION

END

実行結果
  0 手 ( 111, 222, 333 ) 0 → 0
  1 手 ( 111222, , 333 ) 2 → 1  222
  2 手 ( 111222333, ,  ) 3 → 1  333

  3 手 ( 1, 11222333,  ) 1 → 2  11222333
  4 手 ( 1, 1, 1222333 ) 2 → 3  1222333
  5 手 ( 122333, 1, 12 ) 3 → 1  22333
  6 手 ( 12, 12333, 12 ) 1 → 2  2333
  7 手 ( 12, 123, 1233 ) 2 → 3  33
  8 手 ( 123, 123, 123 ) 3 → 1  3
 

Re: N色混合(111,222,333)→(123,123,123)型

 投稿者:GAI  投稿日:2010年 6月19日(土)07時42分23秒
  > No.1259[元記事へ]

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

この2つのソフトは大変役にたちます。
10種類(全部で100枚のカード)
を分配するのに、通常では100手掛かるところをn(n-1)である90手で
同じ効果をもたらす操作が可能なのですから、この原理を使えば何か仕分け作業
での効率化を自動で行うコンピュータでのプログラミングに適応するなどの応用例
がありそうな気がします。

私は、カードマジックに応用したいと思います。
ありがとうございました。
 

(無題)

 投稿者:  投稿日:2010年 6月19日(土)15時01分39秒
  TextWindowに色を付けたいのですが、出来ますか。  

Re: (無題)

 投稿者:白石 和夫  投稿日:2010年 6月19日(土)21時33分36秒
  > No.1261[元記事へ]

> TextWindowに色を付けたいのですが、出来ますか。

こちらをご覧ください。
http://hp.vector.co.jp/authors/VA008683/TextColor.htm
ただし,Windows限定です。
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 6月25日(金)11時24分17秒
  > No.1247[元記事へ]

問題
5つの自然数(同じものを含む)で、その積と和が等しいものをすべて求めよ。
LET N=5 !個数

DIM A(0 TO N) !並び
LET A(0)=1 !番兵
CALL try(1,N,A)

END


!題意より、N個の自然数A≧B≧C≧…≧D≧Eから、A*B*C* … *D*E=A+B+C+ … +D+E
!右辺を最大の値 Aで置き換えるとA*B*C* … *D*E=A+B+C+ … +D+E≦N*A
!よって、B*C* … *D*E≦N (i)式とする
!得られた左辺を同様に最小の値 Eで置き換えると、E^(N-1)≦B*C* … *D*E≦N
!これより、1≦E≦INT(N^(1/(N-1))) ※Nの(N-1)乗根
!
!E=1のとき
! (i)式より、B*C* … *D≦N ←(ii)式
! 最小の値 Dで置き換えると、D^(N-2)≦B*C* … *D≦N
! これより、E=1≦D≦INT(N^(1/(N-2)))
!
! D=1のとき
!   :
!
!  (n-3)式より、B*C≦N ←(n-2)式
!  最小の値 Cで置き換えると、C^2≦B*C≦N
!  これより、D=1≦C≦INT(N^(1/2)
!
!  C=1のとき
!   (n-2)式より、B≦N ←(n-1)式
!   これより、C=1≦B≦N
!
!   B=1のとき
!    s=B*C* … *D*E、w=B+C+ … +D+Eとすると、A*s=A+w、A=w/(s-1)
!   B=2のとき
!    :略
!   B=Nのとき
!    :略
!
!  C=2のとき
!   :略
!  C=INT(N^(1/2)のとき
!   :略
!
! D=2のとき
!   :略
! D=INT(N^(1/(N-2)))のとき
!   :略
!
!E=2のとき
! :略
!E=INT(N^(1/(N-1)))のとき
! :略

EXTERNAL SUB try(p,N,A()) !場合分け
IF p=N THEN !最後の数Aなら
   FOR i=1 TO N-1 !debug
      PRINT A(i);
   NEXT i
   PRINT

   LET w=A(1) !和w=B+C+ … +D+E
   LET s=A(1) !積s=B*C* … *D*E
   FOR i=2 TO N-1
      LET w=w+A(i)
      LET s=s*A(i)
   NEXT i
   IF s>1 THEN !A≧Bなる自然数A
      LET t=w/(s-1)
      IF t>=A(N-1) AND t=INT(t) THEN

         LET A(N)=t

         PRINT A(1); !結果を表示する
         FOR i=2 TO N
            PRINT "+";A(i);
         NEXT i
         PRINT "="; A(1);
         FOR i=2 TO N
            PRINT "*";A(i);
         NEXT i
         PRINT

      END IF
   END IF

ELSE !E,D,…,C,Bなら
   FOR i=A(p-1) TO INT(N^(1/(N-p))) !条件を満たす範囲をすべて検証する
      LET A(p)=i
      CALL try(p+1,N,A) !次へ
   NEXT i

END IF
END SUB


類題
 N個の自然数(同じものを含む)で、その積と和が等しいものをすべて求めよ。
答え
 2*n=(n-2)+2+nより、和 1*(n-2)+2*1+n*1=2*n 積 1^(n-2)*2^1*n^1=2*n
 (n-2)個の1、1個の2、1個のnの並び(1,1,…,1,2,n)がその1つとなる。
 

和=積 のパターン数調べ

 投稿者:GAI  投稿日:2010年 6月25日(金)19時31分41秒
  山中さんのプログラムを弄って
いろいろ調べていたら、例のオンライン整数列大辞典
http://www.research.att.com/~njas/sequences/A033178
にそのパターン数がありました。
ちなみに、最も多いn=85での10パターンは具体的に

(1,・・・・・,1,2,85)
(1,・・・・・,1,3,43)
(1,・・・・・,1,4,29)
(1,・・・・・,1,5,22)
(1,・・・・・,1,7,15)
(1,・・・・・,1,8,13)
(1,・・・・,1,2,7,7)
(1,・・・・,1,3,3,11)
(1,・・・・,1,4,4,6)
(1,・・・,1,2,2,3,8)

であることがわかりました。

(追伸)
ある人の調査によると、
n=1000000までのパターンが最大にとれる場所が

100までの最大は10(n=85)
1000までの最大は22(n=793)
10000までの最大は51(n=9361)
100000までの最大は95(n=95761)
1000000までの最大は209(n=967573)

であるという結果を教えて頂きました。
 

Re: センター試験程度のプログラム演習

 投稿者:山中和義  投稿日:2010年 6月26日(土)07時06分29秒
  > No.1263[元記事へ]

補足 1以外の数は何個?

nは自然数の個数とする。
すべて1の場合、和 1*n 積 1^nなので、和の方が大きい。
すべて2の場合、和 2*n 積 2^nなので、n≧3で積の方が大きい。等号は1,2(1=1、2+2=2*2を意味する)
したがって、いくつかを1以外、すなわち2以上の値となる必要がある。
その個数をmとする。最小の並び(1,…,1,2,…,2)で評価する式を考えると
和 1*(n-m)+2*m=n+m 積 1^(n-m)*2^m=2^m となる。
1つの場合は、和 1*(n-1)+2*1=n+1 積 2なので、n≧1で常に和の方が大きい。m≧2である。
一般に和<積なので、大小関係が和≧積から和<積に変わるまでが検証範囲となる。
n=5の場合
m 和n+m  積2^m
1 5+1 > 2
2 5+2 > 4
3 5+3 ≧ 8 ←←←
4 5+4 < 16
  :
3個以下となる。


n=85の場合
m 和n+m  積2^m
1 85+1 > 2
2 85+2 > 4
3 85+3 > 8
4 85+4 > 16
5 85+5 > 32
6 85+6 > 64 ←←←
7 85+7 < 128
  :
6個以下となる。

●サンプル・プログラム
!問題
!5つの自然数(同じものを含む)で、その積と和が等しいものをすべて求めよ。

LET t0=TIME


PUBLIC NUMERIC N !自然数の個数
LET N=5 !85 !793 !9361 !95761 !967573

DIM A(N) !並び
MAT A=CON !初期値(1,…,1)

PUBLIC NUMERIC c !解答数
LET c=0

LET m=2 !2以上の数の個数
DO WHILE N+m>=2^m
   FOR i=N-m+1 TO N !2を左に追加する (1,…,1,2,…,2) ※(n-m)個の1とm個の2
      LET A(i)=2
   NEXT i
   CALL try(1,m,A,0)

   LET m=m+1
LOOP


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

END


EXTERNAL SUB try(p,m,A(),FLG) !「m個の2」を+1する
IF p=m THEN
   DO
      LET w=1*(N-m) !和
      LET s=1^(N-m) !積
      FOR i=N-m+1 TO N !残りの2以上の数
         LET w=w+A(i)
         LET s=s*A(i)
      NEXT i
      !!!MAT PRINT A; !debug

      IF w< s THEN EXIT SUB !和<積

      IF w=s THEN !和=積
         LET c=c+1 !結果を表示する
         PRINT "No.";c

         PRINT "(1,…,1"; !1は省略
         FOR i=N-m+1 TO N
            PRINT ",";STR$(A(i));
         NEXT i
         PRINT ")"
      END IF

      LET A(N)=A(N)+1 !この桁を+1
      LET FLG=1 !可能性あり
   LOOP

ELSE
   DO
      LET w=0 !可能性 ※最初から「和<積」になっている
      CALL try(p+1,m,A,w)
      IF w=0 THEN EXIT SUB !可能性がないなら

      LET t=A(N-(m-p))+1 !この桁を+1 (1,…,1,3,…,3)、(1,…,1,4,…,4)、…
      FOR i=N-(m-p) TO N !最小の並びにする
         LET A(i)=t
      NEXT i
      LET FLG=1 !可能性あり
   LOOP

END IF
END SUB
 

数の移動

 投稿者:GAI  投稿日:2010年 6月26日(土)18時56分32秒
  下図のような空所がある。

 *  *  *  *  *  *  *


この空所に、数字の1から5までが順に並んでいる。

 *  * 1 2 3 4 5


 これらの数字を、次のルールに従って並べ替える。

(ルール)
1. 1→2→3→4→5→1→2→・・・ と数字の順番に、数字を、数字
    の入っていない空所のどちらかに移動する。

2. 1回の操作で動かせる数字は、ひとつだけとする。

このとき、次のように数字を並べ替えるには、最低何回の操作が必要であろうか?

 *  * 5 4 3 2 1


これに対し
次のように並べ替えればよい。

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



では

   *  *  1  2  3  4  5  6
から始めて
      *  *  6 5 4  3  2  1

へ最短手数で移動する手順を調べて下さい。

一般に1~nまでの数字では可能か?
またあればその最短手数は何手かかるのか?
 

(無題)

 投稿者:しいメール  投稿日:2010年 6月27日(日)02時00分42秒
  I~Lはすべて自然数として
L^3=I^3+J^3+K^3
を満たすLを求めるプログラムの組みかたを教えて下さい。
一例として、6^3=3^3+4^3+5^3があります。
3時間くらいかかって色々やってみたつもりなんですが、詰まってしまいました。
できれば、倍数の組は除外したいです
よろしくお願いします
 

Re: 数の移動

 投稿者:山中和義  投稿日:2010年 6月27日(日)07時15分31秒
  > No.1266[元記事へ]

GAIさんへのお返事です。

> 最短手数で移動する手順を調べて下さい。

実行結果 n=6の場合
 21 00654321 4
 20 30654021 3
 19 30654201 2
 18 30654210 1
 17 30054216 6
 16 30504216 5
 15 30540216 4
 14 03540216 3
 13 23540016 2
 12 23540106 1
 11 23540160 6
 10 23045160 5
  9 23405160 4
  8 20435160 3
  7 02435160 2
  6 12435060 1
  5 12435006 6
  4 12430056 5
  3 12030456 4
  2 12003456 3
  1 10023456 2
  0 00123456 1

●サンプル・プログラム
!□□12345のように数字が並んでいる。□は空白を意味する。
!これらの数字を、次のルールに従って並べ替える。
!(ルール)
! 1.1→2→3→4→5→1→2→ … と数字の順番に数字を、どちらかの空白に移動する。
! 2.1回の操作で動かせる数字は、ひとつだけとする。
!
!このとき、次のように数字を並べ替えるには、最低何回の操作が必要であろうか?
! □□12345 → □□54321


!n=5の場合 PentiumⅢ700MHz,192MB,WindowsMe、2進モードにて
! 13 0054321 4
! 12 0354021 3
! 11 2354001 2
! 10 2354010 1
!  9 2304510 5
!  8 2340510 4
!  7 2043510 3
!  6 0243510 2
!  5 1243500 1
!  4 1243005 5
!  3 1203045 4
!  2 1200345 3
!  1 1002345 2
!  0 0012345 1
!計算時間= 4.45000000000073


LET t0=TIME

LET N=5 !数字 1~N

LET S$="00" !初期 001234…N
FOR i=1 TO N
   LET S$=S$&STR$(i)
NEXT i

LET G$="00" !完成形 00N…4321
FOR i=N TO 1 STEP -1
   LET G$=G$&STR$(i)
NEXT i

DIM M$(100000),L(100000),O(100000) !盤面
LET M$(1)=S$
LET L(1)=0
LET O(1)=1 !移動させる数字
LET CNT=1

LET p=1
DO WHILE p<=CNT !収束したら、終了!

   LET w=O(p) !順番に 1,2,3,4,…,N,1,2,3,4,…
   LET w$=STR$(MOD(w-1,N)+1)

   LET y=0
   FOR z=1 TO 2 !2箇所
      LET T$=M$(p)

      LET x=POS(T$,w$) !移動元位置
      LET y=POS(T$,"0",y+1) !移動先位置
      LET T$(x:x)="0"
      LET T$(y:y)=w$
      !!!PRINT x;y;T$ !debug

      FOR i=1 TO CNT !新規盤面か?
         IF M$(i)=T$ AND O(i)=w+1 THEN EXIT FOR
      NEXT i
      IF i>CNT THEN !登録する
         LET CNT=CNT+1

         LET M$(CNT)=T$ !盤面
         LET L(CNT)=p !元
         LET O(CNT)=w+1 !手数
      END IF

      IF T$=G$ THEN EXIT DO !完成なら、終了!

   NEXT z

   LET p=p+1
LOOP


PRINT p;CNT !debug

CALL PrintOut(CNT)
SUB PrintOut(t)
   DO WHILE t>0 !手を遡る
      PRINT USING "### ":O(t)-1; !盤面
      PRINT M$(t); MOD(O(t)-1,N)+1

      LET t=L(t) !次へ
   LOOP
END SUB

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

END


> 一般に1~nまでの数字では可能か?
> またあればその最短手数は何手かかるのか?

可能だと思います。小生の非力なパソコンでは無理です。
 

Re: (無題)

 投稿者:山中和義  投稿日:2010年 6月27日(日)09時05分56秒
  > No.1267[元記事へ]

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

> I~Lはすべて自然数として
> L^3=I^3+J^3+K^3
> を満たすLを求めるプログラムの組みかたを教えて下さい。
REM 3個の3乗数の和 ※10進モードで実行してください。
FOR I=1 TO 100 !1≦I<J<K≦100
   FOR J=I+1 TO 100
      FOR K=J+1 TO 100
         LET t=I^3+J^3+K^3
         LET L=1
         DO WHILE L^3<t
            LET L=L+1
         LOOP
         IF L^3=t THEN !条件を満たす
            IF GCD3(I,J,K)=1 THEN PRINT L;I;J;K !倍数を除外
         END IF
      NEXT K
   NEXT J
NEXT I
END

EXTERNAL FUNCTION GCD3(a,b,c) !最大公約数(3つの場合)
LET GCD3=GCD(GCD(a,b),c)
END FUNCTION

EXTERNAL FUNCTION GCD(a,b) !最大公約数
DO UNTIL b=0
   LET t=b
   LET b=MOD(a,b)
   LET a=t
LOOP
LET GCD=a
END FUNCTION
 

(無題)

 投稿者:しいメール  投稿日:2010年 6月27日(日)09時40分43秒
  > No.1269[元記事へ]

山中和義さま、お返事ありがとうございます。
実行すると、思っていたとおりのI~Lの組を得ることが出来ました。
プログラムの中に、分からない部分も一部あったりしますが、
これを教材に練習して、理解できるようにしようと思います。
ありがとうございました。
 

Re: (無題)

 投稿者:  投稿日:2010年 6月27日(日)10時21分48秒
  > No.1262[元記事へ]

白石 和夫さんへのお返事です。

> > TextWindowに色を付けたいのですが、出来ますか。
>
> こちらをご覧ください。
> http://hp.vector.co.jp/authors/VA008683/TextColor.htm
> ただし,Windows限定です。

   OPEN # 数値式 : TextWindow1
   OPEN # 数値式 : TextWindow1 ,ACCESS INPUT
   OPEN # 数値式 : TextWindow1 ,ACCESS OUTPUT
   OPEN # 数値式 : TextWindow1 ,ACCESS OUTIN
のTextWindowには、どうすればできますか。
 

Re: (無題)

 投稿者:白石 和夫  投稿日:2010年 6月27日(日)13時55分33秒
  > No.1271[元記事へ]

あさんへのお返事です。

> 白石 和夫さんへのお返事です。
>
> > > TextWindowに色を付けたいのですが、出来ますか。
> >
> > こちらをご覧ください。
> > http://hp.vector.co.jp/authors/VA008683/TextColor.htm
> > ただし,Windows限定です。
>
>    OPEN # 数値式 : TextWindow1
>    OPEN # 数値式 : TextWindow1 ,ACCESS INPUT
>    OPEN # 数値式 : TextWindow1 ,ACCESS OUTPUT
>    OPEN # 数値式 : TextWindow1 ,ACCESS OUTIN
> のTextWindowには、どうすればできますか。

BASICヘルプのWinHandleのページを見てください。
 

空席利用の最短移動手順

 投稿者:GAI  投稿日:2010年 6月27日(日)16時01分15秒
  おかげさまで、次のようなまとめができました。

n=3
手数 状態 数字 2つの空席の
 0 00123  1  左へ
 1 10023  2  左
 2 12003  3  左
 3 12300  1  右
 4 02301  2  右
 5 00321



n=4
手数 状態  数字 2つの空席の
 0 001234  1  左へ
 1 100234  2  左
 2 120034  3  左
 3 120304  4  左
 4 124300  1  右
 5 024301  2  右
 6 004321


n=5
手数 状態     数字 2つの空席の
   0 0012345  1  左へ
   1 1002345  2  左
   2 1200345  3  右
   3 1203045  4  左
   4 1243005  5  左
   5 1243500  1  左
   6 0243510  2  左
   7 2043510  3  左
   8 2340510  4  左
   9 2304510  5  左
  10 2354010  1  右
  11 2354001  2  右
  12 0354021  3  右
  13 0054321


n=6
手数 状態     数字 2つの空席の
   0 00123456  1  左へ
   1 10023456   2  左
   2 12003456  3  右
   3 12030456  4  左
   4 12430056  5  左
   5 12435006  6  右
   6 12435060  1  左
   7 02435160  2  左
   8 20435160  3  左
   9 23405160  4  左
  10 23045160   5  左
  11 23540160  6  右
  12 23540106  1  右
  13 23540016  2  右
  14 03540216  3  左
  15 30540216  4  右
  16 30504216  5  右
  17 30054216  6  右
  18 30654210  1  右
  19 30654201  2  右
  20 30654021  3  右
  21 00654321



n=7
手数 状態      数字 2つの空席の
   0 001234567  1  左へ
   1 100234567 2  左
   2 120034567 3  左
   3 123004567 4  左
   4 123400567 5  左
   5 123450067 6  左
   6 123456007 7  右
   7 123456070 1  左
   8 023456170 2  左
   9 203456170 3  左
  10 230456170 4  左
  11 234056170 5  左
  12 234506170 6  右
  13 234500176 7  右
  14 234507106 1  右
  15 234507016 2  右
  16 034507216 3  左
  17 304507216 4  左
  18 340507216 5  右
  19 340057216 6  右
  20 340657210 7  左
  21 347650210 1  右
  22 347650201 2  右
  23 347650021 3  右
  24 047650321 4  右
  25 007654321



n=8
手数 状態   数字 2つの空席の
  0 0012345678 1 左へ
  1 1002345678 2 左
  2 1200345678 3 左
  3 1230045678 4 右
  4 1230405678 5 左
  5 1235400678 6 左
  6 1235460078 7 右
  7 1235460708 8 右
  8 1235460780 1 左
  9 0235461780 2 左
 10 2035461780 3 左
 11 2305461780 4 右
 12 2305061784 5 右
 13 2300561784 6 右
 14 2306501784 7 左
 15 2376501084 8 右
 16 2376501804 1 右
 17 2376500814 2 右
 18 0376502814 3 左
 19 3076502814 4 左
 20 3476502810 5 左
 21 3476052810 6 左
 22 3470652810 7 左
 23 3407652810 8 左
 24 3487652010 1 右
 25 3487652001 2 右
 26 3487650021 3 右
 27 0487650321 4 右
 28 0087654321



これから、例えばn=12
の場合の最短手順は考察できませんかね?
 

Re: 数の移動

 投稿者:山中和義  投稿日:2010年 6月29日(火)07時17分17秒
  > No.1268[元記事へ]

調査して解ったこと
・最後のN手は決まっている。
・最少手数M(解ったとして)に対して、各数字の移動回数が決まる。
 j回とする。j回で後半分の数字(N=5なら、4,5)を揃える。
 続いて、前半分の数字(N=5なら、1,2,3)を揃える。
  例 N=5の場合
    0: 0012345
     ↓j*N 回      最後N手は決まる j*N-(M-INT((N+1)/2))手から
  j*N: xx54xxx        ↑
     ↓INT((N+1)/2) 回   │
    M: 0054321 ───────┘
 予想式 M=j*N + INT((N+1)/2) !?
   N  M  j INT((N+1)/2)
   2  3  1 1
   3  5  1 2
   4  6  1 2
   5  13 2 3
   6  21 3 3
   7  25 3 4
   8  28 3 4
   9  41 4 5
   10 55 5 5
   11 61 5 6
   12 78 6 6 !?
・最初のN手をきれいな形で固定できる!?

最初のN手を固定して、必勝パターンがあるかないか?
LET t0=TIME


PUBLIC NUMERIC N !数字1~N
PUBLIC NUMERIC cMAX !見つかった最少手数
PUBLIC NUMERIC B(100) !最初のN手、最後のN手

!LET N=2
!LET cMAX=3
!DATA 2,3 !最初の2手 ※数字を移動させる空白位置。1を2、2を3を意味する。
!DATA 3,4 !最後の2手 ※数字を移動させる空白位置。2を3、1を4を意味する。

!LET N=3
!LET cMAX=5
!DATA 1,2, 3 !最初の3手
!DATA 3, 5,4 !最後の3手

!LET N=4
!LET cMAX=6
!DATA 1,2, 4,3 !最初の4手
!DATA 4,3, 6,5 !最後の4手

!LET N=5
!LET cMAX=13
!DATA 1,2, 4,3, 6 !最初の5手 ※数字を移動させる空白位置。1を2、2を1、3を4、4を3、5を6を意味する。
!DATA 4,3,  7,6,5 !最後の5手 ※数字を移動させる空白位置。4を4、5を3、1を7、2を6、3を5を意味する。

!LET N=6
!LET cMAX=21
!DATA 1,2, 4,3, 6,7 !最初の6手
!DATA 5,4,3,  8,7,6 !最後の6手

!LET N=7
!LET cMAX=25
!DATA 1,2, 4,5,3, 7,8 !最初の7手
!DATA 5,4,3,  9,8,7,6 !最後の7手

!LET N=8
!LET cMAX=28
!DATA 1,2, 4,5,3, 7,8,9 !最初の8手
!DATA 6,5,4,3, 10,9,8,7 !最後の8手

!LET N=9
!LET cMAX=41
!DATA 1,2, 4,5,6,3, 8,9,10 !最初の9手
!DATA 6,5,4,3, 11,10,9,8,7 !最後の9手

!LET N=10
!LET cMAX=55
!DATA 1,2, 4,5,6,3, 8,9,10,11 !最初の10手
!DATA 7,6,5,4,3, 12,11,10,9,8 !最後の10手

LET N=11
LET cMAX=61
DATA 1,2, 4,5,6,7,3, 9,10,11,12 !最初の11手
DATA 7,6,5,4,3, 13,12,11,10,9,8 !最後の11手

!LET N=12
!LET cMAX=78
!DATA 1,2, 4,5,6,7,3, 9,10,11,12,13 !最初の12手
!DATA 8,7,6,5,4,3, 14,13,12,11,10,9 !最後の12手


PRINT "N=";N; "cMAX=";cMAX !debug

MAT B=ZER
FOR i=1 TO N
   READ B(i)
NEXT i
FOR i=cMax-N+1 TO cMax
   READ B(i)
NEXT i
MAT PRINT B; !debug

PUBLIC NUMERIC SPC !空きの数
LET SPC=2

PUBLIC STRING S$ !開始パターン
LET S$=REPEAT$("0",SPC)
FOR i=1 TO N
   LET S$=S$&fnSTR1$(i)
NEXT i
!!!PRINT S$ !debug

PUBLIC STRING G$ !終了パターン
LET G$=REPEAT$("0",SPC)
FOR i=N TO 1 STEP -1
   LET G$=G$&fnSTR1$(i)
NEXT i
!!!PRINT G$ !debug

PUBLIC NUMERIC C !解答数
LET C=0

DIM A(cMAX) !手数

CALL try(0,S$,A)
IF C=0 THEN PRINT "解なし"


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

END


EXTERNAL SUB try(p,M$,A()) !深さ優先探索
IF M$=G$ THEN !完成なら
   LET C=C+1
   PRINT "No.";C

   MAT PRINT A; !debug
   LET T$=S$ !盤面を表示する
   FOR i=0 TO p-1 !手を再現する
      LET w$=fnSTR1$(MOD(i,N)+1) !移動させる数字
      PRINT USING "## ": i; !盤面
      PRINT T$; " ";w$

      LET x=POS(T$,w$) !移動元
      LET y=A(i+1) !移動先
      LET T$(x:x)="0" !move it
      LET T$(y:y)=w$
   NEXT i
   PRINT USING "## ": p; !盤面
   PRINT T$
   PRINT

   LET cMAX=p !最少手数を更新する

ELSE
   IF p+1>cMAX THEN EXIT SUB !高々

   LET w$=fnSTR1$(MOD(p,N)+1) !移動させる数字

   LET y=0
   FOR z=1 TO SPC !2つの空きへ
      LET y=POS(M$,"0",y+1) !移動先
      IF B(p+1)=0 OR y=B(p+1) THEN

         LET x=POS(M$,w$) !移動元
         LET T$=M$ !move it
         LET T$(x:x)="0"
         LET T$(y:y)=w$
         !PRINT p;T$ !debug

         IF N>8 AND p+1=INT((cMAX-2*N)/N)*N THEN !チェックポイント! ※N=9,10,11
            LET v=N-INT((N+1)/2)-2
            IF T$(3:3+v)=G$(5:5+v) THEN
               LET A(p+1)=y !手を記録する
               CALL try(p+1,T$,A) !次へ
            END IF
         ELSEIF N>8 AND p+1=INT((cMAX-N)/N)*N THEN !チェックポイント! ※N=7はNG
            LET v=N-INT((N+1)/2)-1
            IF T$(3:3+v)=G$(4:4+v) THEN
               LET A(p+1)=y !手を記録する
               CALL try(p+1,T$,A) !次へ
            END IF
         ELSE
            LET A(p+1)=y !手を記録する
            CALL try(p+1,T$,A) !次へ
         END IF

      END IF
   NEXT z

END IF
END SUB


!N進法表記

EXTERNAL FUNCTION fnVAL1(x$) !1文字の数字を数値に変換する
LET fnVAL1=POS("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",x$)-1
END FUNCTION

EXTERNAL FUNCTION fnSTR1$(x) !1桁の数値を数字に変換する
LET fnSTR1$=MID$("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",x+1,1)
END FUNCTION
 

根性

 投稿者:GAI  投稿日:2010年 6月29日(火)11時44分14秒
  n=9での最短手順を根性で見つけました。
(コンピュータは使いませんでした。)

手順 状態    数字 2つの空席の
  0 00123456789  1 左へ
  1 10023456789  2 左
  2 12003456789  3 左
  3 12300456789  4 右
  4 12304056789  5 左
  5 12354006789  6 左
  6 12354600789  7 右
  7 12354607089  8 右
  8 12354607809  9 右
  9 12354607890  1 左
 10 02354617890  2 左
 11 20354617890  3 左
 12 23054617890  4 右
 13 23050617894  5 右
 14 23005617894  6 右
 15 23065017894  7 左
 16 23765010894  8 右
 17 23765018094  9 右
 18 23765018904  1 右
 19 23765008914  2 右
 20 03765028914  3 左
 21 30765028914  4 左
 22 34765028910  5 左
 23 34760528910  6 左
 24 34706528910  7 左
 25 34076528910  8 左
 26 34876520910  9 右
 27 34876520019  1 右
 28 34876520109  2 左
 29 34876502109  3 左
 30 04876532109  4 左
 31 40876532109  5 左
 32 45876032109  6 左
 33 45870632109  7 左
 34 45807632109  8 左
 35 45087632109  9 左
 36 45987632100  1 右
 37 45987632001  2 右
 38 45987630021  3 右
 39 45987600321  4 右
 40 05987604321  5 右
 41 00987654321
 

Re: 根性

 投稿者:山中和義  投稿日:2010年 6月29日(火)21時24分17秒
  > No.1275[元記事へ]

GAIさんへのお返事です。

N=12の予想
 0: 00123456789ABC

12: 1273456089ABC0 最初N手

24: ?

36: ?

48: xxA9876xxxxxxx (j-2)*N手 ←チェックポイント

60: xxBA9876xxxxxx (j-1)*N手 ←チェックポイント

66: xxxxxxx0xxxxxx
67: xxxxxx07xxxxxx 最後N手
68: xxxxx08-xxxxxx
69: xxxx09--xxxxxx
70: xxx0A---xxxxxx
71: xx0B----xxxxxx

72: xxCBA987xxxxx0 j*N手

73: xx------xxxx01  ↓ INT((N+1)/2) 回
74: xx------xxx02-
75: xx------xx03--
76: xx------x04---
77: xx------05----

78: 00CBA987654321

前出のプログラム(訂正済み)で、確認できると思いますが、、、計算時間は不明です。
 

計算依頼

 投稿者:GAI  投稿日:2010年 6月30日(水)06時11分41秒
  > No.1276[元記事へ]

> N=12の予想
> <PRE>
>  0: 00123456789ABC
>
> 12: 1273456089ABC0 最初N手
>
> 24: ?
>
> 36: ?
>
> 48: xxA9876xxxxxxx (j-2)*N手 ←チェックポイント
>
> 60: xxBA9876xxxxxx (j-1)*N手 ←チェックポイント
>
> 66: xxxxxxx0xxxxxx
> 67: xxxxxx07xxxxxx 最後N手
> 68: xxxxx08-xxxxxx
> 69: xxxx09--xxxxxx
> 70: xxx0A---xxxxxx
> 71: xx0B----xxxxxx
>
> 72: xxCBA987xxxxx0 j*N手
>
> 73: xx------xxxx01  ↓ INT((N+1)/2) 回
> 74: xx------xxx02-
> 75: xx------xx03--
> 76: xx------x04---
> 77: xx------05----
>
> 78: 00CBA987654321
> </PRE>
>
> 前出のプログラム(訂正済み)で、確認できると思いますが、、、計算時間は不明です。




自分のコンピュータでn=12
を走らせようとしましたが、メモリが足りませんのコメントがでてしまいます。
どなたか、高性能のコンピュータをお持ちの方で、このn=12
での結果を知らせてくれませんか?
 

Re: 計算依頼

 投稿者:山中和義  投稿日:2010年 6月30日(水)07時59分57秒
  > No.1277[元記事へ]

GAIさんへのお返事です。

> N=12の予想

N=12は66手となりました。
 0: 00123456789ABC

12: 1273456089ABC0 最初N手

24: ?

36: xxA9876xxxxxxx (j-2)*N手 ←チェックポイント

48: xxBA9876xxxxxx (j-1)*N手 ←チェックポイント

54: xxxxxxx0xxxxxx
55: xxxxxx07xxxxxx 最後N手
56: xxxxx08-xxxxxx
57: xxxx09--xxxxxx
58: xxx0A---xxxxxx
59: xx0B----xxxxxx

60: xxCBA987xxxxx0 j*N手

61: xx------xxxx01  ↓ INT((N+1)/2) 回
62: xx------xxx02-
63: xx------xx03--
64: xx------x04---
65: xx------05----

66: 00CBA987654321

これまでの結果から、上記のパターンで解が見つかるようです。
Nに応じてチェックポイントを増設することで枝刈り(深さ優先探索のこのプログラム)が可能のようです。
 

Re: 計算依頼

 投稿者:GAI  投稿日:2010年 7月 1日(木)05時48分11秒
  > No.1278[元記事へ]

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

> N=12の予想
>
> N=12は66手となりました。



ほう66手ですか。
途中経過の変化を全部見せてくれませんか?
 

Re: 計算依頼

 投稿者:山中和義  投稿日:2010年 7月 1日(木)06時53分3秒
  > No.1279[元記事へ]

GAIさんへのお返事です。

> 途中経過の変化を全部見せてくれませんか?

Nの倍数でチェックポイントを設けて枝刈りする。そのパターンを模索中、、、

12: 1273456089ABC0
24: 2387xx0xxxxx0x
36: 34A98765xxxxxx
48: 45BA9876xxxxxx
60: 56CBA987xxxxx0
+6手

いくつか求まるが、その1つ
 0 00123456789ABC 1
 1 10023456789ABC 2
 2 12003456789ABC 3
 3 12030456789ABC 4
 4 12034056789ABC 5
 5 12034506789ABC 6
 6 12034560789ABC 7
 7 12734560089ABC 8
 8 12734560809ABC 9
 9 12734560890ABC A
10 1273456089A0BC B
11 1273456089AB0C C
12 1273456089ABC0 1
13 0273456089ABC1 2
14 2073456089ABC1 3
15 2370456089ABC1 4
16 2370056489ABC1 5
17 2370506489ABC1 6
18 2370560489ABC1 7
19 2307560489ABC1 8
20 2387560409ABC1 9
21 2387560490ABC1 A
22 238756049A0BC1 B
23 238756049AB0C1 C
24 238756049ABC01 1
25 238756049ABC10 2
26 038756049ABC12 3
27 308756049ABC12 4
28 348756009ABC12 5
29 348706059ABC12 6
30 348700659ABC12 7
31 348007659ABC12 8
32 340087659ABC12 9
33 340987650ABC12 A
34 34A9876500BC12 B
35 34A98765B00C12 C
36 34A98765BC0012 1
37 34A98765BC0102 2
38 34A98765BC2100 3
39 04A98765BC2130 4
40 40A98765BC2130 5
41 45A98760BC2130 6
42 45A98706BC2130 7
43 45A98076BC2130 8
44 45A90876BC2130 9
45 45A09876BC2130 A
46 450A9876BC2130 B
47 45BA98760C2130 C
48 45BA987600213C 1
49 45BA987610203C 2
50 45BA987610023C 3
51 45BA987610320C 4
52 05BA987614320C 5
53 50BA987614320C 6
54 56BA987014320C 7
55 56BA980714320C 8
56 56BA908714320C 9
57 56BA098714320C A
58 56B0A98714320C B
59 560BA98714320C C
60 56CBA987143200 1
61 56CBA987043201 2
62 56CBA987043021 3
63 56CBA987040321 4
64 56CBA987004321 5
65 06CBA987054321 6
66 00CBA987654321

同様に、N=13の場合

13: 1283456709ABCD0
26: 239xxx8xxxxxx0x
39: 34A9xx0xxxxxxxx
52: 45BA987xxxxxxxx
65: 56CBA987xxxxxxx
78: xxDCBA98xxxxxx0
+7手
 0 00123456789ABCD 1
 1 10023456789ABCD 2
 2 12003456789ABCD 3
 3 12030456789ABCD 4
 4 12034056789ABCD 5
 5 12034506789ABCD 6
 6 12034560789ABCD 7
 7 12034567089ABCD 8
 8 12834567009ABCD 9
 9 12834567090ABCD A
10 1283456709A0BCD B
11 1283456709AB0CD C
12 1283456709ABC0D D
13 1283456709ABCD0 1
14 0283456719ABCD0 2
15 2083456719ABCD0 3
16 2380456719ABCD0 4
17 2384056719ABCD0 5
18 2384506719ABCD0 6
19 2384560719ABCD0 7
20 2384560019ABCD7 8
21 2304568019ABCD7 9
22 2394568010ABCD7 A
23 2394568A100BCD7 B
24 2394568A1B00CD7 C
25 2394568A1BC00D7 D
26 2394568A1BCD007 1
27 2394568A0BCD107 2
28 0394568A2BCD107 3
29 3094568A2BCD107 4
30 3490568A2BCD107 5
31 3490068A2BCD157 6
32 3490608A2BCD157 7
33 3490678A2BCD150 8
34 3490670A2BCD158 9
35 3409670A2BCD158 A
36 34A967002BCD158 B
37 34A9670B20CD158 C
38 34A9670B2C0D158 D
39 34A9670B2CD0158 1
40 34A9670B2CD1058 2
41 34A9670B0CD1258 3
42 04A9670B3CD1258 4
43 40A9670B3CD1258 5
44 45A9670B3CD1208 6
45 45A9070B3CD1268 7
46 45A9007B3CD1268 8
47 45A9087B3CD1260 9
48 45A0987B3CD1260 A
49 450A987B3CD1260 B
50 45BA98703CD1260 C
51 45BA987030D126C D
52 45BA98703D0126C 1
53 45BA98703D1026C 2
54 45BA98703D1206C 3
55 45BA98700D1236C 4
56 05BA98704D1236C 5
57 50BA98704D1236C 6
58 56BA98704D1230C 7
59 56BA98074D1230C 8
60 56BA90874D1230C 9
61 56BA09874D1230C A
62 56B0A9874D1230C B
63 560BA9874D1230C C
64 56CBA9874D12300 D
65 56CBA987401230D 1
66 56CBA987400231D 2
67 56CBA987420031D 3
68 56CBA987420301D 4
69 56CBA987024301D 5
70 06CBA987524301D 6
71 60CBA987524301D 7
72 67CBA980524301D 8
73 67CBA908524301D 9
74 67CBA098524301D A
75 67CB0A98524301D B
76 67C0BA98524301D C
77 670CBA98524301D D
78 67DCBA985243010 1
79 67DCBA985243001 2
80 67DCBA985043021 3
81 67DCBA985040321 4
82 67DCBA985004321 5
83 67DCBA980054321 6
84 07DCBA980654321 7
85 00DCBA987654321
 

Re: 計算依頼

 投稿者:山中和義  投稿日:2010年 7月 1日(木)13時22分48秒
  > No.1280[元記事へ]

攻略法!?
 並びを3つ分ける
 zz|xxxxxxx|yyyyyyy|

 Nによって、x=INT((N+1)/2)とy=N-xとなる。zは2個。

「前から」と「後ろから」で手を決めていく。
・1列目と2列目は、12,23,34,…とする。
 ただし、67のように7(x並びで位置半固定)が重なる場合は0とする。
・3列目は+1ずつになるように、最初のN手で後半分の最小値を持ってくる。
・x並びで、+1ずつになる箇所を可能ならもう1つ以上つくる。
・2*N段以降のx並びで、後半分の降下数字列の三角形をつくる。
・y並びで、後半分N近傍の数字列の三角形をつくる。

N=12の場合

  ↓ ↓ ↓   ↓▽
0: 00|1234567|89ABC
12: 12|8345670|9ABC0
24: 23|9xx680x|ABC0x
36: 34|A9x70x|xxC0xx
48: 45|BA9876|xx0xxx
60 :56|CBA987|xxxxx0
+6手
    ↑△


N=13の場合

    ↓ ↓
0: 00|1234567|89ABCD
13: 12|8345670|9ABCD0 ←最初のN手
26: 23|9xx680x|ABCD0x
39: 34|A9x70xx|xCD0xx
52: 45|BA987x|xxD0xxx
65: 56|CBA987|xx0xxxx
78: 67|DCBA98|xxxxxx0
+7手


N=14の場合

0: 00|1234567|89ABCDE
14: 12|8345670|9ABCDE0
28: 23|9xx680x|ABCDE0x
42: 34|A9x70xx|xxDE0xx
56: 45|BA98xxx|xxE0xxx
70: 56|CBA987x|xx0xxxx
84: 60|DCBA987|xxxxxxx ←
98: xx|EDCBA98|xxxxxx0
+7手
  0 00123456789ABCDE 1
  1 10023456789ABCDE 2
  2 12003456789ABCDE 3
  3 12030456789ABCDE 4
  4 12034056789ABCDE 5
  5 12034506789ABCDE 6
  6 12034560789ABCDE 7
  7 12034567089ABCDE 8
  8 12834567009ABCDE 9
  9 12834567090ABCDE A
 10 1283456709A0BCDE B
 11 1283456709AB0CDE C
 12 1283456709ABC0DE D
 13 1283456709ABCD0E E
 14 1283456709ABCDE0 1
 15 0283456719ABCDE0 2
 16 2083456719ABCDE0 3
 17 2380456719ABCDE0 4
 18 2384056719ABCDE0 5
 19 2384506719ABCDE0 6
 20 2384560719ABCDE0 7
 21 2384560019ABCDE7 8
 22 2304568019ABCDE7 9
 23 2394568010ABCDE7 A
 24 239456801A0BCDE7 B
 25 239456801AB0CDE7 C
 26 239456801ABC0DE7 D
 27 239456801ABCD0E7 E
 28 239456801ABCDE07 1
 29 239456810ABCDE07 2
 30 039456812ABCDE07 3
 31 309456812ABCDE07 4
 32 349056812ABCDE07 5
 33 349006812ABCDE57 6
 34 349060812ABCDE57 7
 35 349067812ABCDE50 8
 36 349067012ABCDE58 9
 37 340967012ABCDE58 A
 38 34A9670120BCDE58 B
 39 34A967012B0CDE58 C
 40 34A967012BC0DE58 D
 41 34A967012BCD0E58 E
 42 34A967012BCDE058 1
 43 34A967102BCDE058 2
 44 34A967100BCDE258 3
 45 04A967103BCDE258 4
 46 40A967103BCDE258 5
 47 45A967103BCDE208 6
 48 45A907163BCDE208 7
 49 45A900163BCDE278 8
 50 45A908163BCDE270 9
 51 45A098163BCDE270 A
 52 450A98163BCDE270 B
 53 45BA981630CDE270 C
 54 45BA9816300DE27C D
 55 45BA98163D00E27C E
 56 45BA98163D0E027C 1
 57 45BA98063D0E127C 2
 58 45BA98063D2E107C 3
 59 45BA98060D2E137C 4
 60 05BA98064D2E137C 5
 61 50BA98064D2E137C 6
 62 56BA98004D2E137C 7
 63 56BA98074D2E130C 8
 64 56BA90874D2E130C 9
 65 56BA09874D2E130C A
 66 56B0A9874D2E130C B
 67 560BA9874D2E130C C
 68 56CBA9874D2E1300 D
 69 56CBA987402E130D E
 70 56CBA987402013ED 1
 71 56CBA987412003ED 2
 72 56CBA987410023ED 3
 73 56CBA987410320ED 4
 74 56CBA987014320ED 5
 75 06CBA987014325ED 6
 76 60CBA987014325ED 7
 77 60CBA980714325ED 8
 78 60CBA908714325ED 9
 79 60CBA098714325ED A
 80 60CB0A98714325ED B
 81 60C0BA98714325ED C
 82 600CBA98714325ED D
 83 60DCBA98714325E0 E
 84 60DCBA987143250E 1
 85 60DCBA987043251E 2
 86 62DCBA987043051E 3
 87 62DCBA987040351E 4
 88 62DCBA987004351E 5
 89 62DCBA987054301E 6
 90 02DCBA987654301E 7
 91 72DCBA980654301E 8
 92 72DCBA908654301E 9
 93 72DCBA098654301E A
 94 72DCB0A98654301E B
 95 72DC0BA98654301E C
 96 72D0CBA98654301E D
 97 720DCBA98654301E E
 98 72EDCBA986543010 1
 99 72EDCBA986543001 2
100 70EDCBA986543021 3
101 70EDCBA986540321 4
102 70EDCBA986504321 5
103 70EDCBA986054321 6
104 70EDCBA980654321 7
105 00EDCBA987654321


N=15の場合

  0: 00|12345678|9ABCDEF
15: 12|93456780|ABCDEF0
30: 23|Axxx780x|BCDEF0x
45: 34|BAxx80xx|xxEF0xx
60: 45|CBA90xx|xxxF0xxx
75: 56|DCBA98x|xxx0xxxx
90: 67|EDCBA98|xxxxxxxx
105: 78|FEDCBA9|xxxxxxx0
+8手
  0 00123456789ABCDEF 1
  1 10023456789ABCDEF 2
  2 12003456789ABCDEF 3
  3 12030456789ABCDEF 4
  4 12034056789ABCDEF 5
  5 12034506789ABCDEF 6
  6 12034560789ABCDEF 7
  7 12034567089ABCDEF 8
  8 12034567809ABCDEF 9
  9 12934567800ABCDEF A
 10 1293456780A0BCDEF B
 11 1293456780AB0CDEF C
 12 1293456780ABC0DEF D
 13 1293456780ABCD0EF E
 14 1293456780ABCDE0F F
 15 1293456780ABCDEF0 1
 16 0293456781ABCDEF0 2
 17 2093456781ABCDEF0 3
 18 2390456781ABCDEF0 4
 19 2390056781ABCDEF4 5
 20 2390506781ABCDEF4 6
 21 2390560781ABCDEF4 7
 22 2390567081ABCDEF4 8
 23 2390567801ABCDEF4 9
 24 2309567801ABCDEF4 A
 25 23A95678010BCDEF4 B
 26 23A9567801B0CDEF4 C
 27 23A9567801BC0DEF4 D
 28 23A9567801BCD0EF4 E
 29 23A9567801BCDE0F4 F
 30 23A9567801BCDEF04 1
 31 23A9567810BCDEF04 2
 32 03A9567812BCDEF04 3
 33 30A9567812BCDEF04 4
 34 34A9567812BCDEF00 5
 35 34A9067812BCDEF50 6
 36 34A9007812BCDEF56 7
 37 34A9070812BCDEF56 8
 38 34A9078012BCDEF56 9
 39 34A0978012BCDEF56 A
 40 340A978012BCDEF56 B
 41 34BA9780120CDEF56 C
 42 34BA978012C0DEF56 D
 43 34BA978012CD0EF56 E
 44 34BA978012CDE0F56 F
 45 34BA978012CDEF056 1
 46 34BA978002CDEF156 2
 47 34BA978020CDEF156 3
 48 04BA978023CDEF156 4
 49 40BA978023CDEF156 5
 50 45BA978023CDEF106 6
 51 45BA978023CDEF160 7
 52 45BA908723CDEF160 8
 53 45BA900723CDEF168 9
 54 45BA090723CDEF168 A
 55 45B0A90723CDEF168 B
 56 450BA90723CDEF168 C
 57 45CBA907230DEF168 D
 58 45CBA90723D0EF168 E
 59 45CBA90723DE0F168 F
 60 45CBA90723DEF0168 1
 61 45CBA90723DEF1068 2
 62 45CBA90703DEF1268 3
 63 45CBA90730DEF1268 4
 64 05CBA90734DEF1268 5
 65 50CBA90734DEF1268 6
 66 56CBA90734DEF1208 7
 67 56CBA90034DEF1278 8
 68 56CBA90834DEF1270 9
 69 56CBA09834DEF1270 A
 70 56CB0A9834DEF1270 B
 71 56C0BA9834DEF1270 C
 72 560CBA9834DEF1270 D
 73 56DCBA98340EF1270 E
 74 56DCBA983400F127E F
 75 56DCBA9834F00127E 1
 76 56DCBA9834F10027E 2
 77 56DCBA9834F10207E 3
 78 56DCBA9804F13207E 4
 79 56DCBA9800F13247E 5
 80 06DCBA9805F13247E 6
 81 60DCBA9805F13247E 7
 82 67DCBA9805F13240E 8
 83 67DCBA9085F13240E 9
 84 67DCBA0985F13240E A
 85 67DCB0A985F13240E B
 86 67DC0BA985F13240E C
 87 67D0CBA985F13240E D
 88 670DCBA985F13240E E
 89 67EDCBA985F132400 F
 90 67EDCBA985013240F 1
 91 67EDCBA985003241F 2
 92 67EDCBA985203041F 3
 93 67EDCBA985200341F 4
 94 67EDCBA985204301F 5
 95 67EDCBA980254301F 6
 96 07EDCBA986254301F 7
 97 70EDCBA986254301F 8
 98 78EDCBA906254301F 9
 99 78EDCBA096254301F A
100 78EDCB0A96254301F B
101 78EDC0BA96254301F C
102 78ED0CBA96254301F D
103 78E0DCBA96254301F E
104 780EDCBA96254301F F
105 78FEDCBA962543010 1
106 78FEDCBA962543001 2
107 78FEDCBA960543021 3
108 78FEDCBA960540321 4
109 78FEDCBA960504321 5
110 78FEDCBA960054321 6
111 78FEDCBA900654321 7
112 08FEDCBA907654321 8
113 00FEDCBA987654321
 

Re: 計算依頼

 投稿者:GAI  投稿日:2010年 7月 2日(金)07時28分4秒
  > No.1281[元記事へ]

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

> 攻略法!?
>  並びを3つ分ける
>  zz|xxxxxxx|yyyyyyy|
>
>  Nによって、x=INT((N+1)/2)とy=N-xとなる。zは2個。
>
> 「前から」と「後ろから」で手を決めていく。
> ・1列目と2列目は、12,23,34,…とする。
>  ただし、67のように7(x並びで位置半固定)が重なる場合は0とする。
> ・3列目は+1ずつになるように、最初のN手で後半分の最小値を持ってくる。
> ・x並びで、+1ずつになる箇所を可能ならもう1つ以上つくる。
> ・2*N段以降のx並びで、後半分の降下数字列の三角形をつくる。
> ・y並びで、後半分N近傍の数字列の三角形をつくる。
> N=15の場合
>
>   0: 00|12345678|9ABCDEF
>  15: 12|93456780|ABCDEF0
>  30: 23|Axxx780x|BCDEF0x
>  45: 34|BAxx80xx|xxEF0xx
>  60: 45|CBA90xx|xxxF0xxx
>  75: 56|DCBA98x|xxx0xxxx
>  90: 67|EDCBA98|xxxxxxxx
> 105: 78|FEDCBA9|xxxxxxx0
> +8手

全組合せを調査していたら天文学的に増大する時間数であろうn=15
の最短手数をまあなんと効率よく調査できるものだと感心します。

最短手数が一定にはなく、そこがこの一般化での面白いところですね。
 

障害報告(翻訳時)

 投稿者:山中和義  投稿日:2010年 7月 2日(金)10時08分18秒
  次のような文法エラー(END IFがない)のプログラムを実行すると、
2進モードのみ内部エラーが発生します。
FOR i=1 TO 5
   IF i=2 THEN
      PRINT
NEXT
END
 

Re: 障害報告(翻訳時)

 投稿者:白石 和夫  投稿日:2010年 7月 2日(金)14時19分50秒
  > No.1283[元記事へ]

ご報告ありがとうございました。
修正します。
 

Re: 数の移動(現状のまとめ)

 投稿者:山中和義  投稿日:2010年 7月 2日(金)18時54分33秒
  > No.1274[元記事へ]

●Nによって、一般に

最少手数 M の計算
・Nが奇数なら、M=(N^2+1)/2
・Nが偶数なら、N=4*k型 M=(N-1)*N/2。N=4*k+2型 M=N*(N+1)/2

並びの流れ
 INT(M/N) 巡 + MOD(M,N) 手

 N=16の場合、M=120
    0: 00|123456789ABCDEFG
 1巡 16: 1z|xxxxxxxxxxxxxxx0 ※先頭の1は、対称性で固定とする。最後の0はGを最後に移動させるため。
 2巡 32: zz|xxxxxxxxxxxxxxxx
 3巡 48: zz|xxxxxxxxxxxxxxxx
 4巡 64: zz|xxxxxxxxxxxxxxxx
 5巡 80: zz|xxxxxxxxxxxxxxxx
 6巡 96: zz|xxxxxxxxxxxxxxxx
        :
   104: zz|xxxxxxx0|xxxxxxxx 9
              ────┐
   105: zz|xxxxxx09|yyyyyyyy A  │ ※y並びの個数は、MOD(M,N) 個
   106: zz|xxxxx0A-|yyyyyyyy B  │
   107: zz|xxxx0B--|yyyyyyyy C  │
   108: zz|xxx0C---|yyyyyyyy D  │
   109: zz|xx0D----|yyyyyyyy E  │
   110: zz|x0E-----|yyyyyyyy F  │
   111: zz|0F------|yyyyyyyy G  │
 7巡112: zz|GFEDCBA9|yyyyyyy0 1  │最後のN手
 +8手               │
   113: zz|--------|yyyyyyy1 2  │
   114: zz|--------|yyyyyy2- 3  │
   115: zz|--------|yyyyy3-- 4  │
   116: zz|--------|yyyy4--- 5  │
   117: zz|--------|yyy5---- 6  │
   118: zz|--------|yy6----- 7  │
   119: zz|--------|y7------ 8  │
   120: 00|--------|8-------   │
              ────┘


●具体的なパターンがあるのか?

そこで深さ優先探索のプログラムで枝刈り(チェックポイント)を行って調べてみた。
O(2^M)なので、N=17は未確認、、、
LET t0=TIME


PUBLIC NUMERIC N !数字1~N

!LET N=2
!!! 0: 0012
!DATA "1020" !2 1通り

!LET N=3
!!! 0: 00123
!DATA "12300" !3 1通り

!LET N=4
!!! 0: 001234
!DATA "124300" !4 1通り

!LET N=5
!!! 0: 0012345
!DATA "1243050" !5
!DATA "2354100" !10 2通り

!LET N=6
!!! 0: 00123456
!DATA "12430560" !6
!DATA "2354xx0x" !12
!DATA "30654xx0" !18 21通り

!LET N=7
!!! 0: 001234567
!DATA "125340670" !7
!DATA "23650xx0x" !14
!DATA "34765xxx0" !21 37通り

!LET N=8
!!! 0: 0012345678
!DATA "1263450780" !8
!DATA "237650xx0x" !16
!DATA "34876xxxx0" !24 37通り

!LET N=9
!!! 0: 00123456789
!DATA "12634507890" !9
!DATA "237650x890x" !18
!DATA "348765xx0xx" !27
!DATA "459876xxxx0" !36 4082通り

!LET N=10
!!! 0: 00123456789A
!DATA "1263450789A0" !10
!DATA "237650x89A0x" !20
!DATA "348765xxA0xx" !30
!DATA "4098765x0xxx" !40
!DATA "54A9876xxxx0" !50

!LET N=11
!!! 0: 00123456789AB
!DATA "1273456089AB0" !11
!DATA "2387x60x9AB0x" !22
!DATA "349870xxxB0xx" !33
!DATA "45A9876xx0xxx" !44
!DATA "56BA987xxxxx0" !55

!LET N=12
!!! 0: 00123456789ABC
!DATA "1283456709ABC0" !12
!DATA "2398x670xABC0x" !24
!DATA "34A9870xxxC0xx" !36
!DATA "45BA9876xx0xxx" !48
!DATA "56CBA987xxxxx0" !60

!LET N=13
!!! 0: 00123456789ABCD
!DATA "1283456709ABCD0" !13
!DATA "2398x670xABCD0x" !26
!DATA "34A9870xxxCD0xx" !39
!DATA "45BA987xxxD0xxx" !52
!DATA "56CBA987xx0xxxx" !65
!DATA "67DCBA98xxxxxx0" !78

!LET N=14
!!! 0: 00123456789ABCDE
!DATA "1283456709ABCDE0" !14
!DATA "2398x670xABCDE0x" !28
!DATA "34A9870xxxxDE0xx" !42
!DATA "45BA98xxxxxE0xxx" !56
!DATA "56CBA987xxx0xxxx" !70
!DATA "60DCBA987xxxxxxx" !84
!DATA "76EDCBA98xxxxxx0" !98

LET N=15
!! 0: 00123456789ABCDEF
DATA "1293456780ABCDEF0" !15
DATA "23A9x6780xBCDEF0x" !30
DATA "34BA9x80xxxDEF0xx" !45
DATA "45CBA90xxxxEF0xxx" !60
DATA "56DCBA98xxxF0xxxx" !75
DATA "67EDCBA98xx0xxxxx" !90
DATA "78FEDCBA9xxxxxxx0" !105

!LET N=16
!!! 0: 00123456789ABCDEFG
!DATA "12A34567890BCDEFG0" !16
!DATA "23BAx67890xCDEFG0x" !32
!DATA "34CBAx890xxxEFG0xx" !48
!DATA "45DCBA90xxxxFG0xxx" !64
!DATA "56EDCBA98xxxG0xxxx" !80
!DATA "67FEDCBA98xx0xxxxx" !96
!DATA "78GFEDCBA9xxxxxxx0" !112

!LET N=17
!!! 0: 00123456789ABCDEFGH
!DATA "12A34567890BCDEFGH0" !17
!DATA "23BAx67890xCDEFGH0x" !34
!DATA "34CBAx890xxxEFGH0xx" !51
!DATA "45DCBA90xxxxFGH0xxx" !68
!DATA "56EDCBA9xxxxGH0xxxx" !85
!DATA "67FEDCBA9xxxH0xxxxx" !102
!DATA "78GFEDCBA9xx0xxxxxx" !119
!DATA "89HGFEDCBAxxxxxxxx0" !136


PUBLIC NUMERIC M !最少手数
IF MOD(N,2)=1 THEN !奇数なら
   LET M=(N^2+1)/2
ELSE
   IF MOD(N,4)=0 THEN !偶数 N=4*k
      LET M=(N-1)*N/2
   ELSE !偶数 N=4*k+2
      LET M=N*(N+1)/2
   END IF
END IF

LET ITER=INT(M/N) !j*N ※チェックパターンの数
PRINT "N=";N; "M=";M; "ITER=";ITER !debug

PUBLIC STRING PTN$(500) !チェックパターン
FOR i=1 TO 50
   LET PTN$(i)=""
NEXT i
FOR i=1 TO ITER
   READ PTN$(i*N)
NEXT i

PUBLIC NUMERIC SPC !空きの数
LET SPC=2

PUBLIC STRING S$ !開始パターン
LET S$=REPEAT$("0",SPC)
FOR i=1 TO N
   LET S$=S$&fnSTR1$(i)
NEXT i
!!!PRINT S$ !debug

PUBLIC STRING G$ !終了パターン
LET G$=REPEAT$("0",SPC)
FOR i=N TO 1 STEP -1
   LET G$=G$&fnSTR1$(i)
NEXT i
!!!PRINT G$ !debug

PUBLIC NUMERIC C !解答数
LET C=0

DIM R$(0 TO M) !手の記録
LET R$(0)=S$


LET T$=S$ !1手 ※対称性
LET T$(1:1)=fnSTR1$(1) !10…
LET T$(3:3)="0"
LET R$(1)=T$
LET p=1
IF N>2 THEN !最初のN手 ※1巡目は固定となる
   LET T$(2:2)=fnSTR1$(2) !x2…
   LET T$(4:4)="0"
   LET R$(2)=T$

   FOR i=3 TO N-ITER !xx03456780…
      LET T$(i+1:i+1)=fnSTR1$(i)
      LET T$(i+2:i+2)="0"
      LET R$(i)=T$
   NEXT i

   LET i=N-ITER+1 !xx9xxxxxx0…
   LET T$(3:3)=fnSTR1$(i)
   LET T$(i+2:i+2)="0"
   LET R$(i)=T$

   FOR i=N-ITER+2 TO N !…ABCDEF0
      LET T$(i+1:i+1)=fnSTR1$(i)
      LET T$(i+2:i+2)="0"
      LET R$(i)=T$
   NEXT i
   LET p=N

   !FOR i=1 TO N !debug
   !   PRINT R$(i);i
   !NEXT i
END IF
CALL try(p,T$,R$)
IF C=0 THEN PRINT "解なし"


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

END


EXTERNAL SUB try(p,B$,R$()) !深さ優先探索
IF B$=G$ THEN !完成なら
   LET C=C+1
   PRINT "No.";C

   FOR i=0 TO p-1 !盤面を表示する
      PRINT USING "### ": i;
      PRINT R$(i); " ";fnSTR1$(MOD(i,N)+1)
   NEXT i
   PRINT USING "### ": p;
   PRINT R$(p)
   PRINT

   STOP !!!※1つのみ ←←←←←

ELSE
   IF p+1>M THEN EXIT SUB !高々

   LET w$=fnSTR1$(MOD(p,N)+1) !移動させる数字

   LET y=0
   FOR z=1 TO SPC !2つの空きへ
      LET x=POS(B$,w$) !移動元
      LET y=POS(B$,"0",y+1) !移動先
      LET T$=B$ !move it
      LET T$(x:x)="0"
      LET T$(y:y)=w$
      !PRINT p;T$ !debug

      IF PTN$(p+1)<>"" THEN !チェックポイント!
         FOR i=1 TO N+2
            LET ww$=PTN$(p+1)(i:i)
            IF ww$<>"x" AND T$(i:i)<>ww$ THEN EXIT FOR !不一致なら
         NEXT i
         IF i>N+2 THEN !OK!
         !!!PRINT T$ !debug
            LET R$(p+1)=T$ !手を記録する
            CALL try(p+1,T$,R$) !次へ
         END IF
      ELSE
         LET R$(p+1)=T$ !手を記録する
         CALL try(p+1,T$,R$) !次へ
      END IF
   NEXT z

END IF
END SUB


!N進法表記

EXTERNAL FUNCTION fnVAL1(x$) !1文字の数字を数値に変換する
LET fnVAL1=POS("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",x$)-1
END FUNCTION

EXTERNAL FUNCTION fnSTR1$(x) !1桁の数値を数字に変換する
LET fnSTR1$=MID$("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",x+1,1)
END FUNCTION

「巡」の箇所でのチェックポイント

 N=16、M=120
     0: 00|12345678|9ABCDEFG
 1巡 16: 12|A3456789|0BCDEFG0
 2巡 32: 23|BAx67890|xCDEFG0x
 3巡 48: 34|CBAx890x|xxEFG0xx
 4巡 64: 45|DCBA90xx|xxFG0xxx
 5巡 80: 56|EDCBA98x|xxG0xxxx
 6巡 96: 67|FEDCBA98|xx0xxxxx
 7巡112: 78|GFEDCBA9|xxxxxxx0
 +8手

 並びを、zz|xxxxx|yyyyy と分割する
・z並びは、12,23,34,45,…とする。ただし、N=10,14のようにx並びと重複する場合は、x0とする。
・x並びは、高々1つずつ降順列A,BA,CBA,DCBA,…ができるので、巡ごとに1つずつ増やしていく。
 また、+1ずつ増加する列(「5」列)があれば、それをつくる。
・右斜めのラインで、0位置を確定させる。
 

Re: 数の移動(現状のまとめ)への質問

 投稿者:GAI  投稿日:2010年 7月 3日(土)12時02分18秒
  > No.1285[元記事へ]

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

>
> !LET N=2
> !!! 0: 0012
> !DATA "1020" !2 1通り
>
> !LET N=3
> !!! 0: 00123
> !DATA "12300" !3 1通り
>
> !LET N=4
> !!! 0: 001234
> !DATA "124300" !4 1通り
>
> !LET N=5
> !!! 0: 0012345
> !DATA "1243050" !5
> !DATA "2354100" !10 2通り
>
> !LET N=6
> !!! 0: 00123456
> !DATA "12430560" !6
> !DATA "2354xx0x" !12
> !DATA "30654xx0" !18 21通り
>
> !LET N=7
> !!! 0: 001234567
> !DATA "125340670" !7
> !DATA "23650xx0x" !14
> !DATA "34765xxx0" !21 37通り
>
> !LET N=8
> !!! 0: 0012345678
> !DATA "1263450780" !8
> !DATA "237650xx0x" !16
> !DATA "34876xxxx0" !24 37通り
>
> !LET N=9
> !!! 0: 00123456789
> !DATA "12634507890" !9
> !DATA "237650x890x" !18
> !DATA "348765xx0xx" !27
> !DATA "459876xxxx0" !36 4082通り
>

各DATA の最後にある2,21,37,37,4082通りはなんですか?
 

Re: 数の移動(パターンの生成)

 投稿者:山中和義  投稿日:2010年 7月 5日(月)11時34分57秒
  > No.1285[元記事へ]

Nが2から37まで
!必勝パターンの生成

!Nは数字1~Nとする。
!最少手数Mは、Nが奇数なら、M=(N^2+1)/2。
!N=4*k型偶数なら、M=(N-1)*N/2、N=4*k+2型偶数なら、M=N*(N+1)/2となる。
!手順を、INT(M/N)巡 + MOD(M,N)手と簡潔に記述できる。
!
!例. N=9の場合、M=41
!  0 00123456789
!  9 12634507890
! 18 23765018904
! 27 34876120095
! 36 45987631200
! +5手
!
!●パターンの生成
!数字列を、ZZXXXXYYYYに分ける。Z列は2個、Y列はMOD(M,N)個、X列はN-Y個となる。
!X列の最小値をvとする。
!
!(Step1) 巡回列
! Z列を、00,12,23,34,45,56,…とする。
!
!例. N=9の場合、M=41
!  ZZXXXXYYYYY
!  0 00123456789
!  9 12xxxxyyyyy
! 18 23xxxxyyyyy
! 27 34xxxxyyyyy
! 36 45xxxxyyyyy
!
!(Step2) 降順列
! 巡を重ねることでX列を降順に1つずつ揃えて整列させる。
!
!例. N=9の場合、M=41
!  ZZXXXXYYYYY
!  0 00123456789
!  9 126xxxyyyyy
! 18 2376xxyyyyy
! 27 34876xyyyyy
! 36 459876yyyyy
!
!(Step3) 昇順列
! 2つの0の位置を仮定する。
! X列,Y列に、右斜めに並びが昇順になるように、先のX列の降順に重なるまで記入する。
!
!例. N=9の場合、M=41
!  ZZXXXXYYYYY
!  0 00123456789
!  9 ZZX34507890
! 18 ZZXX50y890y
! 27 ZZXXXxyy0yy
! 36 ZZXXXXyyyyy ※大文字は既に数字が確定されている
!
!(Step4) S列
! S列を、(v-1)列に設ける。0,1,2,3,4,…とする。(Z列の数字と連続させる)
! ただし、最終行でS列がX列と重なる場合、Z列の(j)(j+1)部分をj0に置き換える。
! 横のY列に(j-1)(j-2)と2つ記入する。(Y列の大きい数字を左側に揃えるため)
!
!例.N=10、M=55
!      S
!   ZZXXXXXYYYYY
!  0 00123456789A
! 10 12XXXX0YYYY0
! 20 23XXX01YYY0y
! 30 34XX0x2yY0yy
! 40 45XXXX3y0yyy
! 50 50XXXXX43yyy ※大文字は既に数字が確定されている
!
!(Step5) 最終行(最終巡回行)
! 最終行の右端を0とする。
!
!例. N=9の場合、M=41
!     S
!  ZZXXXXYYYYY
!  0 00123456789
!  9 ZZXXX0SYYY0
! 18 ZZXX0XSYY0y
! 27 ZZXXXxSy0yy
! 36 ZZXXXXSyyy0 ※大文字は既に数字が確定されている
!
!以上の操作で、半分~2/3程度は埋まる。完成!!!
!
!例. N=9の場合、M=41
!     S
!  ZZXXXXYYYYY
!  0 00123456789
!  9 12634507890
! 18 2376501890x
! 27 34876x2x0xx
! 36 4598763xxx0

!後は、プログラムまたは筆算で、ナンプレのように
!「行では数字1~Nは1つずつ、0は2つ」と「列では巡回列となる」
!を基準に数字を埋めていけばよい。


LET t0=TIME


PUBLIC NUMERIC N !数字1~N

LET N=37
!                         S
!     ZZXXXXXXXXXXXXXXXXXXYYYYYYYYYYYYYYYYYYY
DATA "0+123456789ABCDEFGHIJKLMNOPQRSTUVWXYZab" !  0 {}
DATA "12K3456789ABCDEFGHIJ+LMNOPQRSTUVWXYZab0" ! 37 {}
DATA "23LK56789ABCDEFGHIJ+1MNOPQRSTUVWXYZab04" ! 74 {}
DATA "34MLK789ABCDEFGHIJ+52NOPQRSTUVWXYZab016" !111 {}
DATA "45NMLK9ABCDEFGHIJ+763OPQRSTUVWXYZab0128" !148 {}
DATA "56ONMLKBCDEFGHIJ+9874PQRSTUVWXYZab0123A" !185 {}
DATA "67PONMLKDEFGHIJ+BA985QRSTUVWXYZab01234C" !222 {}
DATA "78QPONMLKFGHIJ+DCBA96RSTUVWXYZab012345E" !259 {}
DATA "89RQPONMLKHIJ+FEDCBA7STUVWXYZab0123456G" !296 {}
DATA "9ASRQPONMLKJ+HGFEDCB8TUVWXYZab01234567I" !333 {}
DATA "ABTSRQPONMLKJIHGFEDC9+VWXYZab012345678U" !370 {}
DATA "BCUTSRQPONMLKJIHGFEDA9+XYZab012345678WV" !407 {}
DATA "CDVUTSRQPONMLKJIHGFEBA.YZab012.+56789XW" !444 {34}
DATA "DEWVUTSRQPONMLKJIHGFCB.Zab01.3.2+789AYX" !481 {456}
DATA "EFXWVUTSRQPONMLKJIHGDC.ab01..4.32+9ABZY" !518 {5678}
DATA "FGYXWVUTSRQPONMLKJIHED.b01...5.432.+CaZ" !555 {6789AB}
DATA "GHZYXWVUTSRQPONMLKJIFE.0C....6.543.1+ba" !592 {2789ABD}
DATA "HIaZYXWVUTSRQPONMLKJGF.ED....7.654+210b" !629 {389ABC}
DATA "IJbaZYXWVUTSRQPONMLKHG.FE....8.76543210" !666 {9ABCD+}
!     +19手


PUBLIC NUMERIC M !最少手数
IF MOD(N,2)=1 THEN !奇数なら
   LET M=(N^2+1)/2
ELSE
   IF MOD(N,4)=0 THEN !偶数 N=4*k
      LET M=(N-1)*N/2
   ELSE !偶数 N=4*k+2
      LET M=N*(N+1)/2
   END IF
END IF

LET ITER=INT(M/N) !巡回数 j*N ※チェックパターンの数
PRINT "N=";N; "M=";M; "ITER=";ITER !debug

LET v=N-ITER+1 !x並びの最小値
PRINT "X並びの最小値="; fnSTR1$(v)

PUBLIC NUMERIC SPC !空きの数
LET SPC=2

LET Row=ITER+1 !行数
LET Col=N+SPC !列数

DIM P(0 TO Row-1,Col) !パターン表

FOR i=0 TO ITER !パターンを読み込む
   READ t$
   FOR j=1 TO N+SPC
      LET w$=t$(j:j) !符号化
      SELECT CASE w$
      CASE "+" !0
         LET P(i,j)=N+1
      CASE "." !未定
         LET P(i,j)=-1
      CASE ELSE
         LET P(i,j)=fnVAL1(w$)
      END SELECT
   NEXT j
NEXT i
PRINT
PRINT "    ZZ";REPEAT$("X",N-MOD(M,N));REPEAT$("Y",MOD(M,N))
CALL PrintOut(P,Row,Col, 1)


PUBLIC NUMERIC C !解答数
LET C=0

CALL try(1*Col+1,P,Row,Col) !2行目から
IF C=0 THEN PRINT "解なし"


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

END


EXTERNAL SUB try(e,P(,),Row,Col) !バックトラック法で埋めていく
IF e=Row*Col THEN !完成なら
   LET C=C+1 !結果を表示する
   PRINT "No."; C
   CALL PrintOut(P,Row,Col, 0)

   !STOP !!!※1つのみ ←←←←←

ELSE
   LET y=INT((e-1)/Col) !行位置を算出する
   LET x=MOD(e-1,Col)+1 !桁
   IF P(y,x)<0 THEN !未定xの場合

      FOR i=0 TO N+1 !埋める数字を選ぶ
         FOR j=1 TO Col !既に使用されているか確認する
            IF i=P(y,j) THEN EXIT FOR
         NEXT j
         IF j>Col THEN !未使用なら

            LET t=MOD(i,N+1) !列では昇順になる
            IF t=0 OR t>MOD(P(y-1,x),N+1) THEN !1つ上

               IF y=Row-1 AND x>Col-MOD(i,N+1) THEN !最終巡回なら
               ELSE !※最後のMOD(M,N)手より、1~(v-1)の位置は半固定となる

                  LET P(y,x)=i !仮設
                  CALL try(e+1,P,Row,Col) !次へ
                  LET P(y,x)=-1 !元に戻す

               END IF

            END IF

         END IF
      NEXT i

   ELSE !埋め込まれている場合、それをそのまま使う

      LET t=MOD(P(y,x),N+1) !列では昇順になる
      IF t=0 OR t>MOD(P(y-1,x),N+1) THEN !1つ上

         IF y=Row-1 AND x>Col-MOD(i,N+1) THEN !最終巡回なら
         ELSE !※最後のMOD(M,N)手より、1~(v-1)の位置は半固定となる

            CALL try(e+1,P,Row,Col) !次へ

         END IF
      ELSE
         PRINT "設定値に誤りがあります。"; y;x;t
         STOP
      END IF

   END IF
END IF
END SUB

EXTERNAL SUB PrintOut(P(,),Row,Col, FLG) !盤面を表示する
FOR i=0 TO Row-1 !巡
   PRINT USING "#### ": i*N;
   FOR j=1 TO Col
      LET t=P(i,j)
      IF t>=0 THEN
         IF t=N+1 THEN PRINT "+"; ELSE PRINT fnSTR1$(MOD(t,N+1));
      ELSE
         PRINT ".";
      END IF
   NEXT j

   IF FLG=1 THEN
      DIM A(0 TO N+1) !未使用の数字を列挙する
      MAT A=CON !個数
      FOR j=1 TO Col !使用している数字を削除する
         LET t=P(i,j)
         IF P(i,j)>=0 THEN LET A(t)=A(t)-1
      NEXT j
      PRINT " {"; !{…}形式
      FOR j=0 TO N+1
         LET t=A(j)
         IF t>0 THEN
            IF j=N+1 THEN PRINT "+"; ELSE PRINT fnSTR1$(MOD(j,N+1));
         ELSEIF t<0 THEN
            PRINT "プログラムの論理エラーです。"; t;fnSTR1$(MOD(j,N+1))
            STOP
         END IF
      NEXT j
      PRINT "}";
   END IF

   PRINT
NEXT i
PRINT "+";STR$(MOD(M,N));"手"
PRINT
END SUB


!N進法表記

EXTERNAL FUNCTION fnVAL1(x$) !1文字の数字を数値に変換する
LET fnVAL1=POS("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz",x$)-1
END FUNCTION

EXTERNAL FUNCTION fnSTR1$(x) !1桁の数値を数字に変換する
LET fnSTR1$=MID$("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz",x+1,1)
END FUNCTION

実行結果
N= 37 M= 685 ITER= 18
X並びの最小値=K

    ZZXXXXXXXXXXXXXXXXXXYYYYYYYYYYYYYYYYYYY
   0 0+123456789ABCDEFGHIJKLMNOPQRSTUVWXYZab {}
  37 12K3456789ABCDEFGHIJ+LMNOPQRSTUVWXYZab0 {}
  74 23LK56789ABCDEFGHIJ+1MNOPQRSTUVWXYZab04 {}
 111 34MLK789ABCDEFGHIJ+52NOPQRSTUVWXYZab016 {}
 148 45NMLK9ABCDEFGHIJ+763OPQRSTUVWXYZab0128 {}
 185 56ONMLKBCDEFGHIJ+9874PQRSTUVWXYZab0123A {}
 222 67PONMLKDEFGHIJ+BA985QRSTUVWXYZab01234C {}
 259 78QPONMLKFGHIJ+DCBA96RSTUVWXYZab012345E {}
 296 89RQPONMLKHIJ+FEDCBA7STUVWXYZab0123456G {}
 333 9ASRQPONMLKJ+HGFEDCB8TUVWXYZab01234567I {}
 370 ABTSRQPONMLKJIHGFEDC9+VWXYZab012345678U {}
 407 BCUTSRQPONMLKJIHGFEDA9+XYZab012345678WV {}
 444 CDVUTSRQPONMLKJIHGFEBA.YZab012.+56789XW {34}
 481 DEWVUTSRQPONMLKJIHGFCB.Zab01.3.2+789AYX {456}
 518 EFXWVUTSRQPONMLKJIHGDC.ab01..4.32+9ABZY {5678}
 555 FGYXWVUTSRQPONMLKJIHED.b01...5.432.+CaZ {6789AB}
 592 GHZYXWVUTSRQPONMLKJIFE.0C....6.543.1+ba {2789ABD}
 629 HIaZYXWVUTSRQPONMLKJGF.ED....7.654+210b {389ABC}
 666 IJbaZYXWVUTSRQPONMLKHG.FE....8.76543210 {9ABCD+}
+19手

No. 1
   0 0+123456789ABCDEFGHIJKLMNOPQRSTUVWXYZab
  37 12K3456789ABCDEFGHIJ+LMNOPQRSTUVWXYZab0
  74 23LK56789ABCDEFGHIJ+1MNOPQRSTUVWXYZab04
 111 34MLK789ABCDEFGHIJ+52NOPQRSTUVWXYZab016
 148 45NMLK9ABCDEFGHIJ+763OPQRSTUVWXYZab0128
 185 56ONMLKBCDEFGHIJ+9874PQRSTUVWXYZab0123A
 222 67PONMLKDEFGHIJ+BA985QRSTUVWXYZab01234C
 259 78QPONMLKFGHIJ+DCBA96RSTUVWXYZab012345E
 296 89RQPONMLKHIJ+FEDCBA7STUVWXYZab0123456G
 333 9ASRQPONMLKJ+HGFEDCB8TUVWXYZab01234567I
 370 ABTSRQPONMLKJIHGFEDC9+VWXYZab012345678U
 407 BCUTSRQPONMLKJIHGFEDA9+XYZab012345678WV
 444 CDVUTSRQPONMLKJIHGFEBA3YZab0124+56789XW
 481 DEWVUTSRQPONMLKJIHGFCB4Zab015362+789AYX
 518 EFXWVUTSRQPONMLKJIHGDC5ab01764832+9ABZY
 555 FGYXWVUTSRQPONMLKJIHED6b019875A432B+CaZ
 592 GHZYXWVUTSRQPONMLKJIFE70C2A986B543D1+ba
 629 HIaZYXWVUTSRQPONMLKJGF8ED3BA97C654+210b
 666 IJbaZYXWVUTSRQPONMLKHG9FEDCBA8+76543210
+19手

No. 2
   0 0+123456789ABCDEFGHIJKLMNOPQRSTUVWXYZab
  37 12K3456789ABCDEFGHIJ+LMNOPQRSTUVWXYZab0
  74 23LK56789ABCDEFGHIJ+1MNOPQRSTUVWXYZab04
 111 34MLK789ABCDEFGHIJ+52NOPQRSTUVWXYZab016
 148 45NMLK9ABCDEFGHIJ+763OPQRSTUVWXYZab0128
 185 56ONMLKBCDEFGHIJ+9874PQRSTUVWXYZab0123A
 222 67PONMLKDEFGHIJ+BA985QRSTUVWXYZab01234C
 259 78QPONMLKFGHIJ+DCBA96RSTUVWXYZab012345E
 296 89RQPONMLKHIJ+FEDCBA7STUVWXYZab0123456G
 333 9ASRQPONMLKJ+HGFEDCB8TUVWXYZab01234567I
 370 ABTSRQPONMLKJIHGFEDC9+VWXYZab012345678U
 407 BCUTSRQPONMLKJIHGFEDA9+XYZab012345678WV
 444 CDVUTSRQPONMLKJIHGFEBA3YZab0124+56789XW
 481 DEWVUTSRQPONMLKJIHGFCB4Zab015362+789AYX
 518 EFXWVUTSRQPONMLKJIHGDC5ab01764832+9ABZY
 555 FGYXWVUTSRQPONMLKJIHED6b019875A432B+CaZ
 592 GHZYXWVUTSRQPONMLKJIFE70C2A986B543D1+ba
 629 HIaZYXWVUTSRQPONMLKJGF8ED3BA97C654+210b
 666 IJbaZYXWVUTSRQPONMLKHGDFE9CBA8+76543210
+19手

    :略
 

完全席替え

 投稿者:GAI  投稿日:2010年 7月10日(土)16時51分41秒
  男子3人、女子3人がそれぞれ一列ずつで席が決まって並んでいたとする。
男子   女子
 A     a
 B         b
 C         c

これを席替えして、どの人も前の席からの位置が変わり、隣の異性も変わる並び方は

no.1
男子   女子
 B         c
  C         a
  A         b

no.2
男子   女子
 C         b
  A         c
  B         a

の2通りしかない。

そこで、男、女それぞれ4人が一列で並んでいたのを並び替え、
どの人も前の位置と違う場所で、しかも隣の人も違う異性になる
並び方が何通りあるか。
また、この一般化を考えたとき、(男女n人ずつ)
その並びの総数は式でかけるものか?
 

Re: 完全席替え

 投稿者:山中和義  投稿日:2010年 7月11日(日)09時04分48秒
  > No.1288[元記事へ]

GAIさんへのお返事です。
!参考サイト http://www.research.att.com/~njas/sequences/A000186
!n=0,1,2,3, 4,  5,    6,      7,…
!  1,0,0,2,24,552,21280,1073760,…


!かくらん(攪乱)順列(完全順列、乱列)の数、モンモール数(Montmort number)
!参考サイト http://6317.teacup.com/basic/bbs/1201

!●場合の数 d[n]

LET N=4 !n個の並び

LET dn=Derangements(N)
PRINT "場合の数="; dn

DIM B(dn,N) !並びを記録する


!●並びの列挙

DIM A(N)

LET c=0

LET i=0 !順列0~(FACT(N)-1)通りの中から
DO WHILE i<=FACT(N)-1
   CALL Num2PermFactorial(i, A,N) !番号から順列を生成する

   FOR k=1 TO N !変化しない要素を除く
      IF A(k)=k THEN EXIT FOR
   NEXT k
   IF k>N THEN !該当するなら
      LET c=c+1

      !!!MAT PRINT A; !debug
      FOR x=1 TO N !copy it
         LET B(c,x)=A(x)
      NEXT x

      LET i=i+1
   ELSE
      LET i=i+FACT(N-k) !スキップする
   END IF
LOOP

PRINT "場合の数="; c


!●直積で、その組合せを検証する

LET c=0

FOR i=1 TO dn-1 !組合せ、後で2倍する
   FOR j=i+1 TO dn
      FOR x=1 TO N !同じ位置の数字が同じかどうか確認する
         IF B(i,x)=B(j,x) THEN EXIT FOR
      NEXT x
      IF x>N THEN !すべて異なるなら
         LET c=c+1

         !PRINT "No.";c
         !FOR x=1 TO N
         !   PRINT B(i,x);
         !NEXT x
         !PRINT
         !FOR x=1 TO N
         !   PRINT B(j,x);
         !NEXT x
         !PRINT
         !PRINT
      END IF
   NEXT j
NEXT i
PRINT "場合の数="; 2*c


END


EXTERNAL FUNCTION Derangements(n) !かくらん(攪乱)順列(完全順列、乱列)の数
LET t=0
FOR k=0 TO n
   LET t=t+FACT(n)*(-1)^k/FACT(k) !FACT(n)*Σ{(-1)^k/FACT(k)}
NEXT k
LET Derangements=t
END FUNCTION

EXTERNAL SUB Num2PermFactorial(h, A(),N) !番号から順列パターンを生成する ※辞書式順序
LET v=h !非負の10進数整数を階乗進数へ
FOR j=N TO 1 STEP -1 !下の桁から順に
   LET w=N-j+1
   LET t=INT(v/w)
   LET A(j)=v-t*w +1 !階乗進数の各桁の値+1 A[1..N]=(N-1)! … 3! 2! 1! 0!
   LET v=t
NEXT j
FOR j=N-1 TO 1 STEP -1 !順列パターンへ
   FOR k=j+1 TO N
      IF A(k)>=A(j) THEN LET A(k)=A(k)+1
   NEXT k
NEXT j
END SUB
 

Re: 数の移動(パターンの生成)

 投稿者:山中和義  投稿日:2010年 7月13日(火)06時52分4秒
  > No.1287[元記事へ]

ふ~(疲れ)、 ナンプレ(数独)化に成功!?

ここまで詰めると、後は手作業でもすべて埋まります。

現状のプログラムで処理できる最大値です。(進数変換の文字が足りません)
差し替え部分
LET N=61
!                                     S
!     ZZXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY
DATA "0+123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" !   0 {}
DATA "12W3456789ABCDEFGHIJKLMNOPQRSTUV+XYZabcdefghijklmnopqrstuvwxyz0" !  61 {}
DATA "23XW56789ABCDEFGHIJKLMNOPQRSTUV+1YZabcdefghijklmnopqrstuvwxyz04" ! 122 {}
DATA "34YXW789ABCDEFGHIJKLMNOPQRSTUV+52Zabcdefghijklmnopqrstuvwxyz016" ! 183 {}
DATA "45ZYXW9ABCDEFGHIJKLMNOPQRSTUV+763abcdefghijklmnopqrstuvwxyz0128" ! 244 {}
DATA "56aZYXWBCDEFGHIJKLMNOPQRSTUV+9874bcdefghijklmnopqrstuvwxyz0123A" ! 305 {}
DATA "67baZYXWDEFGHIJKLMNOPQRSTUV+BA985cdefghijklmnopqrstuvwxyz01234C" ! 366 {}
DATA "78cbaZYXWFGHIJKLMNOPQRSTUV+DCBA96defghijklmnopqrstuvwxyz012345E" ! 427 {}
DATA "89dcbaZYXWHIJKLMNOPQRSTUV+FEDCBA7efghijklmnopqrstuvwxyz0123456G" ! 488 {}
DATA "9AedcbaZYXWJKLMNOPQRSTUV+HGFEDCB8fghijklmnopqrstuvwxyz01234567I" ! 549 {}
DATA "ABfedcbaZYXWLMNOPQRSTUV+JIHGFEDC9ghijklmnopqrstuvwxyz012345678K" ! 610 {}
DATA "BCgfedcbaZYXWNOPQRSTUV+LKJIHGFEDAhijklmnopqrstuvwxyz0123456789M" ! 671 {}
DATA "CDhgfedcbaZYXWPQRSTUV+NMLKJIHGFEBijklmnopqrstuvwxyz0123456789AO" ! 732 {}
DATA "DEihgfedcbaZYXWRSTUV+PONMLKJIHGFCjklmnopqrstuvwxyz0123456789ABQ" ! 793 {}
DATA "EFjihgfedcbaZYXWTUV+RQPONMLKJIHGDklmnopqrstuvwxyz0123456789ABCS" ! 854 {}
DATA "FGkjihgfedcbaZYXWV+TSRQPONMLKJIHElmnopqrstuvwxyz0123456789ABCDU" ! 915 {}
DATA "GHlkjihgfedcbaZYXWVUTSRQPONMLKJIF+nopqrstuvwxyz0123456789ABCDEm" ! 976 {}
DATA "HImlkjihgfedcbaZYXWVUTSRQPONMLKJGF+pqrstuvwxyz0123456789ABCDEon" !1037 {}
DATA "IJnmlkjihgfedcbaZYXWVUTSRQPONMLKHG4qrstuvwxyz012.+56789ABCDEFpo" !1098 {3}
DATA "JKonmlkjihgfedcbaZYXWVUTSRQPONMLIH6rstuvwxyz01.3.2+789ABCDEFGqp" !1159 {45}
DATA "KLponmlkjihgfedcbaZYXWVUTSRQPONMJI8stuvwxyz01.64.32+9ABCDEFGHrq" !1220 {57}
DATA "LMqponmlkjihgfedcbaZYXWVUTSRQPONKJAtuvwxyz01.875.432+BCDEFGHIsr" !1281 {69}
DATA "MNrqponmlkjihgfedcbaZYXWVUTSRQPOLKCuvwxyz01.A986.5432+DEFGHIJts" !1342 {7B}
DATA "NOsrqponmlkjihgfedcbaZYXWVUTSRQPMLEvwxyz01.CBA97.65432+FGHIJKut" !1403 {8D}
DATA "OPtsrqponmlkjihgfedcbaZYXWVUTSRQNMGwxyz01.EDCBA8.765432+HIJKLvu" !1464 {9F}
DATA "PQutsrqponmlkjihgfedcbaZYXWVUTSRONIxyz01.GFEDCB9.8765432+JKLMwv" !1525 {AH}
DATA "QRvutsrqponmlkjihgfedcbaZYXWVUTSPOKyz01.IHGFEDCA.98765432+LMNxw" !1586 {BJ}
DATA "RSwvutsrqponmlkjihgfedcbaZYXWVUTQPNz01.KJIHGFEDB.A98765432.+Oyx" !1647 {CLM}
DATA "STxwvutsrqponmlkjihgfedcbaZYXWVURQP0N..LKJIHGFEC.BA9876543.1+zy" !1708 {2DMO}
DATA "TUyxwvutsrqponmlkjihgfedcbaZYXWVSRQPO..MLKJIHGFD.CBA987654+210z" !1769 {3EN}
DATA "UVzyxwvutsrqponmlkjihgfedcbaZYXWTSRQP..NMLKJIHGE.DCBA9876543210" !1830 {FO+}
!     +31手
 

Re: 数の移動(パターンの生成)

 投稿者:GAI  投稿日:2010年 7月13日(火)13時13分27秒
  > No.1290[元記事へ]

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

> ふ~(疲れ)、 ナンプレ(数独)化に成功!?
>
> ここまで詰めると、後は手作業でもすべて埋まります。
>
> 現状のプログラムで処理できる最大値です。(進数変換の文字が足りません)
> LET N=61





凄すぎます。
1861手も動かす気が起こりません。

この動きを人間を使って移動させる演技を見せると、ちょっとしたパフォーマンス

ができる。文化祭なんかで実施すると面白いかもしれない。
 

Re: 数の移動(パターンの生成)

 投稿者:山中和義  投稿日:2010年 7月13日(火)14時34分41秒
  > No.1291[元記事へ]

GAIさんへのお返事です。

パターン生成をプログラムして確認していますので、掲載します。
進数変換の文字が十分足りると一般化できます。
!必勝パターンの生成


!Nは数字1~Nとする。
!最少手数Mは、Nが奇数なら、M=(N^2+1)/2。
!N=4*k型偶数なら、M=(N-1)*N/2、N=4*k+2型偶数なら、M=N*(N+1)/2となる。
!手順を、INT(M/N)巡 + MOD(M,N)手と簡潔に記述できる。
!
!例. N=9の場合、M=41
!  0 00123456789
!  9 12634507890
! 18 23765018904
! 27 34876120095
! 36 45987631200
! +5手
!
!●パターンの生成(概要)
!数字列を、ZZXXXXYYYYに分ける。Z並びは2個、Y並びはMOD(M,N)個、X並びはN-Y個となる。
!X並びの最小値をvとする。
!
!(Step1) 巡回列
! Z列を、00,12,23,34,45,56,…とする。
!
!例. N=9の場合、M=41
!  ZZXXXXYYYYY
!  0 00123456789
!  9 12xxxxyyyyy
! 18 23xxxxyyyyy
! 27 34xxxxyyyyy
! 36 45xxxxyyyyy
!
!(Step2) 降順列
! 巡を重ねることでX並びを降順に1つずつ揃えて整列させる。
!
!例. N=9の場合、M=41
!  ZZXXXXYYYYY
!  0 00123456789
!  9 126xxxyyyyy
! 18 2376xxyyyyy
! 27 34876xyyyyy
! 36 459876yyyyy
!
!(Step3) 昇順列
! 2つの0の位置を仮定する。
! X並び,Y並びに、右斜めに並びが昇順になるように、先のX並びの降順に重なるまで記入する。
!
!例. N=9の場合、M=41
!  ZZXXXXYYYYY
!  0 00123456789
!  9 ZZX34507890
! 18 ZZXX50y890y
! 27 ZZXXXxyy0yy
! 36 ZZXXXXyyyyy ※大文字は既に数字が確定されている
!
!(Step4) S並び
! S並びを、(v-1)列に設ける。0,1,2,3,4,…とする。(Z並びの数字と連続させる)
! ただし、最終行でS並びがX並びと重なる場合、Z並びの(j)(j+1)部分を(j)(0)に置き換える。
! 横のY並びに(j-1)(j-2)と2つ記入する。(Y並びの大きい数字を左側に揃えるため)
! N=6,10,14,18,22,…
!
!例.N=10、M=55
!      S
!   ZZXXXXXYYYYY
!  0 00123456789A
! 10 12XXXX0YYYY0
! 20 23XXX01YYY0y
! 30 34XX0x2yY0yy
! 40 45XXXX3y0yyy
! 50 50XXXXX43yyy ※大文字は既に数字が確定されている
!
!(Step5) 最終行(最終巡回行)
! 最終行の右端を0とする。
!
!例. N=9の場合、M=41
!     S
!  ZZXXXXYYYYY
!  0 00123456789
!  9 ZZXXX0SYYY0
! 18 ZZXX0XSYY0y
! 27 ZZXXXxSy0yy
! 36 ZZXXXXSyyy0 ※大文字は既に数字が確定されている
!
!以上の操作で、半分~2/3程度は埋まる。完成!!!
!
!例. N=9の場合、M=41
!     S
!  ZZXXXXYYYYY
!  0 00123456789
!  9 12634507890
! 18 2376501890x
! 27 34876x2x0xx
! 36 4598763xxx0

!後は、プログラムまたは筆算で、ナンプレのように
!「行では数字1~Nは1つずつ、0は2つ」と「列では巡回列となる」
!を基準に数字を埋めていけばよい。


!さらに埋める場合
!・右端1つ前と右端(w並び、W並び)
!・最下行の並びは半固定
!・右下隅の三角領域、四角領域(v並び、V並び)
!
!N= 38 M= 741 ITER= 19
!                         STtUu             wW
!     ZZXXXXXXXXXXXXXXXXXXXYYYYYYYYYYYYYYYYYYY
!   0 0+123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabc {}
!  38 12K3456789ABCDEFGHIJ+LMNOPQRSTUVWXYZabc0 {}
!  76 23LK56789ABCDEFGHIJ+1MNOPQRSTUVWXYZabc04 {}
! 114 34MLK789ABCDEFGHIJ+52NOPQRSTUVWXYZabc016 {}
! 152 45NMLK9ABCDEFGHIJ+763OPQRSTUVWXYZabc0128 {}
! 190 56ONMLKBCDEFGHIJ+9874PQRSTUVWXYZabc0123A {}
! 228 67PONMLKDEFGHIJ+BA985QRSTUVWXYZabc01234C {}
! 266 78QPONMLKFGHIJ+DCBA96RSTUVWXYZabc012345E {}
! 304 89RQPONMLKHIJ+FEDCBA7STUVWXYZabc0123456G {}
! 342 9ASRQPONMLKJ+HGFEDCB8TUVWXYZabc01234567I {}
! 380 ABTSRQPONMLKJIHGFEDC9+VWXYZabc012345678U {}
! 418 BCUTSRQPONMLKJIHGFEDA9+XYZabc012345678WV {}
! 456 CDVUTSRQPONMLKJIHGFEBA3YZabc012+456789XW {}
! 494 DEWVUTSRQPONMLKJIHGFCB5Zabc01.32+6789AYX {4}
! 532 EFXWVUTSRQPONMLKJIHGDC7abc01.5432+89ABZY {6}
! 570 FGYXWVUTSRQPONMLKJIHED9bc01.765432+ABCaZ {8}
! 608 GHZYXWVUTSRQPONMLKJIFECc01.98765432.+Dba {AB}
! 646 HIaZYXWVUTSRQPONMLKJGFE0C..A9876543.1+cb {2BD}
! 684 IJbaZYXWVUTSRQPONMLKHGFED..BA987654+210c {3C}
! 722 J+cbaZYXWVUTSRQPONMLKIHGF..CBA9876543210 {DE}
!                                vvvvvvvvVVVVV
!+19手


LET t0=TIME


PUBLIC NUMERIC N !数字1~N

LET N=37 !←←←←←


PUBLIC NUMERIC M !最少手数
IF MOD(N,2)=1 THEN !奇数なら
   LET M=(N^2+1)/2
ELSE
   IF MOD(N,4)=0 THEN !偶数 N=4*k
      LET M=(N-1)*N/2
   ELSE !偶数 N=4*k+2
      LET M=N*(N+1)/2
   END IF
END IF

LET ITER=INT(M/N) !巡回数 j*N ※チェックパターンの数
PRINT "N=";N; "M=";M; "ITER=";ITER !debug


PUBLIC NUMERIC SPC !空きの数
LET SPC=2

LET Row=ITER+1 !行数
LET Col=N+SPC !列数

DIM P(0 TO Row-1,Col) !パターン表
MAT P=(-1)*CON

!開始パターン 0012345…N
LET P(0,1)=0
LET P(0,2)=N+1
FOR j=1 TO N
   LET P(0,j+SPC)=j
NEXT j


LET v=N-ITER+1 !x並びの最小値
PRINT "X並びの最小値="; fnSTR1$(v)

IF N=2 THEN !Nが2の場合
   LET P(1,1)=1
   LET P(1,2)=0
   LET P(1,3)=2
   LET P(1,4)=3

ELSE !3以上の場合


つづく
 

Re: 数の移動(パターンの生成)

 投稿者:山中和義  投稿日:2010年 7月13日(火)14時37分34秒
  > No.1292[元記事へ]

続き(Nが3以上のパターン生成の本体)
!j巡パターン(z並び、昇順列、降順列)
   FOR i=1 TO ITER
      FOR j=1 TO SPC !z並び (j)(j+1) …
         LET P(i,j)=i+j-1
      NEXT j

      IF i<=INT(ITER/2)+1 THE