三角形の形状の分析

 投稿者：山中和義  投稿日：2012年 1月15日(日)10時22分55秒
  !（三角形の形状の分析）
!自然数M,Nは、M≧Nとする。
!点(x,y)は、領域0≦x≦M、0≦y≦N内の格子点とする。
!(M+1)(N+1)個の格子点から3つを選んでできる点(x,y)の組を頂点とする三角形を分類せよ。


!参考サイト
!　http://oeis.org/A045996


LET M=3 !0≦x≦M
LET N=M !0≦y≦N


LET K=0 !三角形が不成立
LET P=0 !直角をはさむ２辺が軸に平行な直角三角形
LET Q=0 !直角二等辺三角形
LET R=0 !直角三角形
LET S=0 !二等辺三角形
LET T=0 !鈍角三角形

DIM X(0 TO 3-1),Y(0 TO 3-1) !三角形の頂点の座標

LET Z=(N+1)*(M+1) !格子点の個数

PRINT "頂点番号"
FOR i=N TO 0 STEP -1
   FOR j=0 TO M
      PRINT USING "###": (M+1)*i+j;
   NEXT j
   PRINT
NEXT i
PRINT


FOR A=0 TO Z-3 !組合せ C((M+1)(N+1),3)
   LET X(0)=MOD(A,M+1) !座標へ
   LET Y(0)=INT(A/(M+1))
   FOR B=A+1 TO Z-2
      LET X(1)=MOD(B,M+1)
      LET Y(1)=INT(B/(M+1))
      FOR C=B+1 TO Z-1
         LET X(2)=MOD(C,M+1)
         LET Y(2)=INT(C/(M+1))
         !!PRINT A;B;C; "(";X(0);Y(0);") ("; X(1);Y(1);") ("; X(2);Y(2);")" !debug
         PRINT "("; STR$(A);","; STR$(B);","; STR$(C);")= ";


         LET U1=X(0)-X(3-1) !辺c　※辺を反時計まわりに巡回するベクトルを考える
         LET V1=Y(0)-Y(3-1)

         FOR i=0 TO 3-1 !３つの外角と辺に対して

            LET U2=X(MOD(i+1,3))-X(i) !辺b
            LET V2=Y(MOD(i+1,3))-Y(i)


            LET G=U1*V2-U2*V1 !外積 BCsin(∠A) ≠0, ＝0, 符号
            IF G<>0 THEN !三角形が成立するなら
               LET FLG=0

               IF G<0 AND i=0 THEN PRINT "時計まわり　";

               IF U1*U1+V1*V1=U2*U2+V2*V2 THEN !二等辺三角形
                  LET S=S+1
                  PRINT CHR$(ORD("a")+MOD(i+1,3));"=";CHR$(ORD("a")+MOD(i+2,3));"　"; !b=c
                  LET FLG=1
               END IF


               LET F=U1*U2+V1*V2 !内積 BCcos(∠A) ＝0, ＜0, ＞0
               IF F=0 THEN !外角は直角なので、内角も直角
                  LET R=R+1
                  PRINT "∠";CHR$(ORD("A")+i);"=直角";

                  IF FLG=1 THEN LET Q=Q+1 !直角二等辺三角形

                  IF U1*0-1*V1=0 OR U1*1-0*V1=0 THEN !X軸(1,0), Y軸(0,1)との外積
                     LET P=P+1
                     PRINT "　軸に平行";
                  END IF
                  EXIT FOR

               ELSEIF F>0 THEN !外角は鋭角なので、内角は鈍角
                  LET T=T+1
                  PRINT "∠";CHR$(ORD("A")+i);"=鈍角";
                  EXIT FOR

               ELSE
               !次へ

               END IF

            ELSE !不成立
               LET K=K+1
               PRINT "△ABCは不成立";
               EXIT FOR

            END IF


            LET U1=U2 !次へ
            LET V1=V2
         NEXT i
         PRINT

      NEXT C
   NEXT B
NEXT A


LET W=COMB((M+1)*(N+1),3)
PRINT "格子点の選び方は、"; W; "通り"

PRINT "三角形="; P; R; Q; S; T; W-K; K;"個"
PRINT "鋭角三角形="; (W-K)-(R+T)


PRINT m*(m+1)*n*(n+1);"個" !m*(m+1)*n*(n+1)、m=nなら、{n(n+1)}^2


END

 		 

Re: 三角形の形状の分析

 投稿者：山中和義  投稿日：2012年 1月16日(月)10時21分1秒
  > No.1725[元記事へ]

> （三角形の形状の分析）
> 自然数M,Nは、M≧Nとする。
> 点(x,y)は、領域0≦x≦M、0≦y≦N内の格子点とする。
> (M+1)(N+1)個の格子点から3つを選んでできる点(x,y)の組を頂点とする三角形を分類せよ。

鈍角三角形と鋭角三角形の発生比率は？

モンテカルロ法による

LET M=10^8
LET N=M
LET S=0 !発生数
LET T=10^6 !試行回数
FOR i=1 TO T
   LET X0=INT(RND*M) !0≦x＜M　1点目
   LET Y0=INT(RND*N) !0≦y＜N
   DO
      LET X1=INT(RND*M) !0≦x＜M
      LET Y1=INT(RND*N) !0≦y＜N
   LOOP UNTIL NOT( X1=X0 AND Y1=Y0 ) !2点目
   DO
      LET X2=INT(RND*M) !0≦x＜M
      LET Y2=INT(RND*N) !0≦y＜N
   LOOP UNTIL NOT( (X2=X0 AND Y2=Y0) OR (X2=X1 AND Y2=Y1) ) !3点目
   !PRINT X0;Y0; X1;Y1; X2;Y2 !debug

   LET AA=(X2-X1)^2+(Y2-Y1)^2 !辺の長さの２乗
   LET BB=(X0-X2)^2+(Y0-Y2)^2
   LET CC=(X1-X0)^2+(Y1-Y0)^2
   IF BB+CC<AA OR CC+AA<BB OR AA+BB<CC THEN !余弦定理BCcosA=B^2+C^2-A^2より、負なら∠Aは鈍角
      LET S=S+1
   END IF
NEXT i
PRINT S;T; S/T; (T-S)/T
PRINT S/(T-S); ":"; 1
END


実行結果
725656  1000000  .725656  .274344
2.64505875834718 : 1

 		 

Re: 三角形の形状の分析

 投稿者：山中和義  投稿日：2012年 1月19日(木)21時25分52秒
  > No.1726[元記事へ]



!（直線の分析）
!自然数M,Nは、M≧Nとする。
!点(x,y)は、領域0≦x≦M、0≦y≦N内の格子点とする。
!(M+1)(N+1)個の格子点の中から2つ以上の点を通る直線は何本あるか。

!参考サイト
!　http://oeis.org/A018808


LET M=3 !0≦x≦M
LET N=M !0≦y≦N

LET K=0 !他の線分と重なる本数

LET Z=(N+1)*(M+1) !格子点の個数

PRINT "頂点番号"
FOR i=N TO 0 STEP -1
   FOR j=0 TO M
      PRINT USING "###": (M+1)*i+j;
   NEXT j
   PRINT
NEXT i
PRINT


DIM S(MAX(M,N)-1) !通過する格子点の数iの直線の本数S(i)
MAT S=ZER

FOR A=0 TO Z-2 !組合せ C((M+1)(N+1),2)
   LET XA=MOD(A,M+1) !座標へ
   LET YA=INT(A/(M+1))
   FOR B=A+1 TO Z-1
      LET XB=MOD(B,M+1)
      LET YB=INT(B/(M+1))

      PRINT "("; STR$(A); ","; STR$(B); ")";


      LET DX=XB-XA !線分ABのベクトルを考える
      LET DY=YB-YA


      LET G=gcd(ABS(DX),ABS(DY)) !正規化する
      LET DXX=DX/G
      LET DYY=DY/G

      LET XX=XA-DXX !線分ABの点Aを延ばす
      LET YY=YA-DYY
      IF (XX<0 OR XX>M) OR (YY<0 OR YY>N) THEN !領域外なら
         LET XX=XB+DXX !線分ABの点Bを延ばす
         LET YY=YB+DYY
         IF (XX<0 OR XX>M) OR (YY<0 OR YY>N) THEN !領域外なら
            LET FLG=0
         ELSE
            LET FLG=1 !点B'あり
         END IF
      ELSE
         LET FLG=1 !点A'あり
      END IF
      IF FLG=1 THEN !線分A'B, AB'に重なる
         LET K=K+1
         PRINT "　×";
      END IF


      LET W=G-1 !通過する格子点の数
      IF W>0 THEN
         PRINT W;
         IF FLG=0 THEN LET S(W)=S(W)+1
      END IF
      PRINT


   NEXT B
NEXT A

LET W=COMB((M+1)*(N+1),2)
PRINT "格子点の選び方は、"; W; "通り"

PRINT "重なるのは、"; K; "通り"
PRINT "よって、"; W-K; "通り"

MAT PRINT S;




!（三角形の形状の分析）
!自然数M,Nは、M≧Nとする。
!点(x,y)は、領域0≦x≦M、0≦y≦N内の格子点とする。
!(M+1)(N+1)個の格子点から3つを選んでできる点(x,y)の組を頂点とする三角形を分類せよ。
!
!(1)三角形
!(2)三角形が不成立

!参考サイト
!　http://oeis.org/A045996　三角形

!三角形が不成立は、3点が一直線上に並ぶときである。
!したがって、上記の結果を利用して得られる。

LET W=0
FOR i=1 TO MAX(M,N)-1
   LET W=W+S(i)*COMB(i+2,3)
NEXT i
PRINT COMB((M+1)*(N+1),3)-W; "通り"


END


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


実行結果

頂点番号
12 13 14 15
  8  9 10 11
  4  5  6  7
  0  1  2  3

(0,1)　×
(0,2)　× 1
(0,3) 2
(0,4)　×
(0,5)　×
(0,6)
(0,7)
(0,8)　× 1
(0,9)
(0,10)　× 1
(0,11)
(0,12) 2
(0,13)
(0,14)
(0,15) 2
(1,2)　×
(1,3)　× 1
(1,4)
(1,5)　×
(1,6)　×
(1,7)
(1,8)
(1,9)　× 1
(1,10)
(1,11) 1
(1,12)
(1,13) 2
(1,14)
(1,15)
(2,3)　×
(2,4)
(2,5)　×
(2,6)　×
(2,7)
(2,8) 1
(2,9)
(2,10)　× 1
(2,11)
(2,12)
(2,13)
(2,14) 2
(2,15)
(3,4)
(3,5)
(3,6)　×
(3,7)　×
(3,8)
(3,9)　× 1
(3,10)
(3,11)　× 1
(3,12) 2
(3,13)
(3,14)
(3,15) 2
(4,5)　×
(4,6)　× 1
(4,7) 2
(4,8)　×
(4,9)　×
(4,10)
(4,11)
(4,12)　× 1
(4,13)
(4,14) 1
(4,15)
(5,6)　×
(5,7)　× 1
(5,8)　×
(5,9)　×
(5,10)　×
(5,11)
(5,12)
(5,13)　× 1
(5,14)
(5,15)　× 1
(6,7)　×
(6,8)
(6,9)　×
(6,10)　×
(6,11)　×
(6,12)　× 1
(6,13)
(6,14)　× 1
(6,15)
(7,8)
(7,9)
(7,10)　×
(7,11)　×
(7,12)
(7,13) 1
(7,14)
(7,15)　× 1
(8,9)　×
(8,10)　× 1
(8,11) 2
(8,12)　×
(8,13)
(8,14)
(8,15)
(9,10)　×
(9,11)　× 1
(9,12)　×
(9,13)　×
(9,14)　×
(9,15)
(10,11)　×
(10,12)
(10,13)　×
(10,14)　×
(10,15)　×
(11,12)
(11,13)
(11,14)
(11,15)　×
(12,13)　×
(12,14)　× 1
(12,15) 2
(13,14)　×
(13,15)　× 1
(14,15)　×
格子点の選び方は、 120 通り
重なるのは、 58 通り
よって、 62 通り
4  10

516 通り

 		 

イスラム暦

 投稿者：永野護  投稿日：2012年 1月21日(土)13時33分29秒
  お頼みしたいことがあります。西暦(グレゴリオ暦）で例えば
2012年1月21日(土曜日)と入力すればイスラム暦××年××月××日(××曜日）
と表示されるようなプログラムを十進basicで作っていただけないでしょうか。
アラブ圏は結構広いのですが、モロッコの日付が知りたいのですが。
どなたかもしお頼みできるようでしたらよろしくお願いします。
 		 

Re: Spigot algorithms

 投稿者：劉徹  投稿日：2012年 1月22日(日)18時37分58秒
  > No.1025[元記事へ]

こんな感じでどうでしょう？
一応動作確認済み。
OPTION BASE 0
INPUT k
DIM a(k)
LET z=10 !基数
LET d=0
LET i=k-1
LET j=0
LET temp=0
LET a(k-1)=z
DO WHILE i>0
   LET temp=INT(a(i)/i)
   LET a(i-1)=z+temp
   LET a(i)=a(i)-temp*i
   LET i=i-1
LOOP
LET temp=INT(a(0)/z)
PRINT USING "#.":temp;
LET d=a(0)-temp*z
FOR j=0 TO k-1 !収束具合で調整
   LET a(0)=0
   LET a(k-1)=a(k-1)*z
   LET i=k-1
   DO WHILE i>0
      LET temp=INT(a(i)/i)
      LET a(i-1)=a(i-1)*z+temp
      LET a(i)=a(i)-temp*i
      LET i=i-1
   LOOP
   LET temp=INT(a(0)/z)
   LET d=d+temp
   PRINT USING "%":d;
   LET d=a(0)-temp*z
NEXT j
END

ちなみにC版(元)も
#include <stdio.h>
#define k 1000000
#define z 10
int a[k];
int main(){
int d,i,j;
a[k-1]=z;
for(i=k-1;i>0;i--){
a[i-1]=z+a[i]/i;
a[i]%=i;
}
printf("%d.",a[0]/z);
d=a[0]%z;
for(j=0;j<k/4;j++){
a[0]=0;
a[k-1]*=z;
for(i=k-1;i>0;i--){
a[i-1]=a[i-1]*z+a[i]/i;
a[i]%=i;
}
d+=a[0]/z;
printf("%d",d);
d=a[0]%z;
}
} 		 

Re: イスラム暦

 投稿者：SECOND  投稿日：2012年 1月25日(水)19時17分44秒
  > No.1728[元記事へ]

!修正 2012.1.28 updated

!2012.1.25 origin
!キー入力は無いので、中ほど DATA 文に、所要の西暦年月日を、
!まとめて、書いて下さい。
!西暦1999～2013 ( イスラム暦1420~1435 ) の間は 合っている様ですが、
!参考程度にして下さい。というのは、閏年( 年354日に 12月30日を加えて
! 年355日にする年 )が 前後の年へ　人為的操作を 受けているとしか思えず、
!数理的規則性だけでは、１日ズレる年度が、1423～1425　1431～1433 付近にあった。
!このプログラムでは、この区間を合せ込みましたが、他にどれ位あるのか、
!分りません。

!2012.1.27
!※その後の調査で、サイトにより異なる日付が見られ、確かなことは不明、
!　現在は、（ジェトロ）アジア経済研究所のデータ－へ合せる様にした。
!　ここのデーターだと、殆んど無調整で命中する。

!2012.1.28
!※太陰年に、354.36705日/年, 25101/850*12, 765433/25920*12 ・・等でなく、
!　やや短い 354.36695 ~354.36701日/年を、用いると全くの無調整で一致した。
!　この意味する所は、暦が用いている実態の太陰年らしい。
!※DATA 文の西暦年月日の後に、既知のイスラム暦年月日、=yyyymmdd を付加すると、
!　異なる場合にアラームを出すようにした。付加しなければ変換のみとなる。

!----------------------------------------------------------
!テキスト・ウィンドウの、左上位置(x0,y0)と、枠幅(xw,yw) 設定。
CALL SetWindowPos( WinHandle("TEXT" ),0, 340,150,685,530, 0)

SUB SetWindowPos( handle,C2, x0,y0,xw,yw, nFLG ) !　nFLG, 0=x0y0xwyw 1=x0y0 2=xwyw
   ASSIGN "user32.dll","SetWindowPos"
END SUB
!----------------------------------------------------------
!-------------------------------------------------
!イスラム暦　元年1月1日( 西暦 622.7.16 金)　太陰暦
!-------------------------------------------------

LET Tyy=354.36700 !太陰年 ○354.36695 ~354.36701 !×354.36705　25101/850*12　765433/25920*12
PRINT "Tyy/12 ";Tyy/12;"  Tyy";Tyy
!
DIM wk$(0 TO 6)
MAT READ wk$
DATA 日,月,火,水,木,金,土
!
!--------
!テスター、ユリウス日の動作。(今日の日付、cJD → DcJ)
LET i$=DATE$
LET J2_=cJD200( VAL(i$(1:4)),VAL(i$(5:6)),VAL(i$(7:8)))
CALL DcJ200( J2_)
PRINT USING "通日####### 西暦####年##月##日(##) 今日の日付" :J2_,LY,LM,LD,wk$(week)
!
!--------
!イスラム暦 起点 JB_ のセットアップ 確認。
LET JB_=cJD200( 622,7,16)
CALL DcJ200( JB_)
PRINT USING "通日####### 西暦####年##月##日(##) イスラム暦の起点" :JB_,LY,LM,LD,wk$(week)
!
!--------
!テスター、西暦 DATA 文 "yyyy/mm/dd" ～"" → イスラム暦 へ変換。
PRINT
CALL trans_data
STOP                         !●この STOP 文を外すと、1999, 4,17～2014,10, 5 区間の全表示。
!
!--------
!テスター、西暦 yyyy,mm,dd ～yyyy,mm,dd → イスラム暦 へ変換。
PRINT
!FOR J2_=cJD200( 622,7,16) TO cJD200( 626,7,16)
FOR J2_=cJD200( 1999, 4,17) TO cJD200( 2014,10, 5)
   LET J_ =J2_-JB_
   CALL DcJ200( J2_)
   CALL islam2( J_ )         !● ↓ 月と年の 変わり目の確認なので、通常は if then を外す。
   IF 28< iD OR iD< 3 THEN   ! xx.29 xx.30 xx.1 xx.2 のみ表示
      PRINT USING "通日####### 西暦####年##月##日(##)" :J2_,LY,LM,LD,wk$(week);
      PRINT USING" islam_通日######　####年##月##日 ####":J_,iY,iM,iD,u$
   END IF                    ! xx.29 xx.30 xx.1 のみ表示
NEXT J2_

SUB trans_data
   DO
      READ IF MISSING THEN EXIT DO: d$
      IF d$=" " THEN
         PRINT
      ELSE
         LET w=POS(d$,"/")
         IF w=0 THEN EXIT DO
         LET YY=VAL(d$(1:w-1))
         LET w1=POS(D$,"/",w+1)
         IF w1=0 THEN EXIT DO
         LET MM=VAL(d$(w+1:w1-1))
         LET xx=POS(D$,"=",w1+1)
         IF xx=0 THEN LET w2=LEN(d$)+1 ELSE LET w2=xx
         LET DD=VAL(d$(w1+1:w2-1))
         !---
         LET J2_=cJD200( YY,MM,DD)
         LET J_ =J2_-JB_
         CALL DcJ200( J2_)
         CALL islam2( J_ )
         PRINT USING "通日####### 西暦####年##月##日(##)" :J2_,LY,LM,LD,wk$(week);
         PRINT USING" islam_通日######　####年##月##日 #### df.####":J_,iY,iM,iD,u$,FP(df)
         !---
         IF 0< xx THEN
            IF iY<>VAL(d$(xx+1:xx+4)) OR iM<>VAL(d$(xx+5:xx+6)) OR iD<>VAL(d$(xx+7:xx+8)) THEN
               PRINT "Error"
               beep
               WAIT DELAY 1
            END IF
         END IF
      END IF
   LOOP
END SUB

!太陰年(Tyy)= 354.36698  ○暦の実態=354.36695 ~354.36701日/年、×公称=354.36705日/年
!       平年= 354日/年   閏年= 355日/年( 12.1~12.29＋12.30  …11回/30年)
!     奇数月=  30日/月 偶数月=  29日/月

SUB islam2(J_)
   LET jw_=J_+.999
   LET iY= IP( jw_/Tyy) +1
   LET df=MOD( jw_,Tyy)
   !---
   LET d_= IP( df)
   IF d_< 354 THEN LET Nmm=29.5 ELSE LET Nmm=29.51
   LET iM=     IP( d_/Nmm) +1
   LET iD=IP( MOD( d_,Nmm)) +1
   !---
   IF FP(df)< FP(Tyy) THEN LET u$="閏年" ELSE LET u$=""
END SUB

!-------------------------------------------------------
!http://www.ide.go.jp/Japanese/Research/Region/Mid_e/koyomi.html
! IDE-JETRO  独立行政法人日本貿易振興機構
!（ジェトロ）アジア経済研究所（独立行政法人日本貿易振興機構の附置研究機関）
!
!            ヒジュラ（イスラーム）暦・西暦換算表 による。
!--------------------------------------------------------
DATA " 622/ 7/16 =00010101"            !   1. 1.1
DATA " "
DATA "1999/ 4/16"                      !
DATA "1999/ 4/17 =14200101"            !1420. 1.1
DATA "1999/ 4/18 =14200102"            !
DATA " "
DATA "2000/ 4/ 5"                      !
DATA "2000/ 4/ 6 =14210101"            !1421. 1.1
DATA "2000/ 4/ 7 =14210102"            !
DATA " "
DATA "2001/ 3/25"                      !
DATA "2001/ 3/26 =14220101"            !1422. 1.1
DATA "2001/ 3/27 =14220102"            !
DATA " "
DATA "2002/ 3/14"                      !
DATA "2002/ 3/15 =14230101"            !1423. 1.1
DATA "2002/ 3/16 =14230102"            !
DATA " "
DATA "2003/ 3/ 3"                      !
DATA "2003/ 3/ 4"                      !1424. 1.1
DATA "2003/ 3/ 5 =14240101"            !*1424. 1.1 ← この位置が、確からしい。
DATA "2003/ 3/ 6 =14240102"            !
DATA " "
DATA "2004/ 2/20"                      !
DATA "2004/ 2/21"                      !1425. 1.1
DATA "2004/ 2/22 =14250101"            !*1425. 1.1 ← この位置が、確からしい。
DATA "2004/ 2/23 =14250102"            !
DATA " "
DATA "2005/ 2/ 9"                      !
DATA "2005/ 2/10 =14260101"            !1426. 1.1
DATA "2005/ 2/11 =14260102"            !
DATA " "
DATA "2006/ 1/30"                      !
DATA "2006/ 1/31 =14270101"            !1427. 1.1
DATA "2006/ 2/ 1 =14270102"            !
DATA " "
DATA "2007/ 1/19"                      !
DATA "2007/ 1/20 =14280101"            !1428. 1.1
DATA "2007/ 1/21 =14280102"            !
DATA " "
DATA "2008/ 1/ 9"                      !
DATA "2008/ 1/10 =14290101"            !1429. 1.1
DATA "2008/ 1/11 =14290102"            !
DATA " "
DATA "2008/12/28"                      !
DATA "2008/12/29 =14300101"            !1430. 1.1
DATA "2008/12/30 =14300102"            !
DATA " "
DATA "2009/12/17"                      !
DATA "2009/12/18 =14310101"            !1431. 1.1
DATA "2009/12/19 =14310102"            !
DATA " "
DATA "2010/12/ 6"                      !
DATA "2010/12/ 7"                      !1432. 1.1
DATA "2010/12/ 8 =14320101"            !*1432. 1.1 ← この位置が、確からしい。
DATA "2010/12/ 9 =14320102"            !
DATA " "
DATA "2011/11/26"                      !
DATA "2011/11/27 =14330101"            !1433. 1.1
DATA "2011/11/28 =14330102"            !
DATA " "
DATA "2012/11/14"                      !
DATA "2012/11/15 =14340101"            !1434. 1.1
DATA "2012/11/16 =14340102"            !
DATA " "
DATA "2013/11/ 4"                      !
DATA "2013/11/ 5 =14350101"            !1435. 1.1
DATA "2013/11/ 6 =14350102"            !
DATA " "
DATA "2014/ 9/26 =14351201"            !1435.12.1
DATA "2014/10/ 5 =14351210"            !1435.12.10
!---below random
!DATA "stop"
DATA " "
DATA "2014/10/24"                      !
DATA "2000/ 1/ 8 =14201001"            !1420.10.1
DATA "2007/10/13 =14281001"            !1428.10.1
DATA "2012/ 1/ 1 =14330206"            !1433.2.6
DATA "2012/ 1/25 =14330301"            !1433.3.1
DATA "2012/11/30 =14340116"            !1434. 1.16
DATA "2012/12/31 =14340217"            !1434. 2.17


!-------------------------------------------------------------
!西暦年月日 YY.MM.DD から､ユリウス日 CJD の計算
! -4712.1.1 ~2400.xx.xx の範囲、消滅区間 1582.10.5 ~1582.10.14
!-------------------------------------------------------------
FUNCTION cJD200( YY,MM,DD )
   LET WY=YY
   IF 1582< YY THEN                            !1583.1.1~~
   !-- ( 1583.1.1~ yyyy.12.31),  1600+100.01.00  (1700.01.00) J1700= 2341972
      LET ww=INT(WY/100)
      LET WY=MOD(WY,100)  !LET WY=WY-100*ww
      LET J0_=2341972+INT(36524.25*(ww-17))    !(1700.01.00) J1700= 2341972
      IF MOD(ww,4)<>0 THEN LET J1=365 ELSE LET J1=366
      !--- WY.MM.DD=00.1.1~99.12.31 J0_=J.(ww00.1.0) J1=365|366
   ELSE
      LET J0_= 1721058-1                       !J0000= J.(0000.1.0) julian date
      LET J1=366
   END IF
   !---
   IF 2< MM THEN
      LET WM=MM+1
   ELSE
      LET WM=MM+13
      LET WY=WY-1
   END IF
   IF WY=-1 THEN
      LET J2_=J0_-428 +INT(30.6001*WM)+DD
   ELSE
      LET J2_=J0_-428+J1+INT(365.25*WY) +INT(30.6001*WM)+DD
   END IF
   !---
   IF YY=1582 AND 2299160< J2_ THEN            !1582.10.4 ~1582.xx.xx J1582A4= 2299160
      LET J2_=J2_-10                           !1582.10.15~1582.12.31 ok.
      IF J2_<=2299160 THEN LET J2_=-1          !1582.10.5 ~1582.10.14 error
   END IF
   LET cJD200=J2_
END FUNCTION

!----------------------------------------------------------------------------
!(ユリウス日 CJD) J2_ から､西暦年月日 曜日 LY.LM.LD WEEK( 0:日~6:土) の逆計算
! -4712.1.1 ~2400.xx.xx の範囲、消滅区間 1582.10.5 ~1582.10.14
!----------------------------------------------------------------------------
SUB DcJ200( J2_)
   IF 2299160< J2_ THEN                        !1582.10.4<    J1582A4= 2299160
   !--(1582.10.15~1582~12.31) (1583.1.1~ )
      LET ww=INT((J2_-2341972)/36524.25)+17    !( ww00.01.00) J1700= 2341972
      LET J0_=2341972+INT(36524.25*(ww-17))    !( 1700.01.00) J1700= 2341972
      IF MOD(ww,4)<>0 THEN LET J1=365 ELSE LET J1=366
   ELSE
      LET J0_=1721058-1                        !julian date( 0000.01.00) J0000=1721058-1
      LET J1=366
   END IF
   !---
   LET D_=J2_-J0_+428-J1
   LET LY=INT((D_-122.0001)/365.25)
   IF LY=-1 THEN LET W_=D_+J1 ELSE LET W_=D_-INT(365.25*LY)
   LET LM=INT( W_/30.6001)
   LET LD=W_-INT( 30.6001*LM)
   IF LM< 14 THEN LET LM=LM-1 ELSE LET LM=LM-13
   IF LM<=2 THEN LET LY=LY+1
   !---
   IF 2299160< J2_ THEN LET LY=LY+100*ww       !1582.10.4<    J1582A4= 2299160
   LET WEEK=MOD(J2_+1, 7)
END SUB

!-------------------------------------------------
! Chronological Julian Day(CJD)
!
!   小数下の端数を、時間に対応させるため、( 0~ 1 → 00:00~24:00)
!    JD=0 の基点( 12:00 January 1, 4713 BC, Monday)を、0.5日過去へ下げたもの。
!   CJD=0 の基点( 00:00 January 1, 4713 BC, Monday)
!-------------------------------------------------

END
 		 

二次方程式を解きたいのですが。

 投稿者：nuﾒｰﾙ  投稿日：2012年 1月25日(水)22時40分32秒
  !以下のプログラムで二次方程式を解きたいのですが、どうにも手詰まりです。
!特にa=12,b=23,c=34,d=45,e=56,f=67の場合、如何ともし難いので、
!お分かりになられる方、ご教授を下さるようお願いいたします。
!----------------------------------------------------------------------
!二次方程式を解くためのプログラム
!根はわざと開かないような仕様にいたしました。
!----------------------------------------------------------------------
00100 LET t0=TIME
00500 DECLARE EXTERNAL FUNCTION GCD
01000 !【１】配列
01100 DIM x(2)
01200 DIM y(3)
01300 GOTO 02000 !【２】代入へ

02000 !【２】代入
02100 PRINT "「二次方程式の解を計算します。"
02110 PRINT "  a/d*x^2 + b/e*x + c/f = 0 の形式で、"
02120 PRINT "  a,b,c,d,e,fの順序で入力してください。」"
02130 PRINT "  <例> a*x^2 + b*x + c = 0 のとき、"
02140 PRINT "       a,b,c,1,1,1と入力します。"
02300 INPUT a,b,c,d,e,f
02400 LET y(1)=a*e*f !置き換え
02500 LET y(2)=b*d*f
02600 LET y(3)=c*d*e
02700 LET G=GCD(GCD(y(1),y(2)),y(3))
02750 LET a=y(1)/G
02800 LET b=y(2)/G
02850 LET c=y(3)/G
02900 GOTO 03000 !【３】判別式分岐へ

03000 !【３】判別式分岐
03100 LET D=b^2-4*a*c !D＝平方数
03200 IF D>=0 THEN GOTO 04000 !【４】実数解のときの平方数分岐
03300 IF D<0 THEN GOTO 03400
03400 LET D=-D
03500 GOTO 08000!【８】虚数解のときの分岐

04000 !【４】実数解のときの平方数分岐
04100 IF INT(SQR(D))=SQR(D) THEN GOTO 05000!【５】!実数解のときのD＝平方数のときの解
04200 IF INT(SQR(D))><SQR(D) THEN GOTO 06000!【６】!実数解のときのD≠平方数のときの分岐

05000 !【５】実数解のときのD＝平方数のときの解
05100 LET x(1)=(-b-SQR(D))/(2*a)
05200 LET x(2)=(-b+SQR(D))/(2*a)
05300 PRINT "x(1)=";x(1)
05400 PRINT "x(2)=";x(1)
05500 GOTO 20000 !ENDへ

06000 !【６】実数解のときのD≠平方数のときの分岐
06100 FOR i=2 TO INT(SQR(D))
06300    IF MOD(D/(i^2)-INT(D/(i^2)),1)><0 THEN GOTO 06900 !iの探索を行うループ
06400    IF MOD(D/(i^2)-INT(D/(i^2)),1)=0 THEN GOTO 06500 !除数分岐へ
06500    IF MOD((i^2)-INT((i^2)),1)><0 THEN GOTO 06900
06600    IF MOD((i^2)-INT((i^2)),1)=0 THEN GOTO 06620 !実数解のときの-D≠平方数のときの解
06620    IF i/GCD(2*a,i)=1 THEN GOTO 06820
06640    IF i/GCD(2*a,i)><1 THEN GOTO 06700
06700    PRINT "x(1)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"+";i/GCD(2*a,i);"√";D/(i^2);"/";2*a/GCD(2*a,i)
06800    PRINT "x(2)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"-";i/GCD(2*a,i);"√";D/(i^2);"/";2*a/GCD(2*a,i)
06805    PRINT "⇔"
06810    GOTO 06900
06820    PRINT "x(1)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"+";"√";D;"/";2*a
06840    PRINT "x(2)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"-";"√";D;"/";2*a
06850    PRINT "⇔"
06900 NEXT i
07000 PRINT"これが解です。"
07100 GOTO 20000 !ENDへ

08000 !【８】虚数解のときの平方数分岐
08100 IF INT(SQR(D))=SQR(D) THEN GOTO 09000!【９】!虚数解のときの-D＝平方数のときの解
08200 IF INT(SQR(D))><SQR(D) THEN GOTO 10000!【１０】!虚数解のときの-D≠平方数のときの分岐

09000 !【９】虚数解のときの-D＝平方数のときの解
09100 LET x(1)=(-b-SQR(D))/(2*a)
09200 LET x(2)=(-b+SQR(D))/(2*a)
09300 PRINT "x(1)=";x(1)
09400 PRINT "x(2)=";x(2)
09500 GOTO 20000 !ENDへ

10000 !【１０】虚数解のときの-D≠平方数のときの分岐
10100 FOR i=2 TO INT(SQR(D))
10300    IF MOD(D/(i^2)-INT(D/(i^2)),1)><0 THEN GOTO 10900 !iの探索を行うループ
10400    IF MOD(D/(i^2)-INT(D/(i^2)),1)=0 THEN GOTO 10500 !除数分岐へ
10500    IF MOD((i^2)-INT((i^2)),1)><0 THEN GOTO 10900
10600    IF MOD((i^2)-INT((i^2)),1)=0 THEN GOTO 10620 !実数解のときの-D≠平方数のときの解
10620    IF i/GCD(2*a,i)=1 THEN GOTO 10820
10640    IF i/GCD(2*a,i)><1 THEN GOTO 10700
10700    PRINT "x(1)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"-";i/GCD(2*a,i);"√";D/(i^2);"ｉ/";2*a/GCD(2*a,i)
10800    PRINT "x(2)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"+";i/GCD(2*a,i);"√";D/(i^2);"ｉ/";2*a/GCD(2*a,i)
10805    PRINT "⇔"
10810    GOTO 10900
10820    PRINT "x(1)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"+";"√";D;"ｉ/";2*a
10840    PRINT "x(2)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"-";"√";D;"ｉ/";2*a
10850    PRINT "⇔"
10900 NEXT i
11100 PRINT"これが解です。"
11150 PRINT TIME-t0;"秒かかりました。"
11200 GOTO 20000 !ENDへ
20000 END

30000 EXTERNAL FUNCTION GCD(a,b)
30100 DO
30200    LET r=MOD(a,b)
30300    IF r=0 THEN EXIT DO
30400    LET a=b
30500    LET b=r
30600 LOOP
30700 LET GCD=b
30800 END FUNCTION 		 

二次方程式を解きたいのですが。（訂正あり）

 投稿者：nuﾒｰﾙ  投稿日：2012年 1月25日(水)23時25分49秒
  > No.1731[元記事へ]

訂正です。
  (誤)05400 PRINT "x(2)=";x(1)
→(正)05400 PRINT "x(2)=";x(2) 		 

Re: 二次方程式を解きたいのですが。

 投稿者：SECOND  投稿日：2012年 1月26日(木)09時46分34秒
  > No.1731[元記事へ]

06100 FOR i=2 TO INT(SQR(D))
10100 FOR i=2 TO INT(SQR(D))　 →  FOR i=1 TO INT(SQR(D))　両方とも、変えてみる。

√ の中の約数 i を探す所を、
２から始めると、見つからない場合の処理が、必要になりますが、文中にそれは有りません。
１から始めれば、最初に１つは、見つかるので、見つからない場合のブランクを、防げます。

＜追記＞
FOR i=INT(SQR(D)) TO 1 STEP -1   !１へ向って、逆回しにする。
   IF FP( D/(i^2))=0 THEN        ! 小数部が０なら、
      (
       )         !最初に見つかる最大の約数ｉで PRINT し、
      EXIT FOR   !for~next から出る。最悪でも i=1 で 漏れない。
   END IF
NEXT i
 		 

Re: 二次方程式を解きたいのですが。

 投稿者：山中和義  投稿日：2012年 1月26日(木)13時28分21秒
  > No.1731[元記事へ]

nuさんへのお返事です。

有理数（分数）の計算ができるので、こちらでまず考えてみました。


!2次方程式Ax^2+Bx+C=0すると、
!　判別式D=B^2-4AC
!　解の公式より、x=(-B/(2A))±√{(B^2-4AC)}/(2A)
!となる。

OPTION ARITHMETIC RATIONAL !有理数モード

LET A=12/45
LET B=23/56
LET C=34/67


LET D=B^2-4*A*C
IF D=0 THEN !重根
   PRINT "x="; -B/(2*A); "（重根）"

ELSE
   LET S=NUMER(D) !分子　※符号なし
   LET T=DENOM(D) !分母　※符号なし
   !!!PRINT D;S;T !debug
   CALL SqNormalize(S,P,Q) !√S=P√Qと変形する
   CALL SqNormalize(T,X,Y)
   !!!PRINT P;Q; X;Y !debug
   IF Q=1 AND Y=1 THEN !平方根の中が平方数なら、m形
      PRINT "x="; (-B+P/X)/(2*A); ","; (-B-P/X)/(2*A)

   ELSE !m±√n形
      LET W=-B/(2*A) !有理数部（実部）
      IF W<>0 THEN PRINT "x="; W;

      PRINT "±";

      IF D<0 THEN PRINT "i * "; !虚数単位

      LET W=(P/X)/(2*A*Y) !平方根部（虚部）　※有理化
      LET Z=NUMER(W)
      IF Z>1 THEN PRINT Z;
      PRINT "√"; Q*Y;
      LET Z=DENOM(W)
      IF Z>1 THEN PRINT "/"; Z

   END IF

END IF

END

EXTERNAL SUB SqNormalize(n, p,q) !平方根の中をできるだけ小さな正の整数に直す
OPTION ARITHMETIC RATIONAL !有理数モード
!※n=p^2*q、n,p,q≧0とすると、SQR(n)=p*SQR(q)と変形できる。
LET q=1 !※SQR(0)=0*SQR(1)とする　※n=0なら、１行下のFOR文でp=0は設定される
FOR p=INTSQR(n) TO 1 STEP -1 !約数p^2の候補を大きい方から
   LET q=n/p^2
   IF q=INT(q) THEN EXIT FOR !qは自然数より
NEXT p
END SUB



実行結果
x=-345/448 ±i * √ 1180210695 / 30016
 		 

Re: 二次方程式を解きたいのですが。

 投稿者：nuﾒｰﾙ  投稿日：2012年 1月26日(木)16時50分17秒
  > No.1733[元記事へ]

SECONDさんへのお返事です。

SECOND様、ご回答いただきありがとうございました。
大変勉強になりました。
早くなることを期待して、
FOR i=2 TO INT(SQR(D))にしたことが主な原因だったようです。
FOR i=1 TO INT(SQR(D))に元どおり手直しします。
あとで配列を変えて、最後まで根を簡単にするようにしたいと思います。
参考にさせていただきます。

nu 		 

Re: 二次方程式を解きたいのですが。

 投稿者：nuﾒｰﾙ  投稿日：2012年 1月26日(木)16時52分27秒
  > No.1734[元記事へ]

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

山中様、ご回答いただきありがとうございました。
大変勉強になりました。

有理数モードの有効性に驚かされました。
おそらく、DATAからREADの流れで、一気に複数の問題を解くのに向いていると思います。
参考にさせていただきます。

un 		 

Re: 二次方程式を解きたいのですが。（訂正再送）

 投稿者：nuﾒｰﾙ  投稿日：2012年 1月26日(木)16時56分10秒
  山中和義さんへのお返事です。

山中様、ご回答いただきありがとうございました。
大変勉強になりました。

有理数モードの有効性に驚かされました。
おそらく、DATAからREADの流れで、一気に複数の問題を解くのに向いていると思います。
参考にさせていただきます。

unもといnu 		 

二次方程式の解

 投稿者：nuﾒｰﾙ  投稿日：2012年 1月27日(金)23時57分37秒
  !こんな感じになりました。
!ありがとうございました。
!2次方程式Ax^2+Bx+C=0すると、
!　判別式D=B^2-4AC
!　解の公式より、x=(-B/(2A))±√{(B^2-4AC)}/(2A)
!となる。
OPTION ARITHMETIC RATIONAL !有理数モード
DIM A(10)
DIM B(10)
DIM C(10)
LET A(1)=631/254
LET B(1)=25/398
LET C(1)=761/764
LET A(2)=131/521
LET B(2)=727/13
LET C(2)=31/423
LET A(3)=714/29
LET B(3)=2/103
LET C(3)=793/4
LET A(4)=405/26
LET B(4)=245/3
LET C(4)=17/4
LET A(5)=3431/2
LET B(5)=223/106
LET C(5)=441/4
LET A(6)=49/12
LET B(6)=112/113
LET C(6)=317/47
LET A(7)=91/29
LET B(7)=52/39
LET C(7)=73/41
LET A(8)=11/92
LET B(8)=72/13
LET C(8)=37/94
LET A(9)=12/271
LET B(9)=209/32
LET C(9)=79/104
LET A(10)=431/2
LET B(10)=33/74
LET C(10)=75/4

FOR j=1 TO 10
PRINT "(";j;")";A(j);"x^2+";B(j);"x+";C(j);"=0"
LET D=B(j)^2-4*A(j)*C(j)
IF D=0 THEN !重根
PRINT " ⇔";"x=";-B(j)/(2*A(j));"（重根）"
ELSE
LET S=NUMER(D) !分子　※符号なし
LET T=DENOM(D) !分母　※符号なし
!!!PRINT D;S;T !debug
CALL SqNormalize(S,P,Q) !√S=P√Qと変形する
CALL SqNormalize(T,X,Y)
!!!PRINT P;Q; X;Y !debug
IF Q=1 AND Y=1 THEN !平方根の中が平方数なら、m形
PRINT " ⇔";"x=";(-B(j)+P/X)/(2*A(j));",";(-B(j)-P/X)/(2*A(j))
ELSE !m±√n形
LET W=-B(j)/(2*A(j)) !有理数部（実部）
IF W<>0 THEN
PRINT " ⇔";"x="; W;
PRINT "±";
IF D<0 THEN PRINT "i * "; !虚数単位
LET W=(P/X)/(2*A(j)*Y) !平方根部（虚部）※有理化
LET Z=NUMER(W)
IF Z>1 THEN PRINT Z;
PRINT "√"; Q*Y;
LET Z=DENOM(W)
IF Z>1 THEN PRINT "/"; Z
END IF
END IF
END IF
NEXT j
END

EXTERNAL SUB SqNormalize(n,p,q) !平方根の中をできるだけ小さな正の整数に直す
OPTION ARITHMETIC RATIONAL !有理数モード
!※n=p^2*q、n,p,q≧0とすると、SQR(n)=p*SQR(q)と変形できる。
LET q=1 !※SQR(0)=0*SQR(1)とする　※n=0なら、１行下のFOR文でp=0は設定される
FOR p=INTSQR(n) TO 1 STEP -1 !約数p^2の候補を大きい方から
LET q=n/p^2
IF q=INT(q) THEN EXIT FOR !qは自然数より
NEXT p
END SUB 		 

Re: 二次方程式の解

 投稿者：山中和義  投稿日：2012年 1月28日(土)18時59分35秒
  > No.1738[元記事へ]

nuさんへのお返事です。

まず、前出のサンプルには整形表示で不具合がありました。（以下は修正しています）

サブルーチンをご存知なら、こちらの方が簡単です。まとめてブラックボックス化してください。

後は、有理数のプログラムを元に自前で有理数（分数）の計算を導入（差し替え）すればよいでしょう。


!2次方程式Ax^2+Bx+C=0とすると、
!　判別式D=B^2-4AC
!　解の公式より、x=(-B/(2A))±√D/(2A)
!となる。

OPTION ARITHMETIC RATIONAL !有理数モード

LET A=12/45
LET B=23/56
LET C=34/67
CALL Solve2Equ(A,B,C)

LET A=1 !x^2-3x+2=(x-1)(x-2)
LET B=-3
LET C=2
CALL Solve2Equ(A,B,C)

LET A=-1 !-x^2+x+1
LET B=1
LET C=1
CALL Solve2Equ(A,B,C)

LET A=1 !x^2+1=(x+i)(x-i)
LET B=0
LET C=1
CALL Solve2Equ(A,B,C)

LET A=2 !2x^2-2=2(x+1)(x-1)
LET B=0
LET C=-2
CALL Solve2Equ(A,B,C)

LET A=1 !x^2-4x+4=(x-2)^2
LET B=-4
LET C=4
CALL Solve2Equ(A,B,C)

LET A=0 !(1/2)x+3/4
LET B=1/2
LET C=3/4
CALL Solve2Equ(A,B,C)

LET A=0 !2/3
LET B=0
LET C=2/3
CALL Solve2Equ(A,B,C)

END


EXTERNAL SUB Solve2Equ(A,B,C) !2次方程式Ax^2+Bx+C=0を解く
OPTION ARITHMETIC RATIONAL !有理数モード

IF A=0 THEN !1次方程式 Bx+C=0
   IF B=0 THEN !C=0
      PRINT "方程式が成立しません。"; A;B;C
   ELSE
      PRINT "x= "; -C/B
   END IF

ELSE
   PRINT "x= ";

   LET D=B^2-4*A*C !判別式　※平方根の中
   LET S=NUMER(D) !分子　※符号なし
   LET T=DENOM(D) !分母　※符号なし
   !!!PRINT D;S;T !debug
   CALL SqNormalize(S,P,Q) !√S=P√Qと変形する
   CALL SqNormalize(T,X,Y)
   !!!PRINT P;Q; X;Y !debug
   IF D>0 AND (Q=1 AND Y=1) THEN !平方根の中が平方数なら、m形
      PRINT (-B+P/X)/(2*A); ", "; (-B-P/X)/(2*A)

   ELSE !m±√n形
      LET W=-B/(2*A) !有理数部（実部）
      IF D=0 THEN !判別式D=0なら
         PRINT W; "（重根）";
      ELSE
         IF W<>0 THEN PRINT W;

         PRINT "± ";

         LET W=(P/X)/Y/(2*A) !平方根部（虚部）　※有理化 √(P/Q)=(√PQ)/Q
         LET Z=Q*Y
         LET S=NUMER(W)
         LET T=DENOM(W)

         IF D<0 THEN
            PRINT "i "; !虚数単位
            IF NOT(S=1 AND T=1 AND Z=1) THEN PRINT "* "; !虚数単位
         END IF

         IF S>1 THEN PRINT S; !１サプレス
         IF Z>1 THEN PRINT "√("; Z; ") ";
         IF T>1 THEN PRINT "/"; T; !１サプレス

      END IF
      PRINT

   END IF
END IF
END SUB


EXTERNAL SUB SqNormalize(n, p,q) !平方根の中をできるだけ小さな正の整数に直す
OPTION ARITHMETIC RATIONAL !有理数モード
!※n=p^2*q、n,p,q≧0とすると、SQR(n)=p*SQR(q)と変形できる。
LET q=1 !※SQR(0)=0*SQR(1)とする　※n=0なら、１行下のFOR文でp=0は設定される
FOR p=INTSQR(n) TO 1 STEP -1 !約数p^2の候補を大きい方から
   LET q=n/p^2
   IF q=INT(q) THEN EXIT FOR !qは自然数より
NEXT p
END SUB
 		 

Re: 二次方程式の解

 投稿者：nuﾒｰﾙ  投稿日：2012年 1月29日(日)06時26分42秒
  山中和義さんへのお返事です。
お便りをいただきありがとうございます。

当方もプログラムを組んでおりました。
出来は無骨で、中学生には楽しめるのではないかと自負しております。
検索に時間がかかる点が短所ですが、他の解を見られるのは長所だと思います。
!----------------------------------------------------------------------
!二次方程式を解くためのプログラム
!根はわざと開かないような仕様にいたしました。
!----------------------------------------------------------------------
00500 DECLARE EXTERNAL FUNCTION GCD
01000 !【１】配列
01100 DIM x(2)
01200 DIM y(3)
01300 GOTO 02000 !【２】代入へ

02000 !【２】代入
02001 PRINT "「二次方程式の解を計算します。"
02002 PRINT " a/d*x^2 + b/e*x + c/f = 0 の形式で、"
02003 PRINT " a,b,c,d,e,fの順序で入力してください。」"
02004 PRINT " <例> a*x^2 + b*x + c = 0 のとき、"
02005 PRINT " a,b,c,1,1,1と入力します。"
02006 INPUT a,b,c,d,e,f
02007 PRINT "a,b,c,d,e,f"
02008 PRINT "(";a;")";"/";"(";d;")";"x^2+";"(";b;")";"/";"(";e;")";"x+";"(";c;")";"/";"(";f;")";"=0"
02009 LET t0=TIME

!!!!!
02010 IF d*e*f=0 THEN GOTO 02398
02011 IF d*e*f><0 THEN GOTO 02013
02012
02013 IF a*b*c*d*e*f><0 THEN GOTO 02400
02014 IF d*e*f><0 AND a><0 AND b><0 AND c=0 THEN GOTO 02040
02015 IF d*e*f><0 AND a><0 AND b=0 AND c><0 THEN GOTO 02046
02016 IF d*e*f><0 AND a><0 AND b=0 AND c=0 THEN GOTO 02386
02017 IF d*e*f><0 AND a=0 AND b><0 AND c><0 THEN GOTO 02388
02018 IF d*e*f><0 AND a=0 AND b><0 AND c=0 THEN GOTO 02394
02019 IF d*e*f><0 AND a=0 AND b=0 AND c><0 THEN GOTO 02396
02020 IF d*e*f><0 AND a=0 AND b=0 AND c=0 THEN GOTO 02398

02040 IF INT(b/GCD(a,b))><int(a a="" and=""><1 THEN GOTO 02042
02041 IF INT(b/GCD(a,b))=INT(a/GCD(a,b)) OR INT(a/GCD(a,b))=1 THEN GOTO 02044
02042 PRINT "x(1)=";-b/GCD(a,b);"/";a/GCD(a,b);",";"x(2)=";0
02043 GOTO 20000
02044 PRINT "x(1)=";-b/a;",";"x(2)=";0
02045 GOTO 20000

!
!x(1)=-i*SQR(c*d/a*f),x(2)=i*SQR(c*d/a*f)
!
02046 IF a*f>0 AND c*d>0 THEN GOTO 02050
02047 IF a*f>0 AND c*d<0 THEN GOTO 02070
02048 IF a*f<0 AND c*d>0 THEN GOTO 02090
02049 IF a*f<0 AND c*d<0 THEN GOTO 02110

!x(1)=-i*SQR(c*d/a*f),x(2)=i*SQR(c*d/a*f)
!(1)a*f>0 AND c*d>0
02050 FOR j=INT(SQR(c*d*a*f)) TO 1 STEP -1
02052 IF INT(SQR(c*d*a*f)/j)=SQR(c*d*a*f)/j AND GCD(a*f,j)><1 THEN GOTO 02055
02053 IF INT(SQR(c*d*a*f)/j)=SQR(c*d*a*f)/j AND GCD(a*f,j)=1 AND a*f><1 THEN GOTO 02057
02054 IF INT(SQR(c*d*a*f)/j)=SQR(c*d*a*f)/j AND GCD(a*f,j)=1 AND a*f=1 THEN GOTO 02059
02055 PRINT "x(1)=-i*";j/GCD(a*f,j);"/";a*f/GCD(a*f,j);"√";(c*d*a*f/(j^2));",";"x(2)=i*";j/GCD(a*f,j);"/";a*f/GCD(a*f,j);"√";(c*d*a*f/(j^2))
02056 GOTO 02061
02057 PRINT "x(1)=-i*";j;"/";a*f;"√";(c*d*a*f/(j^2));",";"x(2)=i*";j;"/";a*f;"√";(c*d*a*f/(j^2))
02058 GOTO 02061
02059 PRINT "x(1)=-i*";j/(a*f);"√";(c*d*a*f/(j^2));",";"x(2)=i*";j/(a*f);"√";(c*d*a*f/(j^2))
02060 GOTO 02061
02061 NEXT j
02062 GOTO 20000

!(2)a*f>0 AND c*d<0
!x(1)=-SQR(-c*d/a*f),x(2)=SQR(-c*d/a*f)
!x(1)=-SQR(-c*d*a*f/(a^2*f^2)),x(2)=SQR(-c*d*a*f/(a^2*f^2))
!x(1)=-SQR(-c*d*a*f)/(a*f),x(2)=SQR(-c*d*a*f)/(a*f)
02070 FOR j=INT(SQR(-c*d*a*f)) TO 1 STEP -1
02071 IF INT(SQR(-c*d*a*f)/j)=SQR(-c*d*a*f)/j AND GCD(a*f,j)><1 THEN GOTO 02074
02072 IF INT(SQR(-c*d*a*f)/j)=SQR(-c*d*a*f)/j AND GCD(a*f,j)=1 AND a*f><1 THEN GOTO 02076
02073 IF INT(SQR(-c*d*a*f)/j)=SQR(-c*d*a*f)/j AND GCD(a*f,j)=1 AND a*f=1 THEN GOTO 02078
02074 PRINT "x(1)=-";j/GCD(a*f,j);"/";a*f/GCD(a*f,j);"√";(-c*d*a*f/(j^2));",";"x(2)=";j/GCD(a*f,j);"/";a*f/GCD(a*f,j);"√";(-c*d*a*f/(j^2))
02075 GOTO 02080
02076 PRINT "x(1)=-";j;"/";a*f;"√";(-c*d*a*f/(j^2));",";"x(2)=";j;"/";a*f;"√";(-c*d*a*f/(j^2))
02077 GOTO 02080
02078 PRINT "x(1)=-";j/(a*f);"√";(-c*d*a*f/(j^2));",";"x(2)=";j/(a*f);"√";(-c*d*a*f/(j^2))
02079 GOTO 02080
02080 NEXT j
02081 GOTO 20000


!x(1)=-i*SQR(c*d/a*f),x(2)=i*SQR(c*d/a*f)
!(3)a*f<0 AND c*d>0
!x(1)=-SQR(-c*d/a*f),x(2)=SQR(-c*d/a*f)
!x(1)=-SQR(-c*d*a*f/(a^2*f^2)),x(2)=SQR(-c*d*a*f/(a^2*f^2))
!x(1)=-SQR(-c*d*a*f)/(-a*f),x(2)=SQR(-c*d*a*f)/(-a*f)
02090 FOR j=INT(SQR(-c*d*a*f)) TO 1 STEP -1
02091 IF INT(SQR(-c*d*a*f)/j)=SQR(-c*d*a*f)/j AND GCD(-a*f,j)><1 THEN GOTO 02094
02092 IF INT(SQR(-c*d*a*f)/j)=SQR(-c*d*a*f)/j AND GCD(-a*f,j)=1 AND a*f><1 THEN GOTO 02096
02093 IF INT(SQR(-c*d*a*f)/j)=SQR(-c*d*a*f)/j AND GCD(-a*f,j)=1 AND a*f=1 THEN GOTO 02098
02094 PRINT "x(1)=-";j/GCD(-a*f,j);"/";-a*f/GCD(-a*f,j);"√";(-c*d*a*f/(j^2));",";"x(2)=";j/GCD(-a*f,j);"/";-a*f/GCD(-a*f,j);"√";(-c*d*a*f/(j^2))
02095 GOTO 02100
02096 PRINT "x(1)=-";j;"/";-a*f;"√";(-c*d*a*f/(j^2));",";"x(2)=";j;"/";-a*f;"√";(-c*d*a*f/(j^2))
02097 GOTO 02100
02098 PRINT "x(1)=-";j/(-a*f);"√";(-c*d*a*f/(j^2));",";"x(2)=";j/(-a*f);"√";(-c*d*a*f/(j^2))
02099 GOTO 02100
02100 NEXT j
02101 GOTO 20000

!(4)a*f<0 AND c*d<0
!x(1)=-i*SQR(c*d/a*f),x(2)=i*SQR(c*d/a*f)
!x(1)=-i*SQR(c*d*a*f/(a^2*f^2)),x(2)=i*SQR(c*d*a*f/(a^2*f^2))
!x(1)=-i*SQR(c*d*a*f)/(-a*f),x(2)=i*SQR(c*d*a*f)/(-a*f)
02110 FOR j=INT(SQR(c*d*a*f)) TO 1 STEP -1
02111 IF INT(SQR(c*d*a*f)/j)=SQR(c*d*a*f)/j AND GCD(-a*f,j)><1 THEN GOTO 02114
02112 IF INT(SQR(c*d*a*f)/j)=SQR(c*d*a*f)/j AND GCD(-a*f,j)=1 AND a*f><1 THEN GOTO 02116
02113 IF INT(SQR(c*d*a*f)/j)=SQR(c*d*a*f)/j AND GCD(-a*f,j)=1 AND a*f=1 THEN GOTO 02118
02114 PRINT "x(1)=-i*";j/GCD(-a*f,j);"/";-a*f/GCD(-a*f,j);"√";(c*d*a*f/(j^2));",";"x(2)=i*";j/GCD(-a*f,j);"/";-a*f/GCD(-a*f,j);"√";(c*d*a*f/(j^2))
02115 GOTO 02120
02116 PRINT "x(1)=-i*";j;"/";(-a*f);"√";(c*d*a*f/(j^2));",";"x(2)=i*";j;"/";(-a*f);"√";(c*d*a*f/(j^2))
02117 GOTO 02120
02118 PRINT "x(1)=-i*";j/(-a*f);"√";(c*d*a*f/(j^2));",";"x(2)=i*";j/(-a*f);"√";(c*d*a*f/(j^2))
02119 GOTO 02120
02120 NEXT j
02121 GOTO 20000

02385 GOTO 20000
02386 PRINT "x=";0;"(重解)"
02387 GOTO 20000
02388 IF INT(c/GCD(b,c))><int(b and="" b=""><1 THEN GOTO 02390
02389 IF INT(c/GCD(b,c))=INT(b/GCD(b,c)) OR INT(b/GCD(b,c))=1 THEN GOTO 02392
02390 PRINT "x=";-c/GCD(b,c);"/";b/GCD(b,c)
02391 GOTO 20000
02392 PRINT "x=";-c/b
02393 GOTO 20000
02394 PRINT "x=";0
02395 GOTO 20000
02396 PRINT c;"≠0で等号不成立により、不能。（解なし）"
02397 GOTO 20000
02398 PRINT 0;"＝0で、等号成立により、不定。"
02399 GOTO 20000
!!!!!
02400 LET y(1)=a*e*f !置き換え
02500 LET y(2)=b*d*f
02600 LET y(3)=c*d*e
02700 LET G=GCD(GCD(y(1),y(2)),y(3))
02750 LET a=y(1)/G
02800 LET b=y(2)/G
02850 LET c=y(3)/G
02900 GOTO 03000 !【３】判別式分岐へ

03000 !【３】判別式分岐
03100 LET D=b^2-4*a*c !D＝平方数
03200 IF D>0 THEN GOTO 04000 !【４】実数解のときの平方数分岐
03250 IF D=0 THEN GOTO 04300
03300 IF D<0 THEN GOTO 03400
03400 LET D=-D
03500 GOTO 08000!【８】虚数解のときの分岐


04000 !【４】実数解のときの平方数分岐
04100 IF INT(SQR(D))=SQR(D) THEN GOTO 05000!【５】!実数解のときのD＝平方数のときの解
04200 IF INT(SQR(D))><sqr(d) br="" goto="" then="">04300 IF INT(b/GCD(b,2*a))><int(2*a a="" and=""><1 THEN GOTO 04500
04400 IF INT(b/GCD(b,2*a))=INT(2*a/GCD(b,2*a)) OR 2*a/GCD(b,2*a)=1 THEN GOTO 04700
04500 PRINT "x=";-b/GCD(b,2*a);"/";2*a/GCD(b,2*a);"(重解)"
04600 GOTO 20000
04700 PRINT "x=";-b/2/a;"(重解)"
04800 GOTO 20000

05000 !【５】実数解のときのD＝平方数のときの解
05100 LET x(1)=(-b-SQR(D))/(2*a)
05200 LET x(2)=(-b+SQR(D))/(2*a)
05300 PRINT "x(1)=";x(1)
05400 PRINT "x(2)=";x(2)
05500 GOTO 20000 !ENDへ

06000 !【６】実数解のときのD≠平方数のときの分岐
06100 FOR i=INT(SQR(D)) TO 1 STEP -1
06300 IF FP( D/(i^2))><0 THEN GOTO 06900 !iの探索を行うループ
06400 IF FP( D/(i^2))=0 THEN GOTO 06500 !除数分岐へ
!06410 IF i=GCD(2*a,i) THEN GOTO 06450
!06420 IF i><gcd(2*a,i) 06500="" br="" goto="" then=""> !06450 PRINT "x(1)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"-";"√";D/(i^2);"/";(2*a)/i
!06460 PRINT "x(2)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"+";"√";D/(i^2);"/";(2*a)/i
!06470 PRINT "⇔"
!06480 GOTO 06900
06500 PRINT "x(1)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"-";i/GCD(2*a,i);"/";(2*a)/GCD(2*a,i);"√";D/(i^2)
06600 PRINT "x(2)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"+";i/GCD(2*a,i);"/";(2*a)/GCD(2*a,i);"√";D/(i^2)
06700 PRINT "⇔"
06900 NEXT i
07000 PRINT"これが解です。"
07100 GOTO 20000 !ENDへ

08000 !【８】虚数解のときの平方数分岐
08100 IF INT(SQR(D))=SQR(D) THEN GOTO 09000!【９】!虚数解のときの-D＝平方数のときの解
08200 IF INT(SQR(D))><sqr(d) br="" goto="" then="">
09000 !【９】虚数解のときの-D＝平方数のときの解
09100 LET x(1)=(-b-SQR(D))/(2*a)
09200 LET x(2)=(-b+SQR(D))/(2*a)
09300 PRINT "x(1)=";x(1)
09400 PRINT "x(2)=";x(2)
09500 GOTO 20000 !ENDへ

10000 !【１０】虚数解のときの-D≠平方数のときの分岐
10100 FOR i=INT(SQR(D)) TO 1 STEP -1
10300 IF FP( D/(i^2))><0 THEN GOTO 10900 !iの探索を行うループ
10400 IF FP( D/(i^2))=0 THEN GOTO 10500 !除数分岐へ
!10410 IF i=GCD(2*a,i) THEN GOTO 10450
!10420 IF i=GCD(2*a,i) THEN GOTO 10500
!10450 PRINT "x(1)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"-ｉ*";"√";D/(i^2);"/";(2*a)/i
!10460 PRINT "x(2)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"+ｉ*";"√";D/(i^2);"/";(2*a)/i
!10470 PRINT "⇔"
!10480 GOTO 10900
10500 PRINT "x(1)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"-ｉ*";i/GCD(2*a,i);"/";(2*a)/GCD(2*a,i);"√";D/(i^2)
10600 PRINT "x(2)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"+ｉ*";i/GCD(2*a,i);"/";(2*a)/GCD(2*a,i);"√";D/(i^2)
10700 PRINT "⇔"
10900 NEXT i
11000 PRINT"これが解です。"
12000 GOTO 20000 !ENDへ
13000 PRINT TIME-t0;"秒かかりました。"
14000 GOTO 20000 !ENDへ
20000 END

30000 EXTERNAL FUNCTION GCD(a,b)
30100 DO
30200 LET r=MOD(a,b)
30300 IF r=0 THEN EXIT DO
30400 LET a=b
30500 LET b=r
30600 LOOP
30700 LET GCD=b
30800 END FUNCTION

!nu 2012/01/29/06:26</sqr(d)></gcd(2*a,i)></int(2*a></sqr(d)></int(b></int(a> 		 

二次方程式を解く1/2(全2/2)

 投稿者：nuﾒｰﾙ  投稿日：2012年 1月29日(日)07時18分1秒
  !1/2
!----------------------------------------------------------------------
!二次方程式を解くためのプログラム
!根はわざと開かないような仕様にいたしました。
!----------------------------------------------------------------------
00500 DECLARE EXTERNAL FUNCTION GCD
01000 !【１】配列
01100 DIM x(2)
01200 DIM y(3)
01300 GOTO 02000 !【２】代入へ

02000 !【２】代入
02001 PRINT "「二次方程式の解を計算します。"
02002 PRINT "  a/d*x^2 + b/e*x + c/f = 0 の形式で、"
02003 PRINT "  a,b,c,d,e,fの順序で入力してください。」"
02004 PRINT "  <例> a*x^2 + b*x + c = 0 のとき、"
02005 PRINT "       a,b,c,1,1,1と入力します。"
02006 INPUT a,b,c,d,e,f
02007 PRINT "a,b,c,d,e,f"
02008 PRINT "(";a;")";"/";"(";d;")";"x^2+";"(";b;")";"/";"(";e;")";"x+";"(";c;")";"/";"(";f;")";"=0"
02009 LET t0=TIME

02010 IF d*e*f=0 THEN GOTO 02398
02011 IF d*e*f><0 THEN GOTO 02013
02012
02013 IF a*b*c*d*e*f><0 THEN GOTO 02400
02014 IF d*e*f><0 AND a><0 AND b><0 AND c=0 THEN GOTO 02040
02015 IF d*e*f><0 AND a><0 AND b=0 AND c><0 THEN GOTO 02046
02016 IF d*e*f><0 AND a><0 AND b=0 AND c=0 THEN GOTO 02386
02017 IF d*e*f><0 AND a=0 AND b><0 AND c><0 THEN GOTO 02388
02018 IF d*e*f><0 AND a=0 AND b><0 AND c=0 THEN GOTO 02394
02019 IF d*e*f><0 AND a=0 AND b=0 AND c><0 THEN GOTO 02396
02020 IF d*e*f><0 AND a=0 AND b=0 AND c=0 THEN GOTO 02398

02040 IF INT(b/GCD(a,b))><INT(a/GCD(a,b)) AND INT(a/GCD(a,b))><1 THEN GOTO 02042
02041 IF INT(b/GCD(a,b))=INT(a/GCD(a,b)) OR INT(a/GCD(a,b))=1 THEN GOTO 02044
02042 PRINT "x(1)=";-b/GCD(a,b);"/";a/GCD(a,b);",";"x(2)=";0
02043 GOTO 20000
02044 PRINT "x(1)=";-b/a;",";"x(2)=";0
02045 GOTO 20000
02046 IF a*f>0 AND c*d>0 THEN GOTO 02050
02047 IF a*f>0 AND c*d<0 THEN GOTO 02070
02048 IF a*f<0 AND c*d>0 THEN GOTO 02090
02049 IF a*f<0 AND c*d<0 THEN GOTO 02110

!x(1)=-i*SQR(c*d/a*f),x(2)=i*SQR(c*d/a*f)
!(1)a*f>0 AND c*d>0
02050 FOR j=INT(SQR(c*d*a*f)) TO 1 STEP -1
02052    IF INT(SQR(c*d*a*f)/j)=SQR(c*d*a*f)/j AND GCD(a*f,j)><1 THEN GOTO 02055
02053    IF INT(SQR(c*d*a*f)/j)=SQR(c*d*a*f)/j AND GCD(a*f,j)=1 AND a*f><1 THEN GOTO 02057
02054    IF INT(SQR(c*d*a*f)/j)=SQR(c*d*a*f)/j AND GCD(a*f,j)=1 AND a*f=1 THEN GOTO 02059
02055    PRINT "x(1)=-i*";j/GCD(a*f,j);"/";a*f/GCD(a*f,j);"√";(c*d*a*f/(j^2));",";"x(2)=i*";j/GCD(a*f,j);"/";a*f/GCD(a*f,j);"√";(c*d*a*f/(j^2))
02056    GOTO 02061
02057    PRINT "x(1)=-i*";j;"/";a*f;"√";(c*d*a*f/(j^2));",";"x(2)=i*";j;"/";a*f;"√";(c*d*a*f/(j^2))
02058    GOTO 02061
02059    PRINT "x(1)=-i*";j/(a*f);"√";(c*d*a*f/(j^2));",";"x(2)=i*";j/(a*f);"√";(c*d*a*f/(j^2))
02060    GOTO 02061
02061 NEXT j
02062 GOTO 20000

!(2)a*f>0 AND c*d<0
      !x(1)=-SQR(-c*d/a*f),x(2)=SQR(-c*d/a*f)
      !x(1)=-SQR(-c*d*a*f/(a^2*f^2)),x(2)=SQR(-c*d*a*f/(a^2*f^2))
      !x(1)=-SQR(-c*d*a*f)/(a*f),x(2)=SQR(-c*d*a*f)/(a*f)
02070 FOR j=INT(SQR(-c*d*a*f)) TO 1 STEP -1
02071    IF INT(SQR(-c*d*a*f)/j)=SQR(-c*d*a*f)/j AND GCD(a*f,j)><1 THEN GOTO 02074
02072    IF INT(SQR(-c*d*a*f)/j)=SQR(-c*d*a*f)/j AND GCD(a*f,j)=1 AND a*f><1 THEN GOTO 02076
02073    IF INT(SQR(-c*d*a*f)/j)=SQR(-c*d*a*f)/j AND GCD(a*f,j)=1 AND a*f=1 THEN GOTO 02078
02074    PRINT "x(1)=-";j/GCD(a*f,j);"/";a*f/GCD(a*f,j);"√";(-c*d*a*f/(j^2));",";"x(2)=";j/GCD(a*f,j);"/";a*f/GCD(a*f,j);"√";(-c*d*a*f/(j^2))
02075    GOTO 02080
02076    PRINT "x(1)=-";j;"/";a*f;"√";(-c*d*a*f/(j^2));",";"x(2)=";j;"/";a*f;"√";(-c*d*a*f/(j^2))
02077    GOTO 02080
02078    PRINT "x(1)=-";j/(a*f);"√";(-c*d*a*f/(j^2));",";"x(2)=";j/(a*f);"√";(-c*d*a*f/(j^2))
02079    GOTO 02080
02080 NEXT j
02081 GOTO 20000

!(3)a*f<0 AND c*d>0
02090 FOR j=INT(SQR(-c*d*a*f)) TO 1 STEP -1
02091    IF INT(SQR(-c*d*a*f)/j)=SQR(-c*d*a*f)/j AND GCD(-a*f,j)><1 THEN GOTO 02094
02092    IF INT(SQR(-c*d*a*f)/j)=SQR(-c*d*a*f)/j AND GCD(-a*f,j)=1 AND a*f><1 THEN GOTO 02096
02093    IF INT(SQR(-c*d*a*f)/j)=SQR(-c*d*a*f)/j AND GCD(-a*f,j)=1 AND a*f=1 THEN GOTO 02098
02094    PRINT "x(1)=-";j/GCD(-a*f,j);"/";-a*f/GCD(-a*f,j);"√";(-c*d*a*f/(j^2));",";"x(2)=";j/GCD(-a*f,j);"/";-a*f/GCD(-a*f,j);"√";(-c*d*a*f/(j^2))
02095    GOTO 02100
02096    PRINT "x(1)=-";j;"/";-a*f;"√";(-c*d*a*f/(j^2));",";"x(2)=";j;"/";-a*f;"√";(-c*d*a*f/(j^2))
02097    GOTO 02100
02098    PRINT "x(1)=-";j/(-a*f);"√";(-c*d*a*f/(j^2));",";"x(2)=";j/(-a*f);"√";(-c*d*a*f/(j^2))
02099    GOTO 02100
02100 NEXT j
02101 GOTO 20000

!(4)a*f<0 AND c*d<0
02110 FOR j=INT(SQR(c*d*a*f)) TO 1 STEP -1
02111    IF INT(SQR(c*d*a*f)/j)=SQR(c*d*a*f)/j AND GCD(-a*f,j)><1 THEN GOTO 02114
02112    IF INT(SQR(c*d*a*f)/j)=SQR(c*d*a*f)/j AND GCD(-a*f,j)=1 AND a*f><1 THEN GOTO 02116
02113    IF INT(SQR(c*d*a*f)/j)=SQR(c*d*a*f)/j AND GCD(-a*f,j)=1 AND a*f=1 THEN GOTO 02118
02114    PRINT "x(1)=-i*";j/GCD(-a*f,j);"/";-a*f/GCD(-a*f,j);"√";(c*d*a*f/(j^2));",";"x(2)=i*";j/GCD(-a*f,j);"/";-a*f/GCD(-a*f,j);"√";(c*d*a*f/(j^2))
02115    GOTO 02120
02116    PRINT "x(1)=-i*";j;"/";(-a*f);"√";(c*d*a*f/(j^2));",";"x(2)=i*";j;"/";(-a*f);"√";(c*d*a*f/(j^2))
02117    GOTO 02120
02118    PRINT "x(1)=-i*";j/(-a*f);"√";(c*d*a*f/(j^2));",";"x(2)=i*";j/(-a*f);"√";(c*d*a*f/(j^2))
02119    GOTO 02120
02120 NEXT j
02121 GOTO 20000

02385 GOTO 20000
02386 PRINT "x=";0;"(重解)"
02387 GOTO 20000
02388 IF INT(c/GCD(b,c))><INT(b/GCD(b,c)) AND INT(b/GCD(b,c))><1 THEN GOTO 02390
02389 IF INT(c/GCD(b,c))=INT(b/GCD(b,c)) OR INT(b/GCD(b,c))=1 THEN GOTO 02392
02390 PRINT "x=";-c/GCD(b,c);"/";b/GCD(b,c)
02391 GOTO 20000
02392 PRINT "x=";-c/b
02393 GOTO 20000
02394 PRINT "x=";0
02395 GOTO 20000
02396 PRINT c;"≠0で等号不成立により、不能。（解なし）"
02397 GOTO 20000
02398 PRINT 0;"＝0で、等号成立により、不定。"
02399 GOTO 20000
      !!!!!
02400 LET y(1)=a*e*f !置き換え
02500 LET y(2)=b*d*f
02600 LET y(3)=c*d*e
02700 LET G=GCD(GCD(y(1),y(2)),y(3))
02750 LET a=y(1)/G
02800 LET b=y(2)/G
02850 LET c=y(3)/G
02900 GOTO 03000 !【３】判別式分岐へ
 		 

二次方程式を解く2/2(全2/2)

 投稿者：nuﾒｰﾙ  投稿日：2012年 1月29日(日)07時19分41秒
  !2/2

03000 !【３】判別式分岐
03100 LET D=b^2-4*a*c !D＝平方数
03200 IF D>0 THEN GOTO 04000 !【４】実数解のときの平方数分岐
03250 IF D=0 THEN GOTO 04300
03300 IF D<0 THEN GOTO 03400
03400 LET D=-D
03500 GOTO 08000!【８】虚数解のときの分岐

04000 !【４】実数解のときの平方数分岐
04100 IF INT(SQR(D))=SQR(D) THEN GOTO 05000 !【５】実数解のときのD＝平方数のときの解
04200 IF INT(SQR(D))><SQR(D) THEN GOTO 06000 !【６】実数解のときのD≠平方数のときの分岐
04300 IF INT(b/GCD(b,2*a))><INT(2*a/GCD(b,2*a)) AND 2*a/GCD(b,2*a)><1 THEN GOTO 04500
04400 IF INT(b/GCD(b,2*a))=INT(2*a/GCD(b,2*a)) OR 2*a/GCD(b,2*a)=1 THEN GOTO 04700
04500 PRINT "x=";-b/GCD(b,2*a);"/";2*a/GCD(b,2*a);"(重解)"
04600 GOTO 20000
04700 PRINT "x=";-b/2/a;"(重解)"
04800 GOTO 20000

05000 !【５】実数解のときのD＝平方数のときの解
05100 LET x(1)=(-b-SQR(D))/(2*a)
05200 LET x(2)=(-b+SQR(D))/(2*a)
05300 PRINT "x(1)=";x(1)
05400 PRINT "x(2)=";x(2)
05500 GOTO 20000 !ENDへ

06000 !【６】実数解のときのD≠平方数のときの分岐
06100 FOR i=INT(SQR(D)) TO 1 STEP -1
06300    IF FP( D/(i^2))><0 THEN GOTO 06900 !iの探索を行うループ
06400    IF FP( D/(i^2))=0 THEN GOTO 06500 !除数分岐へ
         !06410    IF i=GCD(2*a,i) THEN GOTO 06450
         !06420    IF i><GCD(2*a,i) THEN GOTO 06500
         !06450    PRINT "x(1)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"-";"√";D/(i^2);"/";(2*a)/i
         !06460    PRINT "x(2)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"+";"√";D/(i^2);"/";(2*a)/i
         !06470    PRINT "⇔"
         !06480    GOTO 06900
06500    PRINT "x(1)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"-";i/GCD(2*a,i);"/";(2*a)/GCD(2*a,i);"√";D/(i^2)
06600    PRINT "x(2)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"+";i/GCD(2*a,i);"/";(2*a)/GCD(2*a,i);"√";D/(i^2)
06700    PRINT "⇔"
06900 NEXT i
07000 PRINT"これが解です。"
07100 GOTO 20000 !ENDへ

08000 !【８】虚数解のときの平方数分岐
08100 IF INT(SQR(D))=SQR(D) THEN GOTO 09000 !【９】虚数解のときの-D＝平方数のときの解
08200 IF INT(SQR(D))><SQR(D) THEN GOTO 10000 !【１０】虚数解のときの-D≠平方数のときの分岐

09000 !【９】虚数解のときの-D＝平方数のときの解
09100 LET x(1)=(-b-SQR(D))/(2*a)
09200 LET x(2)=(-b+SQR(D))/(2*a)
09300 PRINT "x(1)=";x(1)
09400 PRINT "x(2)=";x(2)
09500 GOTO 20000 !ENDへ

10000 !【１０】虚数解のときの-D≠平方数のときの分岐
10100 FOR i=INT(SQR(D)) TO 1 STEP -1
10300    IF FP( D/(i^2))><0 THEN GOTO 10900 !iの探索を行うループ
10400    IF FP( D/(i^2))=0 THEN GOTO 10500 !除数分岐へ
         !10410    IF i=GCD(2*a,i) THEN GOTO 10450
         !10420    IF i=GCD(2*a,i) THEN GOTO 10500
         !10450    PRINT "x(1)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"-ｉ*";"√";D/(i^2);"/";(2*a)/i
         !10460    PRINT "x(2)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"+ｉ*";"√";D/(i^2);"/";(2*a)/i
         !10470    PRINT "⇔"
         !10480    GOTO 10900
10500    PRINT "x(1)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"-ｉ*";i/GCD(2*a,i);"/";(2*a)/GCD(2*a,i);"√";D/(i^2)
10600    PRINT "x(2)=";-b/GCD(2*a,b);"/";2*a/GCD(2*a,b);"+ｉ*";i/GCD(2*a,i);"/";(2*a)/GCD(2*a,i);"√";D/(i^2)
10700    PRINT "⇔"
10900 NEXT i
11000 PRINT"これが解です。"
12000 GOTO 20000 !ENDへ
13000 PRINT TIME-t0;"秒かかりました。"
14000 GOTO 20000 !ENDへ
20000 END

30000 EXTERNAL FUNCTION GCD(a,b)
30100 DO
30200    LET r=MOD(a,b)
30300    IF r=0 THEN EXIT DO
30400    LET a=b
30500    LET b=r
30600 LOOP
30700 LET GCD=b
30800 END FUNCTION 		 

Re: 二次方程式の解

 投稿者：山中和義  投稿日：2012年 1月29日(日)11時04分56秒
  > No.1740[元記事へ]

nuさんへのお返事です。

整数係数の2次方程式を解くプログラムをベースに考えてみました。
a,b,c,d,e,fがP,Q,Rになるので、すっきりします。


!有理係数の2次方程式(a/d)x^2+(b/e)x+(c/f)=0、d,e,f≠0とすると、
!分母をはらって、(aef)x^2+(bdf)x+(cde)=0
!
!整数係数の2次方程式Ax^2+Bx+C=0とすると、
!　判別式D=B^2-4AC
!　解の公式より、x={-B/(2A)}±{√D/(2A)}
!となるので、
!これを適用する。

LET a=12 !12/45
LET b=23 !23/56
LET c=34 !34/67
LET d=45
LET e=56
LET f=67
LET P=a*e*f
LET Q=b*d*f
LET R=c*d*e
CALL Solve2Equ(P,Q,R)

LET a=1 !x^2-3x+2=(x-1)(x-2)
LET b=-3
LET c=2
LET d=1
LET e=1
LET f=1
LET P=a*e*f
LET Q=b*d*f
LET R=c*d*e
CALL Solve2Equ(P,Q,R)

LET A=-1 !-x^2+x+1
LET B=1
LET C=1
LET d=1
LET e=1
LET f=1
LET P=a*e*f
LET Q=b*d*f
LET R=c*d*e
CALL Solve2Equ(P,Q,R)

LET A=1 !x^2+1=(x+i)(x-i)
LET B=0
LET C=1
LET d=1
LET e=1
LET f=1
LET P=a*e*f
LET Q=b*d*f
LET R=c*d*e
CALL Solve2Equ(P,Q,R)

LET A=2 !2x^2-2=2(x+1)(x-1)
LET B=0
LET C=-2
LET d=1
LET e=1
LET f=1
LET P=a*e*f
LET Q=b*d*f
LET R=c*d*e
CALL Solve2Equ(P,Q,R)

LET A=1 !x^2-4x+4=(x-2)^2
LET B=-4
LET C=4
LET d=1
LET e=1
LET f=1
LET P=a*e*f
LET Q=b*d*f
LET R=c*d*e
CALL Solve2Equ(P,Q,R)

LET A=0 !(1/2)x+3/4
LET B=1
LET C=3
LET d=1
LET e=2
LET f=4
LET P=a*e*f
LET Q=b*d*f
LET R=c*d*e
CALL Solve2Equ(P,Q,R)

LET A=0 !2/3
LET B=0
LET C=2
LET d=1
LET e=1
LET f=3
LET P=a*e*f
LET Q=b*d*f
LET R=c*d*e
CALL Solve2Equ(P,Q,R)

END


EXTERNAL SUB Solve2Equ(A,B,C) !整数係数の2次方程式Ax^2+Bx+C=0を解く
IF A=0 THEN !1次方程式 Bx+C=0
   IF B=0 THEN !C=0
      PRINT "方程式が成立しません。"; A;B;C
   ELSE
      PRINT "x= ";
      CALL RtPrint(-C,B) !x=-C/B
      PRINT
   END IF

ELSE
   PRINT "x= ";

   LET D=B^2-4*A*C !判別式　※平方根の中
   CALL SqNormalize(ABS(D),P,Q) !√D=P√Qと変形する
   IF D>0 AND Q=1 THEN !平方根の中が平方数なら、m形
      CALL RtPrint(-B-P,2*A) !1つの有理数解 x=(-B-P)/(2*A)
      PRINT ", ";
      CALL RtPrint(-B+P,2*A) !もう1つの有理数解 x=(-B+P)/(2*A)

   ELSE !m±√n形
      IF D=0 THEN !判別式D=0なら
         CALL RtPrint(-B,2*A)
         PRINT "（重根）";
      ELSE
         IF B<>0 THEN CALL RtPrint(-B,2*A) !有理数部（実部）-B/(2*A)

         PRINT "± ";

         LET S=P !平方根部（虚部）P√Q
         LET T=2*A
         CALL RtNormalize(S,T)

         IF D<0 THEN
            PRINT "i "; !虚数単位
            IF NOT(S=1 AND T=1 AND Q=1) THEN PRINT "* "; !虚数単位
         END IF

         IF S>1 THEN PRINT S; !１サプレス
         IF Q>1 THEN PRINT "√("; Q; ") ";
         IF T>1 THEN PRINT "/"; T; !１サプレス

      END IF

   END IF
   PRINT

END IF
END SUB


EXTERNAL SUB SqNormalize(n, p,q) !平方根の中をできるだけ小さな正の整数に直す
!※n=p^2*q、n,p,q≧0とすると、SQR(n)=p*SQR(q)と変形できる。
LET q=1 !※SQR(0)=0*SQR(1)とする　※n=0なら、１行下のFOR文でp=0は設定される
FOR p=INT(SQR(n)) TO 1 STEP -1 !約数p^2の候補を大きい方から
   LET q=n/p^2
   IF q=INT(q) THEN EXIT FOR !qは自然数より
NEXT p
END SUB


EXTERNAL SUB RtNormalize(U,V) !分数U/Vを既約分数U'/V'にする　※符号は分子へ
IF V<0 THEN !符号は分子へ
   LET U=-U
   LET V=-V
END IF
LET G=gcd(ABS(U),V)
LET U=U/G
LET V=V/G
END SUB


EXTERNAL SUB RtPrint(U,V) !分数U/Vを既約分数として表示する
CALL RtNormalize(U,V)
PRINT U;
IF V>1 THEN PRINT "/"; V; !１サプレス
END SUB


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: 二次方程式の解

 投稿者：nuﾒｰﾙ  投稿日：2012年 1月29日(日)17時29分3秒
  > No.1743[元記事へ]

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

山中和義　様

お便りいただきありがとうございます。
今度、拡張にも挑戦したいです。
Mathematicaに触発されて、こういうプログラムはないかなと思って組んだ次第です。
お体に気をつけて、これからもご指導ください。

un 		 

Re: 二次方程式の解（訂正再送）

 投稿者：nuﾒｰﾙ  投稿日：2012年 1月29日(日)17時41分9秒
  > No.1743[元記事へ]

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

山中和義　様

お便りいただきありがとうございます。
今度、拡張にも挑戦したいです。
Mathematicaに触発されて、こういうプログラムはないかなと思って組んだ次第です。
お体に気をつけて、これからもご指導ください。

unもといnu m(;- -;)m 		 

ランダム設問、ランダム選択肢

 投稿者：nuﾒｰﾙ  投稿日：2012年 1月31日(火)15時53分31秒
  !いつも楽しく拝見しております。
!また、処理にてこずりまして、ランダム選択肢、ランダム設問まではうまくいきました。
!ただ、どういうわけか、正解を選んでも"間違いです。"の後で"正解です。"が出力され、
!また、明らかに誤答を選んでも、正解になったりするなど、納得がいきません。
!できれば、
!(1)別の外部記憶装置から、問題・回答ファイルを出力
!(2)別ファイルに入力して答案を作成
!(3)答案の採点
!(4)統計解析
!まで行いたいです。
!お分かりになる方、御指導くださるようお願いします。
!Microsoft Basic　互換モードで動作します。
!下の!問題集に自分で作成した問題、回答を入力、
!ランダム設問、ランダム選択肢が出題されます。
!----------------------------------------------------------------
1000 DIM A$(10,10),Q(10),ANS(10)
1010 cls 3
1020 RANDOMIZE
1030 LET Q(1)=INT(RND*2+1)
1040 LET Q(2)=INT(RND*2+1)
1050 IF Q(2)><Q(1) THEN GOTO 1070
1060 IF Q(2)=Q(1) THEN GOTO 1040

1070 GOSUB 1190
1080  FOR i=1 TO 2
1090  h=Q(i)
1100    PRINT A$(h,0)
1110    PRINT " 1.";A$(h,1);" 2.";A$(h,2);" 3.";A$(h,3);" 4.";A$(h,4)
1120    INPUT B
1130    IF B=ANS(h) THEN GOSUB 1160
1140    IF B><ANS(h) THEN GOSUB 1150
1150    PRINT A$(0,0)&A$(h,0)
1160    PRINT A$(0,1)
1170    NEXT i
1180 END

1190 RANDOMIZE
1200 LET AA=INT(RND*4)+1
1210 LET AB=INT(RND*4)+1
1220 IF AA><AB THEN GOTO 1240
1230 IF AA=AB THEN GOTO 1210
1240 LET AC=INT(RND*4)+1
1250 IF AC><AA AND AC><AB THEN GOTO 1270
1260 IF AC=AA OR AC=AB THEN GOTO 1240
1270 LET AD=INT(RND*4)+1
1280 IF AD><AA AND AD><AB AND AD><AC THEN GOTO 1300
1290 IF AD=AA OR AD=AB OR AD=AC THEN GOTO 1270
1300 !問題集
1310 LET A$(0,0)="間違いです。"
1320 LET A$(0,1)="正解です。"
1330 LET A$(1,0)="何を持っていますか?"
1340 LET A$(1,AA)="do":A$(1,AB)="What":A$(1,AC)="you":A$(1,AD)="have":ANS(1)=ABAAACAD
1350 LET A$(2,AA)="Coke":A$(2,AB)="feel":A$(2,AC)="I":A$(2,AD)="*":ANS(2)=ACABAA
1360 LET A$(2,0)="コーラが飲みたい。"
1370 RETURN
!おっくうの教材作成日記
!http://plaza.rakuten.co.jp/printsoft/diary/201004200000/
!を参考にして作成。

nu 		 

Re: ランダム設問、ランダム選択肢

 投稿者：nuﾒｰﾙ  投稿日：2012年 1月31日(火)21時48分51秒
  !首都名クイズです。
!Microsoft BASIC互換モードで動作します。
0010 OPTION BASE 0
0020 DIM A$(2,3),B$(2,3)
0021 RANDOMIZE
0022 LET Q(1)=INT(RND*2+1)
0023 LET Q(2)=INT(RND*2+1)
0024 IF Q(2)=Q(1) THEN GOTO 0023
0025 IF Q(2)><Q(1) THEN GOTO 0030

0030 GOSUB 0170
0040 FOR i=1 TO 2
0041 LET h=Q(i)
0050    PRINT "1."&A$(h,j)
0060    PRINT "2."&A$(h,k)
0070    PRINT "3."&A$(h,l)
0080    PRINT "全角カタカナで「,」(コンマ)で区切って入力してください。"
0085    PRINT "＜例＞サンチャゴ,ペキン,トウキョウ"
0090    INPUT C$,D$,E$
0100    IF C$><B$(h,j) OR D$><B$(h,k) OR E$><B$(h,l) THEN GOTO 0090
0110    IF C$=B$(h,j) AND D$=B$(h,k) AND E$=B$(h,l) THEN GOTO 0120
0111    ! IF j=1 OR k=1 OR l=1 OR C$(1)="ワシントンD.C." OR C$(2)="ワシントンD.C." OR C$(3)="ワシントンD.C." THEN GOTO 0120
0120    PRINT "正解"
0130    PRINT "1."&A$(h,j);B$(h,j)
0140    PRINT "2."&A$(h,k);B$(h,k)
0150    PRINT "3."&A$(h,l);B$(h,l)
0160 NEXT i
END

0170 RANDOMIZE
0180 LET j=INT(RND*3+1)
0190 LET k=INT(RND*3+1)
0200 IF k=j THEN GOTO 0190
0210 IF k><j THEN GOTO 0220
0220 LET l=INT(RND*3+1)
0230 IF l=k OR l=j THEN GOTO 0220
0240 IF l><k AND l><k THEN GOTO 0250
0250 LET A$(1,1)="アメリカの首都はどこか。":A$(1,2)="イタリアの首都はどこか。":A$(1,3)="フランスの首都はどこか。":B$(1,1)="ワシントン":B$(1,2)="ローマ":B$(1,3)="パリ"
0260 LET A$(2,1)="マルタの首都はどこか。":A$(2,2)="ハンガリーの首都はどこか。":A$(2,3)="ブルガリアの首都はどこか。":B$(2,1)="バレッタ":B$(2,2)="ブダペスト":B$(2,3)="ソフィア"
0270 RETURN
!いくつかの文章をランダムに、改行した状態で表示させる方法　を参考にして作成しました。
!http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1374685968
!nu 		 

Re: ランダム設問、ランダム選択肢

 投稿者：nuﾒｰﾙ  投稿日：2012年 2月 2日(木)05時17分16秒
  > No.1747[元記事へ]

投稿できないと思い、あせりました。
利用方法を見て、納得です。
!Microsoft Basic　互換モードで動作します。
!下の!問題集に自分で作成した問題、回答を入力、
!ランダム設問、ランダム選択肢が出題されます。
!----------------------------------------------------------------
!並べかえがやっとできました。
!(1)別の外部記憶装置から、問題・回答ファイルを出力
!(2)別ファイルに入力して答案を作成
!(3)答案の採点
!(4)統計解析
!まで行いたいです。
!----------------------------------------------------------------
!【配列宣言】
!WRD$(10,10):これから並べかえる単語
!QTN(10):問題番号
!ANS(10,10):正解の順番の単語
!RES(10,10):回答された順番の単語
001000 OPTION BASE 0
001100 DIM WRD$(10,10),QTN(10),ANS(10,10),RES(10,10)
001200 RANDOMIZE
001300 LET QTN(1)=INT(RND*2)+1
001400 LET QTN(2)=INT(RND*2)+1
001500 IF QTN(2)=QTN(1) THEN GOTO 001400
001600 IF QTN(2)><QTN(1) THEN GOTO 010000

010000 GOSUB 018900
010100 FOR i=1 TO 2
010200    LET h=QTN(i)
010300    PRINT WRD$(h,5)
010400    PRINT " 1."&WRD$(h,A)&" 2."&WRD$(h,B)&" 3."&WRD$(h,C)&" 4."&WRD$(h,D)
010500    INPUT RES(h,1),RES(h,2),RES(h,3),RES(h,4)
010600    IF RES(h,1)><ANS(h,1) OR RES(h,2)><ANS(h,2) OR RES(h,3)><ANS(h,3) OR RES(h,4)><ANS(h,4) THEN GOTO 010500
010700    IF RES(h,1)=ANS(h,1) AND RES(h,2)=ANS(h,2) AND RES(h,3)=ANS(h,3) AND RES(h,4)=ANS(h,4) THEN GOTO 010800
010800    PRINT "正解です。"
010900    PRINT RES(h,1);RES(h,2);RES(h,3);RES(h,4)
010950    GOSUB 018900
011000 NEXT i
011100 END
! 4語の問題集
018900 RANDOMIZE
019000 LET A=INT(RND*4)+1
019100 LET B=INT(RND*4)+1
019200 IF B><A THEN GOTO 019400
019300 IF B=A THEN GOTO 019100
019400 LET C=INT(RND*4)+1
019500 IF C><A AND C><B THEN GOTO 019700
019600 IF C=A OR C=B THEN GOTO 019400
019700 LET D=INT(RND*4)+1
019800 IF D><A AND D><B AND D><C THEN GOTO 020000
019900 IF D=A OR D=B OR D=C THEN GOTO 019700
020000 LET WRD$(1,5)="何を持っていますか?":WRD$(1,1)="What":WRD$(1,2)="do":WRD$(1,3)="you":WRD$(1,4)="have":ANS(1,A)=1:ANS(1,B)=2:ANS(1,C)=3:ANS(1,D)=4
020100 LET WRD$(2,5)="何処を飛んでいますか?":WRD$(2,1)="Where":WRD$(2,2)="do":WRD$(2,3)="you":WRD$(2,4)="fly":ANS(2,A)=1:ANS(2,B)=2:ANS(2,C)=3:ANS(2,D)=4
020200 RETURN
! おっくうの教材作成日記
! http://plaza.rakuten.co.jp/printsoft/diary/201004200000/
! を参考にして作成。
nu 201202020615

http://

  

Re: ランダム設問、ランダム選択肢

 投稿者：山中和義  投稿日：2012年 2月 2日(木)13時07分54秒
  > No.1748[元記事へ]

nuさんへのお返事です。

問題集の書式を検討してみました。


1000 !n語の問題集
1010 RANDOMIZE !毎回異なるようにする
1020
1030 LET C=0 !正解数
1040
1050 DIM Q(100),W$(10),A(10) !問題、語彙、答え
1060
1070 READ M !問題の個数
1080 CALL shuffle(M,Q) !シャッフルする
1090
1100 FOR i=1 TO M
1110    RESTORE 7010
1120    FOR k=1 TO Q(i)
1130       READ Q$ !質問文
1140       READ N !n語
1150       FOR j=1 TO N !語彙
1160          READ W$(j)
1170       NEXT j
1180    NEXT k
1190    PRINT Q$ !問題文を表示する
1200
1210    CALL shuffle(N,A) !シャッフルする
1220
1230    LET ANS=0 !n進法の数値へ
1240    FOR j=1 TO N !語彙を表示する
1250       PRINT STR$(j); ") "; W$(A(j))
1260       LET ANS=ANS+(j-1)*N^(N-A(j))
1270    NEXT j
1280
1290    PRINT "正しい順に語彙を並べなさい。"
1300    PRINT "番号を順に入力してください。　例. 2314"
1310    INPUT PROMPT "？": T
1320    LET S=0
1330    FOR j=1 TO N !10進法n桁をn進法n桁へ
1340       LET S=S+(MOD(T,10)-1)*N^(j-1)
1350       LET T=INT(T/10)
1360    NEXT j
1370    !!!PRINT S;ANS !debug
1380
1390
1400    IF S=ANS THEN !採点する
1410       LET C=C+1
1420       PRINT "正解です。"
1430    ELSE
1440       PRINT "誤りです。"
1450    END IF
1460    PRINT "正しい並びは、";
1470    FOR j=1 TO N
1480       PRINT W$(j); " ";
1490    NEXT j
1500    PRINT "です。"
1510
1520
1530    PRINT !次へ
1540 NEXT i
1550
1560 PRINT "正解率は、"; M;"問中"; C;"回です。"


7000 DATA 3 !問題の個数
7010 DATA "何を持っていますか?" !第1問
7020 DATA 4, "what","do","you","have"
7030 DATA "コーラが飲みたい。" !第2問
7040 DATA 3, "i","feel","coke"
7050 DATA "太陽から近い順に並べなさい。" !第3問
7060 DATA 6, "水星","金星","地球","火星","木星","土星"


9500 END

9510 EXTERNAL SUB shuffle(N,A()) !シャッフルする
9520 FOR i=1 TO N !数字を準備する
9530    LET A(i)=i
9540 NEXT i
9550 FOR i=N TO 2 STEP -1 !シャッフルする
9560    LET p=INT(RND*(i-1))+1 !左側 1～i-1
9570    IF i>2 THEN
9580       LET t=A(i) !右端iと交換する
9590       LET A(i)=A(p)
9600       LET A(p)=t
9610    ELSE !残り2枚の場合
9620       IF RND<0.5 THEN !1/2の確率で交換する
9630          LET t=A(i) !右端iと交換する
9640          LET A(i)=A(1)
9650          LET A(1)=t
9660       END IF
9670    END IF
9680 NEXT i
9690 END SUB

 		 

Re: ランダム設問、ランダム選択肢

 投稿者：nuﾒｰﾙ  投稿日：2012年 2月 3日(金)03時21分27秒
  > No.1749[元記事へ]

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

山中和義　様

お便りいただきありがとうございます。さらに発展していけそうな、励みになります。
後ほどどう発展できたか、ご報告いたします。
nu 		 

パズル　カークマン（Kirkman）女学生散歩問題

 投稿者：山中和義  投稿日：2012年 2月 3日(金)11時26分25秒
 
!カークマン（Kirkman）女学生散歩問題

!n人をk人ずつm個のグループに分けるとする。

LET N=6 !総人数
LET K=2 !グループ内人数

LET M=N/K !グループ数
PRINT N; M
IF M<>INT(M) THEN !整数　※必要条件
   PRINT "解なし"
   STOP
END IF

LET D=(N-1)/(K-1) !1を基準にして、k=3なら(1,2,3),(1,4,5),…,(1,n-1,n)のようなグループ分けできるか
PRINT D
IF D<>INT(D) THEN !整数　※必要条件
   PRINT "解なし"
   STOP
END IF

LET S=COMB(N-1,K-1) !(1,2),(1,3),…,(1,N)のような(1,…)形の個数
LET T=COMB(N,K) !グループ分けの総数
PRINT S; T


!日程表
!　n=6,k=2の場合、m=3
!　A():  ┌ m ┐
!　  ┌  1 10 15  ← t
!　  │  2  *  *
!　 d    3  *  *
!　  │  4  *  *
!　  └  5  *  *
!　      ↑  └ s＜x＜t, 10を除く。すなわち、6,7,8,9, 11,12,13,14
!　      s
!
!　ただし、d=(n-1)/(k-1)、s=C(n-1,k-1)、t=C(n,k)、数字1～tは、組合せ番号

DIM F(T) !日程表に埋める「組合せ番号」の使用状況　0:未使用、1:使用中
MAT F=ZER
DIM A(D*M) !日程表　d行m列

DIM Z(K) !「組合せ番号」に対応する「組合せパターン」
LET W=1
FOR i=1 TO T
   CALL Num2Comb(i-1, Z,N,K) !一覧を表示する
   PRINT STR$(i);": (";
   FOR j=1 TO K-1
      PRINT STR$(Z(j)); ",";
   NEXT j
   PRINT STR$(Z(j)); ")"


   IF Z(1)=1 THEN !日程表の１列目を埋める
      IF K=2 THEN !(1,2),(1,3),(1,4),…,(1,n-1),(1,n)のd個
         LET A((W-1)*M+1)=i
         LET F(i)=1
         LET W=W+1
      ELSE
         IF MOD(Z(2)-1,K-1)=1 THEN !(1,2,3),(1,3,4),(1,5,6),…,(1,n-1,n)のd個
            FOR j=2 TO K-1
               IF Z(j)+1<>Z(j+1) THEN EXIT FOR
            NEXT j
            IF j>K-1 THEN
               LET A((W-1)*M+1)=i
               LET F(i)=1
               LET W=W+1
            END IF
         END IF
      END IF
   END IF

   IF MOD(Z(1)-1,K)=0 THEN !日程表の１行目を埋める
      FOR j=1 TO K-1 !(1,2,3),(3,4,5),(6,7,8),…,(n-2,n-1,n)のm個
         IF Z(j)+1<>Z(j+1) THEN EXIT FOR
      NEXT j
      IF j>K-1 THEN
         LET A((Z(1)-1)/K+1)=i
         LET F(i)=1
      END IF
   END IF

NEXT i
MAT PRINT F; !debug
MAT PRINT A; !debug

PUBLIC NUMERIC C !解の数
LET C=0
CALL try(M+2,S,T,D,M,K,A,F) !2行目2列目から順に埋めていく

END


EXTERNAL SUB try(p,S,T,D,M,K,A(),F()) !バックトラック法で検索する
IF p>D*M THEN !すべて埋まったなら
   LET C=C+1 !結果を表示する
   PRINT "No.";C
   !!!MAT PRINT A; !debug
   FOR i=1 TO D*M !d行m列
      PRINT A(i);
      IF MOD(i,M)=0 THEN PRINT
   NEXT i

ELSE
   IF A(p)=0 THEN !未定義なら
      FOR i=S+1 TO T-1 !日程表に埋める「番号」の範囲
         IF i>A(p-1) THEN !並びは組合せとする

            IF F(i)=0 THEN !未使用なら
               LET F(i)=1
               LET A(p)=i

               LET N=K*M !同じ行で「グループ」を構成する「人」に重複がないか確認する
               DIM U(N),Z(K)
               MAT U=ZER !全体集合U={1,2,3,…,n}
               !!!PRINT INT((p-1)/M)*M+1; p !debug
               FOR j=INT((p-1)/M)*M+1 TO p
                  CALL Num2Comb(A(j)-1, Z,N,K) !※0～COMB(N,K)-1
                  !!!MAT PRINT Z; !debug
                  FOR L=1 TO K !部分集合{e1,e2,…,ek}
                     LET W=Z(L) !要素el
                     IF U(W)=1 THEN EXIT FOR !既に使用されているなら
                     LET U(W)=1
                  NEXT L
                  IF L<=K THEN EXIT FOR
               NEXT j
               IF j>p THEN !重複しないなら

                  CALL try(p+1,S,T,D,M,K,A,F) !次へ

               END IF

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

         END IF
      NEXT i

   ELSE !skip it
      CALL try(p+1,S,T,D,M,K,A,F)

   END IF

END IF
END SUB


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)を１とする
NEXT j
END SUB


実行結果

6  3
5
5  15
1: (1,2)
2: (1,3)
3: (1,4)
4: (1,5)
5: (1,6)
6: (2,3)
7: (2,4)
8: (2,5)
9: (2,6)
10: (3,4)
11: (3,5)
12: (3,6)
13: (4,5)
14: (4,6)
15: (5,6)
1  1  1  1  1  0  0  0  0  1  0  0  0  0  1

1  10  15  2  0  0  3  0  0  4  0  0  5  0  0

No. 1
1  10  15
2  8  14
3  9  11
4  7  12
5  6  13
No. 2
1  10  15
2  9  13
3  8  12
4  6  14
5  7  11

 		 

Re: パズル　カークマン（Kirkman）女学生散歩問題

 投稿者：山中和義  投稿日：2012年 2月 4日(土)13時43分28秒
  > No.1751[元記事へ]

日にちにおける「グループ分け」の候補


!カークマン（Kirkman）女学生散歩問題

!日にちにおける「グループ分け」の候補

!n人をk人ずつm個のグループに分けるとする。

LET K=2
LET M=3
LET N=K*M !N≦63

LET T=COMB(N,K) !候補の個数
PRINT T

DIM P(T) !グループ分けの候補
FOR i=1 TO T !全パターン
   CALL Num2CombBit(i-1,N,K,A) !番号は０～
   PRINT i; ":"; A; RIGHT$(REPEAT$("0",N)&BSTR$(A,2),N) !ビットパターン
   LET P(i)=A
NEXT i
MAT PRINT P;


DIM Z(M) !候補は、部分集合A1,A2,…,Atである。
CALL try(1,T,Z,M,K,N,P)

END

EXTERNAL SUB try(s,T,Z(),M,K,N,P()) !バックトラック法で検索する
FOR i=s TO T-(M-s) !組合せで考える　C(T,m)通り
   IF s=1 OR (s>1 AND i>Z(s-1)) THEN
      LET Z(s)=i

      LET U=P(Z(1)) !A1∪A2∪ … ∪Am=U（全体集合）、A1∩A2∩ … ∩Am=φ
      FOR j=2 TO s
         IF BITAND(U,P(Z(j)))<>0 THEN EXIT FOR !重複する要素が存在する
         LET U=BITOR(U,P(Z(j)))
      NEXT j
      IF j>s THEN !条件を満たすなら

         IF s=M THEN !全部揃ったら
            FOR x=1 TO M !結果を表示する
               PRINT "("; !1組(e1,e2,…,ek)
               LET W=P(Z(x))
               LET F=0
               FOR e=1 TO N !2進法n桁へ展開する
                  IF MOD(W,2)=1 THEN !ビットが1なら
                     IF F>0 THEN PRINT ",";
                     PRINT STR$(e);
                     LET F=1
                  END IF
                  LET W=INT(W/2) !次の桁へ
               NEXT e
               PRINT ")";
            NEXT x
            PRINT

         ELSE
            CALL try(s+1,T,Z,M,K,N,P) !次へ

         END IF

      END IF

   END IF
NEXT i
END SUB


EXTERNAL SUB Num2CombBit(h, N,R, A) !番号から組合せパターンを生成する　※辞書式順序
LET v=h+1
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^i !ビット位置iを１とする
      LET j=j-1
      LET v=v-t
   END IF
NEXT i
END SUB



実行結果

15
1 : 3 000011
2 : 5 000101
3 : 6 000110
4 : 9 001001
5 : 10 001010
6 : 12 001100
7 : 17 010001
8 : 18 010010
9 : 20 010100
10 : 24 011000
11 : 33 100001
12 : 34 100010
13 : 36 100100
14 : 40 101000
15 : 48 110000
3  5  6  9  10  12  17  18  20  24  33  34  36  40  48

(1,2)(3,4)(5,6)
(1,2)(3,5)(4,6)
(1,2)(4,5)(3,6)
(1,3)(2,4)(5,6)
(1,3)(2,5)(4,6)
(1,3)(4,5)(2,6)
(2,3)(1,4)(5,6)
(2,3)(1,5)(4,6)
(2,3)(4,5)(1,6)
(1,4)(2,5)(3,6)
(1,4)(3,5)(2,6)
(2,4)(1,5)(3,6)
(2,4)(3,5)(1,6)
(3,4)(1,5)(2,6)
(3,4)(2,5)(1,6)

 		 

パズルの解を求めて

 投稿者：GAI  投稿日：2012年 2月 6日(月)12時13分57秒
  知り合いから出題されたパズルで未だ解決できずに悶々としています。
力ずくで、コンピュータによる何らかのパターン調査ができたら解が見つかるかもと思い
お願いしています。



0:白　1:黒
に塗り分けた正方形のタイルがあることにする。
その全パターンは次の１６種類となり
（上下の見分けが付くように、印を付けておく。）


00  00  00  00
00  01  10  11

01  01  01  01
00  01  10  11

10  10  10  10
00  01  10  11

11  11  11  11
00  01  10  11


この１６枚のタイルを４×４の形に並べ替え（各タイルの上、下を守る。）
各行、各列の境の模様を同じにする。
しかも左端と右端が同じ、最上辺、最下辺が同じ（トーラスと同相）
模様になることまで満たすこと。



この条件を満たす配列を探すことをして頂きたいのですが・・・

 		 

Re: パズルの解を求めて

 投稿者：山中和義  投稿日：2012年 2月 6日(月)19時06分24秒
  > No.1753[元記事へ]

GAIさんへのお返事です。

回転などの対称性は排除していません。また、行や列でスライドしたものも含みます。


!問題
!次の0,1の模様（4ビットで構成された）がある16枚のピースがある。
! 1   2   3   4    5   6   7    8   9   10  11  12   13  14  15  16
!  00  00  00  00   01  01  01  01   10  10  10  10   11  11  11  11
!  00  01  10  11   00  01  10  11   00  01  10  11   00  01  10  11
!
!16枚を4行4列に条件を満たすように並べよ。
!条件
!・行や列の境ではビットが同じ並びである。
!・左端辺と右端辺、上端辺と下端辺が同じ並びである。

!答え
!題意を満たすビットの並び
!　01 | 12 | 23 | 30
!　45 | 56 | 67 | 74
! ----+----+----+----
!　45 | 56 | 67 | 74
!　89 | 9A | AB | B8
! ----+----+----+----
!　89 | 9A | AB | B8
!　CD | DE | EF | FC
! ----+----+----+----
!　CD | DE | EF | FC
!　01 | 12 | 23 | 30
!
!よって、[0],[1],[2],[3],…,[E],[F]の16ビットのビットパターン

10 DATA 0,1,4,5 !1行1列目のピース　番号は、[0]*2^3+[1]*2^2+[4]*2^1+[5]*2^0
   DATA 1,2,5,6 !1行2列目
   DATA 2,3,6,7 !1行3列目
   DATA 3,0,7,4 !1行4列目

   DATA 4,5,8,9 !2行1列目
   DATA 5,6,9,A !2行2列目
   DATA 6,7,A,B !2行3列目
   DATA 7,4,B,8 !2行4列目

   DATA 8,9,C,D !3行1列目
   DATA 9,A,D,E !3行2列目
   DATA A,B,E,F !3行3列目
   DATA B,8,F,C !3行4列目

   DATA C,D,0,1 !4行1列目
   DATA D,E,1,2 !4行2列目
   DATA E,F,2,3 !4行3列目
   DATA F,C,3,0 !4行4列目

   LET C=0 !解の数

   DIM B(0 TO 15) !ビットパターン
   FOR i=0 TO 2^16-1 !0,1,2,3,…,E,Fは、0または1
      LET t=i !2進法16桁へ
      FOR k=0 TO 15
         LET B(k)=MOD(t,2)
         LET t=INT(t/2)
      NEXT k


      RESTORE 10 !先頭へ位置付ける

      DIM P(0 TO 15) !16枚のピースへの「ピース番号（ビットパターンによる）」
      FOR j=0 TO 15
         LET V=0 !10進法へ
         FOR k=1 TO 4
            READ n$ !ビット位置を得る
            LET t=POS("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",n$)-1
            LET V=V*2+B(t)
         NEXT k
         !!!PRINT V; !debug
         LET P(j)=V !「ピース番号」
      NEXT j


      DIM F(0 TO 15) !ピースが重複するかどうか確認する
      MAT F=ZER
      FOR k=0 TO 15
         LET t=P(k) !「ピース番号」を得る
         IF F(t)=1 THEN EXIT FOR !重複！！！
         LET F(t)=1
      NEXT k
      IF k>15 THEN !重複しないなら

      !!IF P(0)<P(1) AND P(1)<P(4) THEN !対称性を考慮する

         LET C=C+1 !結果を表示する
         PRINT "No.";C
         FOR k=0 TO 15
            PRINT P(k);
            IF MOD(k+1,4)=0 THEN PRINT
         NEXT k
         PRINT

         !!END IF

      END IF

   NEXT i !次へ

END


実行結果

No. 1
15  14  9  7
13  10  4  12
6  8  0  1
11  3  2  5

No. 2
7  10  1  3
15  11  6  13
14  12  8  5
9  2  0  4

No. 3
11  6  13  15
12  8  5  14
2  0  4  9
10  1  3  7

No. 4
3  2  5  11
14  9  7  15
10  4  12  13
8  0  1  6

No. 5
15  11  6  13
14  12  8  5
9  2  0  4
7  10  1  3

No. 6
7  15  14  9
12  13  10  4
1  6  8  0
5  11  3  2

No. 7
11  3  2  5
15  14  9  7
13  10  4  12
6  8  0  1

No. 8
3  7  10  1
13  15  11  6
5  14  12  8
4  9  2  0

No. 9
13  15  11  6
5  14  12  8
4  9  2  0
3  7  10  1

No. 10
5  11  3  2
7  15  14  9
12  13  10  4
1  6  8  0

No. 11
9  7  15  14
4  12  13  10
0  1  6  8
2  5  11  3

No. 12
1  3  7  10
6  13  15  11
8  5  14  12
0  4  9  2

No. 13
13  10  4  12
6  8  0  1
11  3  2  5
15  14  9  7

No. 14
5  14  12  8
4  9  2  0
3  7  10  1
13  15  11  6

No. 15
9  2  0  4
7  10  1  3
15  11  6  13
14  12  8  5

No. 16
1  6  8  0
5  11  3  2
7  15  14  9
12  13  10  4

No. 17
14  9  7  15
10  4  12  13
8  0  1  6
3  2  5  11

No. 18
6  13  15  11
8  5  14  12
0  4  9  2
1  3  7  10

No. 19
10  1  3  7
11  6  13  15
12  8  5  14
2  0  4  9

No. 20
2  5  11  3
9  7  15  14
4  12  13  10
0  1  6  8

No. 21
14  12  8  5
9  2  0  4
7  10  1  3
15  11  6  13

No. 22
6  8  0  1
11  3  2  5
15  14  9  7
13  10  4  12

No. 23
10  4  12  13
8  0  1  6
3  2  5  11
14  9  7  15

No. 24
2  0  4  9
10  1  3  7
11  6  13  15
12  8  5  14

No. 25
12  8  5  14
2  0  4  9
10  1  3  7
11  6  13  15

No. 26
4  12  13  10
0  1  6  8
2  5  11  3
9  7  15  14

No. 27
8  0  1  6
3  2  5  11
14  9  7  15
10  4  12  13

No. 28
0  4  9  2
1  3  7  10
6  13  15  11
8  5  14  12

No. 29
12  13  10  4
1  6  8  0
5  11  3  2
7  15  14  9

No. 30
4  9  2  0
3  7  10  1
13  15  11  6
5  14  12  8

No. 31
8  5  14  12
0  4  9  2
1  3  7  10
6  13  15  11

No. 32
0  1  6  8
2  5  11  3
9  7  15  14
4  12  13  10

 		 

Re: パズルの解を求めて

 投稿者：ＧＡＩ  投稿日：2012年 2月 6日(月)22時40分6秒
  > No.1754[元記事へ]

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

プログラムの作成ありがとうございます。
解を探しに行く発想の着眼点は思っても見ないアイデアで感心いたします。

ただ点検していましたら、次の結果での並びで　０と６が隣同士ではパターンがずれるのではないかと思われますが・・・

> 実行結果
>
> No. 12
>  2  4  13  11
>  10  1  7  15
>  8  5  14  12
>  0  6  9  3
>
>
> No. 26
>  1  7  15  10
>  5  14  12  8
>  4  9  3  2
>  0  6  13  11
>
> No. 27
>  2  5  11  3
>  10  4  13  15
>  8  1  7  14
>  0  6  12  9
>
> No. 28
>  2  4  12  9
>  10  1  3  7
>  8  5  15  14
>  0  6  13  11
>
 		 

Re: パズルの解を求めて

 投稿者：山中和義  投稿日：2012年 2月 7日(火)01時09分30秒
  > No.1755[元記事へ]

ＧＡＩさんへのお返事です。

> ただ点検していましたら、次の結果での並びで　０と６が隣同士ではパターンがずれるのではないかと思われますが・・・
>
> > 実行結果
> >
> > No. 12
> >  2  4  13  11
> >  10  1  7  15
> >  8  5  14  12
> >  0  6  9  3
> >
> >
> > No. 26
> >  1  7  15  10
> >  5  14  12  8
> >  4  9  3  2
> >  0  6  13  11
> >
> > No. 27
> >  2  5  11  3
> >  10  4  13  15
> >  8  1  7  14
> >  0  6  12  9
> >
> > No. 28
> >  2  4  12  9
> >  10  1  3  7
> >  8  5  15  14
> >  0  6  13  11
> >
>


NEXT J の位置が間違っていました。（ピース番号をすべて作った後でないと重複チェックはできません）
プログラムを修正しましたので、参照してください。

 		 

マクマホンのパズルへの応用

 投稿者：GAI  投稿日：2012年 2月 8日(水)17時59分30秒
  随分と昔に、こんなパズルは難し過ぎると思ったものにマクマホンのパズルと呼ばれるものに出会ったことがあり、解決には至らず、途中で投げ出したことを思い出しました。

（ルール）
マクマホンタイル
一辺が１の長さの正方形で、その対角線を引き４つの領域に分ける。各領域を重複を許し３色で塗り分けられる全タイル（２４種類できる。）を用いて４×６の長方形に同じ色の辺が各行、各列で隣り合うように並べるパズル。
また、出来た長方形の周辺の色は同一色になっておくこと。


この解法に先程のアイデアが使えそうな感覚を持ちます。
もちろん私には、どこをどの様に変更すれば良いものなのか解らず、再び山中さんへプログラムの開発をお願いする次第です。
もし、決定的に異なるアルゴリズムでなければならないものなら、その点もよろしくお願いできますか？


 		 

Re: マクマホンのパズルへの応用

 投稿者：山中和義  投稿日：2012年 2月10日(金)18時51分14秒
  > No.1757[元記事へ]

GAIさんへのお返事です。

> マクマホンタイル

3^38通りの検証になりますので、PCでは不可能だと思います。
プログラムは掲載しますが、最初の1つの解でも実時間では何日かかるか解りません。


!マクマホン・タイル

!参考サイト　http://www.asahi-net.or.jp/~uy7t-isn/Puzzle/MacMahon/

!正方形の4辺を塗り分けたタイルを用い、同じ色の辺が隣り合うように並べる。
!3色24枚のセットを用い、辺の色が1色の長方形を作ることができる。

!以下の24種類
!1色系　Ａ:0,1,2　※0,1,2は色を表す
!1┌───┐
! │＼Ａ／│
! │Ａ×Ａ│
! │／Ａ＼│
! └───┘　計3*1=3通り

!2色系　Ａ:0,1,2、Ｂ:1,2,0
!1┌───┐ 2┌───┐ 3┌───┐ 4┌───┐
! │＼Ａ／│  │＼Ａ／│  │＼Ａ／│  │＼Ａ／│
! │Ｂ×Ａ│  │Ｂ×Ａ│  │Ｂ×Ｂ│  │Ｂ×Ｂ│
! │／Ａ＼│  │／Ｂ＼│  │／Ａ＼│  │／Ｂ＼│
! └───┘  └───┘  └───┘  └───┘　計3*4=12通り

!3色系　Ａ:0,1,2、Ｂ:1,2,0、Ｃ:2,0,1
!1┌───┐ 2┌───┐ 3┌───┐
! │＼Ａ／│  │＼Ａ／│  │＼Ａ／│
! │Ｃ×Ａ│  │Ｂ×Ａ│  │Ｃ×Ｂ│
! │／Ｂ＼│  │／Ｃ＼│  │／Ａ＼│
! └───┘  └───┘  └───┘　計3*3=9通り

OPTION ARITHMETIC RATIONAL !多桁整数

LET t0=TIME

!題意を満たす色の並び
!┌───┐┌───┐┌───┐┌───┐┌───┐┌───┐
!│＼０／││＼０／││＼０／││＼０／││＼０／││＼０／│
!│０×１││１×２││２×３││３×４││４×５││５×０│
!│／６＼││／７＼││／８＼││／９＼││／Ａ＼││／Ｂ＼│
!└───┘└───┘└───┘└───┘└───┘└───┘
!┌───┐┌───┐┌───┐┌───┐┌───┐┌───┐
!│＼６／││＼７／││＼８／││＼９／││＼Ａ／││＼Ｂ／│
!│０×Ｃ││Ｃ×Ｄ││Ｄ×Ｅ││Ｅ×Ｆ││Ｆ×Ｇ││Ｇ×０│
!│／Ｈ＼││／Ｉ＼││／Ｊ＼││／Ｋ＼││／Ｌ＼││／Ｍ＼│
!└───┘└───┘└───┘└───┘└───┘└───┘
!┌───┐┌───┐┌───┐┌───┐┌───┐┌───┐
!│＼Ｈ／││＼Ｉ／││＼Ｊ／││＼Ｋ／││＼Ｌ／││＼Ｍ／│
!│０×Ｎ││Ｎ×Ｏ││Ｏ×Ｐ││Ｐ×Ｑ││Ｑ×Ｒ││Ｒ×０│
!│／Ｓ＼││／Ｔ＼││／Ｕ＼││／Ｖ＼││／Ｗ＼││／Ｘ＼│
!└───┘└───┘└───┘└───┘└───┘└───┘
!┌───┐┌───┐┌───┐┌───┐┌───┐┌───┐
!│＼Ｓ／││＼Ｔ／││＼Ｕ／││＼Ｖ／││＼Ｗ／││＼Ｘ／│
!│０×Ｙ││Ｙ×Ｚ││Ｚ×ａ││ａ×ｂ││ｂ×ｃ││ｃ×０│
!│／０＼││／０＼││／０＼││／０＼││／０＼││／０＼│
!└───┘└───┘└───┘└───┘└───┘└───┘

LET M=4 !m行n列
LET N=6
LET K=38 !０を0に固定して、１,２,３,…,Ｙ,Ｚ,ａ,ｂ,ｃ

DATA 0,0,1,6 !1
DATA 0,1,2,7 !2
DATA 0,2,3,8 !3
DATA 0,3,4,9 !4
DATA 0,4,5,A !5
DATA 0,5,0,B !6
DATA 6,0,C,H !7
DATA 7,C,D,I !8
DATA 8,D,E,J !9
DATA 9,E,F,K !10
DATA A,F,G,L !11
DATA B,G,0,M !12
DATA H,0,N,S !13
DATA I,N,O,T !14
DATA J,O,P,U !15
DATA K,P,Q,V !16
DATA L,Q,R,W !17
DATA M,R,0,X !18
DATA S,0,Y,0 !19
DATA T,Y,Z,0 !20
DATA U,Z,a,0 !21
DATA V,a,b,0 !22
DATA W,b,c,0 !23
DATA X,c,0,0 !24

DIM H(M*N,4) !4桁ずつmn個
FOR y=1 TO M*N !ピース番号を決めるパターンの桁の構成
   FOR x=1 TO 4
      READ d$
      LET H(y,x)=POS("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz",d$)-1
   NEXT x
NEXT y
MAT PRINT H; !debug

PRINT 3^K !debug


LET C=0 !解の数

DIM B(0 TO K) !パターン
FOR i=0 TO 3^K-1 !０を0に固定して、１,２,３,…,Ｙ,Ｚ,ａ,ｂ,ｃの計k個の変数は、0,1,2
   LET t=i
   FOR x=K TO 0 STEP -1 !3進法k桁へ
      LET B(x)=MOD(t,3)
      LET t=INT(t/3)
   NEXT x


   DIM F(0 TO 3^4-1) !ピースが重複するかどうか確認する
   MAT F=ZER
   FOR y=1 TO M*N !ピースの位置
      LET v0=B(H(y,1))*27+B(H(y,2))*9+B(H(y,3))*3+B(H(y,4)) !ピース番号　4桁ずつ
      LET v1=B(H(y,3))*27+B(H(y,1))*9+B(H(y,4))*3+B(H(y,2)) !90°回転
      LET v2=B(H(y,4))*27+B(H(y,3))*9+B(H(y,2))*3+B(H(y,1)) !180°回転
      LET v3=B(H(y,2))*27+B(H(y,4))*9+B(H(y,1))*3+B(H(y,3)) !270°回転
      LET t=MIN( MIN(v0,v1), MIN(v2,v3) ) !回転対称を除く

      IF F(t)=1 THEN EXIT FOR !重複！！！
      LET F(t)=1
   NEXT y
   IF y>M*N THEN !重複しないなら

      LET C=C+1 !結果を表示する
      PRINT "No.";C

      PRINT " +"; B(0); "+"; B(0); "+"; B(0); "+"; B(0); "+"; B(0); "+"; B(0); "+" !上端
      PRINT B(0); " "; B(1); " "; B(2); " "; B(3); " "; B(4); " "; B(5); " "; B(0); " " !1列目
      PRINT " +"; B(6); "+"; B(7); "+"; B(8); "+"; B(9); "+"; B(10); "+"; B(11); "+"
      PRINT B(0); " "; B(12); " "; B(13); " "; B(14); " "; B(15); " "; B(16); " "; B(0); " " !2列目
      PRINT " +"; B(17); "+"; B(18); "+"; B(19); "+"; B(20); "+"; B(21); "+"; B(22); "+"
      PRINT B(0); " "; B(23); " "; B(24); " "; B(25); " "; B(26); " "; B(27); " "; B(0); " " !3列目
      PRINT " +"; B(28); "+"; B(29); "+"; B(30); "+"; B(31); "+"; B(32); "+"; B(33); "+"
      PRINT B(0); " "; B(34); " "; B(35); " "; B(36); " "; B(37); " "; B(38); " "; B(0); " " !4列目
      PRINT " +"; B(0); "+"; B(0); "+"; B(0); "+"; B(0); "+"; B(0); "+"; B(0); "+" !下端

      PRINT

   END IF

NEXT i !次へ


PRINT "実行時間="; TIME-t0

END


実行結果

　　：
　　：

No. ?
+ 0 + 0 + 0 + 0 + 0 + 0 +
0   1   1   2   1   1   0
+ 0 + 0 + 2 + 2 + 1 + 2 +
0   1   2   1   1   1   0
+ 2 + 0 + 2 + 2 + 1 + 2 +
0   2   2   2   1   1   0
+ 0 + 0 + 2 + 1 + 2 + 1 +
0   0   2   2   1   1   0
+ 0 + 0 + 0 + 0 + 0 + 0 +

No. ?
+ 0 + 0 + 0 + 0 + 0 + 0 +
0   1   1   2   1   1   0
+ 0 + 0 + 2 + 2 + 1 + 2 +
0   1   2   1   1   1   0
+ 2 + 0 + 2 + 2 + 1 + 2 +
0   2   2   2   1   1   0
+ 2 + 0 + 2 + 1 + 2 + 1 +
0   0   0   2   1   1   0
+ 0 + 0 + 0 + 0 + 0 + 0 +

　　：
　　：

 		 

お礼と感想

 投稿者：ＧＡＩ  投稿日：2012年 2月11日(土)07時13分12秒
  最初に掲載して頂いたプログラムを、マクマホンの条件に合うように修正して動かしてみようと私なりに試みていましたが、３進法や配置の条件を組むあたりは何とか理解できたのでいろいろ変更しながらスタートしても、範囲を超えてますなどの返事が返ってくるだけで一向に動こうとはしませんでした。
また今度はピースを回転させることも許されるので、どうしたらいいのか検討もつきませんでした。
今度掲載して頂いたプログラム（実際パソコンの能力では結果がでるまでは長時間かかりそう・・・）を拝見し、特に次の部分の構成が凄いと思いました。


DIM F(0 TO 3^4-1) !ピースが重複するかどうか確認する
   MAT F=ZER
   FOR y=1 TO M*N !ピースの位置
      LET v0=B(H(y,1))*27+B(H(y,2))*9+B(H(y,3))*3+B(H(y,4)) !ピース番号　4桁ずつ
      LET v1=B(H(y,3))*27+B(H(y,1))*9+B(H(y,4))*3+B(H(y,2)) !90°回転
      LET v2=B(H(y,4))*27+B(H(y,3))*9+B(H(y,2))*3+B(H(y,1)) !180°回転
      LET v3=B(H(y,2))*27+B(H(y,4))*9+B(H(y,1))*3+B(H(y,3)) !270°回転
      LET t=MIN( MIN(v0,v1), MIN(v2,v3) ) !回転対称を除く

      IF F(t)=1 THEN EXIT FOR !重複！！！
      LET F(t)=1

（実は理解したつもりが、本当はよく分かってないかも・・・）

このように、実際の問題にどのようにプログラムを構成していかれるのかを拝見するのはとっても参考になります。
私も（もうじき退職を迎える年齢になっています。）まとめて勉強する時間がとれる時がきましたら、山中さんが作られた数多くのプログラム（電脳遊戯団よりダウンロード済み）を一つ一つ鑑賞しコンピュータを自由に使いこなす域まで到達したいと密かに計画しております。（現在はコンピュータに使われている状態です。）

重ね重ねプログラムを提供していただいて、ありがとうございます。
山中さんを人生の目標にします。 		 

10進BASICにGUIは作らないのですか

 投稿者：大熊　正ﾒｰﾙ  投稿日：2012年 2月11日(土)11時44分1秒
  山中　和義　様
必要に迫られて数式ソフトのMAXIMAをやってみました。これにはGUIのWxMAXIMAが付いていて、それなりにソフトの全体が見通せて便利でした。山中様の電脳集団は膨大なソフトを作られています、私も丸ごとコピーしてときに応じて利用していますが、数値ソフトの「グレープ」や「FUNCTION VIEW」のようにGUIがあれば初心者には便利と思います、10進BASIC用のGUIを作る御計画は無いのでしょうか。

敬具

http://ｈｔｔｐ:／／

  

Re: 10進BASICにGUIは作らないのですか

 投稿者：白石和夫  投稿日：2012年 2月11日(土)12時00分28秒
  > No.1760[元記事へ]

Full BASICのプログラムはブロック構造をとっているので，
プログラム単位，内部手続き，繰り返し，判断，例外状態処理などのブロックを貼り付けていけばプログラムが完成するようなGUIを用意することは可能だと思います。
私一人の手に負えるようなものではないので，どなたか意欲のある方の参入を期待してます。
なお，ソースコードはGPLで公開しているので，改変自由です。
 		 

なんでそうなるの？

 投稿者：ＧＡＩ  投稿日：2012年 2月13日(月)05時58分58秒
  http://www.asahipress.com/brain/langton_regular/langton.html
に面白いセル・オートマトンの現象が紹介されていました。（ラングトンの蟻）
これをぜひプログラムして頂きたいです。
 		 

Re: なんでそうなるの？

 投稿者：山中和義  投稿日：2012年 2月13日(月)12時34分50秒
  > No.1762[元記事へ]

ＧＡＩさんへのお返事です。

> 面白いセル・オートマトンの現象が紹介されていました。（ラングトンの蟻）

タートルグラフィックスを使って実装してみました。
ライントレース・ロボットの制御（仮想シミュレーション）、正ｎ角形などの作図などに向いています。


!ラングトンの蟻（Langton's ant）

!参考サイト　http://ja.wikipedia.org/wiki/%E3%83%A9%E3%83%B3%E3%82%B0%E3%83%88%E3%83%B3%E3%81%AE%E3%82%A2%E3%83%AA

DECLARE EXTERNAL NUMERIC tg.COLOR, tg.STYLE
DECLARE EXTERNAL SUB tg.move, tg.moveTo, tg.turn, tg.direction, tg.current

LET w=500 !画面の大きさ　※
LET h=400
SET bitmap SIZE w,h !第1象限（整数座標）
SET WINDOW 0,w-1,0,h-1

CALL home
SUB home !ホームポジション
   CALL moveTo(INT(w/2),INT(h/2)) !画面中央
   CALL direction(0) !右向き 0°
END SUB
!----------------------- ここまでがサブルーチン

DIM Ax(3),Ay(3),Aa(3) !3匹の蟻 A(1),A(2),A(3)
LET Ax(1)=INT(w/4) !(x,y)
LET Ay(1)=INT(h/4)
LET Ax(2)=INT(3*w/4) !(x,y)
LET Ay(2)=INT(h/4)
LET Ax(3)=INT(w/2) !(x,y)
LET Ay(3)=INT(3*h/4)
MAT Aa=ZER !右向き 0°

LET tg.COLOR=-1 !軌跡を描かない

FOR i=1 TO 50000 !試行回数

   FOR c=1 TO 3
      LET x=Ax(c)
      LET y=Ay(c)
      CALL moveTo(x,y) !restore it
      CALL direction(Aa(c))

      ASK PIXEL VALUE (x,y) d !ピクセル（ドット）の色を読み込む
      IF d>0 THEN !黒点の場合
         CALL turn(-90) !右へ
         SET AREA COLOR 0 !点の色を変更する
      ELSE !白点
         CALL turn(90) !左へ
         SET AREA COLOR c+1
      END IF

      PLOT AREA: x-1,y-1; x+1,y-1; x+1,y+1; x-1,y+1 !矩形を描く　※3ピクセル
      CALL move(3) !移動する　※3ピクセル


      CALL current(x,y,a) !画面からはみ出した場合、向こう側に折り返す
      LET x=MOD(x,w)
      LET y=MOD(y,h)

      LET Ax(c)=x !save it
      LET Ay(c)=y
      LET Aa(c)=a
   NEXT c

NEXT i

END


!タートルグラフィックス（極座標による線画システム）
MODULE tg
PUBLIC NUMERIC COLOR,STYLE !線色、線種
LET COLOR=1 !黒色
LET STYLE=1 !実線

SHARE NUMERIC CPX,CPY,CA
LET CPX=0 !現在位置を原点、現在の向きを０°とする
LET CPY=0
LET CA=0

PUBLIC SUB move
EXTERNAL SUB move(L) !前に進む　(x+L*cosθ,y+L*sinθ)
   LET x=CPX !現在位置
   LET y=CPY
   LET CPX=CPX+L*COS(RAD(CA)) !移動先を算出する
   LET CPY=CPY+L*SIN(RAD(CA))
   IF COLOR>=0 THEN !色番号が負なら、線は書かない（ペンを上げる）
      SET LINE COLOR COLOR
      SET LINE STYLE STYLE
      PLOT LINES: x,y; CPX,CPY !線を描く
   END IF
END SUB

PUBLIC SUB moveTo
EXTERNAL SUB moveTo(x,y) !現在位置を(x,y)とする
   LET CPX=x
   LET CPY=y
END SUB

PUBLIC SUB turn
EXTERNAL SUB turn(a) !角度aだけ回転する
   LET CA=MOD(CA+a,360) ![0,360)
END SUB

PUBLIC SUB direction
EXTERNAL SUB direction(a) !向きをaとする
   LET CA=MOD(a,360)
END SUB

PUBLIC SUB current
EXTERNAL SUB current(x,y,a) !状態変数の値を返す
   LET x=CPX
   LET y=CPY
   LET a=CA
END SUB
END MODULE
 

プログラムリストが見れません

 投稿者：名なしさん  投稿日：2012年 2月13日(月)23時03分17秒
  　初めまして。
　ボチクンのパコソンを再セットアップしたら、十進Basicの拡張子basのファイルをアイコンから開こうとすると、
プログラムを実行するだけで、プログラムリストが見れなくなってしまいました（「一覧からプログラムを選択す
る」をクリック後、BASIC.EXEを選択して起動しても同じ）。プログラムリストを編集しながら実行するためには、
いちいち本体のBASIC.EXEを開いて、そっから見たいプログラムを開くようにしなければならなくなりました。
　とってもメンドくさいです(因みに、この再セットアップで、Tiny Basicはアプリケ本体からはヘルプを見
ようとすると、例のF1キーを押す方法でも見れず、WINDOWS EXPLORER上のヘルプファイルのアイコンを直接
クリックしなければならなくなりました)。
　因みに、パコソンは東芝２００３年型dynabook
     PAAX/2525CMS
　OSは
　　Windows XP SP1 ver.5.1.2600
です。だれか元に戻す方法を教えてください。お願いしまーす。
 		 

Re: プログラムリストが見れません

 投稿者：山中和義  投稿日：2012年 2月14日(火)10時12分13秒
  > No.1764[元記事へ]

名なしさんさんへのお返事です。

> プログラムを実行するだけで、プログラムリストが見れなくなってしまいました
>（「一覧からプログラムを選択する」をクリック後、BASIC.EXEを選択して起動しても同じ）。

拡張子.BASのファイル（ソース・プログラム）を右クリックして、
出てきたメニューの「プロパティ」から、アプリケーションの「変更」を選び、
「メモ帳」などのテキストを表示するアプリケーションに割り付ければよいと思います。

以前は、そのようになっていたのではないでしょうか？（アイコンの形状をみれば分かります）


> プログラムリストを編集しながら実行するためには、
> いちいち本体のBASIC.EXEを開いて、そっから見たいプログラムを開くようにしなければならなくなりました。

BASIC本体は、「編集＋実行」を行ういわゆるプログラムを開発する統合環境ですから、
BASIC本体を起動して、ソースプログラムを見るのが通常の使い方だと思います。


> ヘルプを見ようとすると、例のF1キーを押す方法でも見れず、

Windows95/98/Me/NT4.0/2000/XP/Vista/7　アーカイブ版
http://hp.vector.co.jp/authors/VA008683/basicw32.htm

にトラブルシュートがあります。
 		 

Re: マクマホンのパズルへの応用

 投稿者：山中和義  投稿日：2012年 2月15日(水)11時13分41秒
  > No.1758[元記事へ]

GAIさんへのお返事です。

> マクマホンタイル
>
> 3^38通りの検証になりますので、PCでは不可能だと思います。
> プログラムは掲載しますが、最初の1つの解でも実時間では何日かかるか解りません。

プログラムをバックトラック法に変更してみました。
PCに依りますが、1時間で40個程度、12時間で900個程度の解を見つけることができます。
12時間で、並びが、1,2,3,…,23,24から、1,2,22,21,…ですから全解を求めるのは困難です。

2進モードで実行してください。


!マクマホン（MacMahon）・タイル

!参考サイト　http://www.asahi-net.or.jp/~uy7t-isn/Puzzle/MacMahon/

!正方形の4辺を塗り分けたタイルを用い、同じ色の辺が隣り合うように並べる。
!3色24枚のセットを用い、辺の色が1色の長方形を作ることができる。

LET t0=TIME

!1つの解
!　+ 0 + 0 + 0 + 0 + 0 + 0 +
!　0   1   1   2   1   1   0
!　+ 0 + 0 + 2 + 2 + 1 + 2 +
!　0   1   2   1   1   1   0
!　+ 2 + 0 + 2 + 2 + 1 + 2 +
!　0   2   2   2   1   1   0
!　+ 0 + 0 + 2 + 1 + 2 + 1 +
!　0   0   2   2   1   1   0
!　+ 0 + 0 + 0 + 0 + 0 + 0 +
!より、

DATA 0,1,0,0 !1　※時計の12時の位置から時計まわりに並べる
DATA 0,1,0,1 !2
DATA 0,2,2,1 !3
DATA 0,1,2,2 !4
DATA 0,1,1,1 !5
DATA 0,0,2,1 !6
DATA 0,1,2,0 !7
DATA 0,2,0,1 !8
DATA 2,1,2,2 !9
DATA 2,1,2,1 !10
DATA 1,1,1,1 !11
DATA 2,0,2,1 !12
DATA 2,2,0,0 !13
DATA 0,2,0,2 !14
DATA 2,2,2,2 !15
DATA 2,1,1,2 !16
DATA 1,1,2,1 !17
DATA 2,0,1,1 !18
DATA 0,0,0,0 !19
DATA 0,2,0,0 !20
DATA 2,2,0,2 !21
DATA 1,1,0,2 !22
DATA 2,1,0,1 !23
DATA 1,0,0,1 !24

PUBLIC NUMERIC M,N !盤の大きさ　m行n列
LET M=4 !※固定
LET N=6


PUBLIC NUMERIC P(0 TO 23, 0 TO 3) !24枚のピース
MAT READ P

PUBLIC NUMERIC B(0 TO 23, 0 TO 3) !4行6列の盤

PUBLIC NUMERIC F(0 TO 23) !ピースの使用状況　0:未使用、1:使用
MAT F=ZER

PUBLIC NUMERIC C, cc !解の数
LET C=0

CALL try(0)

PRINT "実行時間=";TIME-t0

END


EXTERNAL SUB try(z) !バックトラック法で探索する
!枝刈り
!・右下に到達するまでに、4隅に入るピース（0が隣接する）を既に使い切ってしまった！
IF z>7 THEN
   IF F(0)>0 AND F(5)>0 AND F(6)>0 AND F(12)>0 AND F(18)>0 AND F(19)>0 AND F(23)>0 THEN EXIT SUB
END IF
!・中央部をすべて埋めて、中央に入るピース（0が1つもない）を使い切っていない！
IF z=(M-1)*N-1 AND ( F(8)=0 OR F(9)=0 OR F(10)=0 OR F(14)=0 OR F(15)=0 OR F(16)=0 ) THEN EXIT SUB


FOR i=0 TO M*N-1 !(mn)枚のピースを配置する。高々(mn)!通り
   IF F(i)=0 THEN !未使用なら
      LET F(i)=z+1 !使用中　※0より大きな数


      DIM S(0 TO 3^4-1) !ピース番号
      MAT S=ZER
      FOR R=0 TO 3 !0°,90°,180°,270°回転して配置する
         LET t=0 !3進法4桁
         FOR j=0 TO 3
            LET v=P(i,MOD(j+R,4))
            LET t=t*3+v
            LET B(z,j)=v !z番目の位置にピースを置く（上書き）
         NEXT j
         IF S(t)=0 THEN !回転対称でないなら
            LET S(t)=1


            !---------- ↓↓↓↓↓ ----------
            !盤にピースが置けるかどうか確認する
            !  B(z-1,)   B(z,)=P(i,+R)
            !     0'       0
            !   3'  1'   3   1
            !     2'       2
            LET FLG=0

            IF z=0 THEN !左上隅（1番目）
               IF B(z,0)=0 THEN !上=色0
                  IF B(z,3)=0 THEN LET FLG=1 !左=色0
               END IF
            ELSEIF z=N-1 THEN !右上隅
               IF B(z,0)=0 THEN !上=色0
                  IF B(z-1,1)=B(z,3) THEN !左隣接1'=3
                     IF B(z-(N-1),3)=B(z,1) THEN LET FLG=1 !左端3'=右端1
                  END IF
               END IF
            ELSEIF z=(M-1)*N THEN !左下隅
               IF B(z,3)=0 THEN !左=色0
                  IF B(z-N,2)=B(z,0) THEN !上隣接2'=0
                     IF B(MOD(z,N),0)=B(z,2) THEN LET FLG=1 !上端0'=下端2
                  END IF
               END IF
            ELSEIF z=M*N-1 THEN !右下隅（最後）
               IF B(z-1,1)=B(z,3) THEN !左隣接1'=3
                  IF B(z-N,2)=B(z,0) THEN !上隣接2'=0
                     IF B(MOD(z,N),0)=B(z,2) THEN !上端0'=下端2
                        IF B(z-(N-1),3)=B(z,1) THEN LET FLG=1 !左端3'=右端1
                     END IF
                  END IF
               END IF

            ELSEIF z<N THEN !上端
               IF B(z,0)=0 THEN !上=色0
                  IF B(z-1,1)=B(z,3) THEN LET FLG=1 !左隣接1'=3
               END IF
            ELSEIF MOD(z,N)=0 THEN !左端
               IF B(z,3)=0 THEN !左=色0
                  IF B(z-N,2)=B(z,0) THEN LET FLG=1 !上隣接2'=0
               END IF
            ELSEIF MOD(z,N)=N-1 THEN !右端
               IF B(z-1,1)=B(z,3) THEN !左隣接1'=3
                  IF B(z-N,2)=B(z,0) THEN !上隣接2'=0
                     IF B(z-(N-1),3)=B(z,1) THEN LET FLG=1 !左端3'=右端1
                  END IF
               END IF
            ELSEIF z>=(M-1)*N THEN !下端
               IF B(z-1,1)=B(z,3) THEN !左隣接1'=3
                  IF B(z-N,2)=B(z,0) THEN !上隣接2'=0
                     IF B(MOD(z,N),0)=B(z,2) THEN LET FLG=1 !上端0'=下端2
                  END IF
               END IF

            ELSE !その他（中央部分）
               IF B(z-1,1)=B(z,3) THEN !左隣接1'=3
                  IF B(z-N,2)=B(z,0) THEN LET FLG=1 !上隣接2'=0
               END IF
            END IF
            !---------- ↑↑↑↑↑ ----------

            IF FLG=1 THEN !配置可能なら


               IF z=M*N-1 THEN !すべて揃ったなら
                  LET C=C+1 !結果を表示する
                  PRINT "No."; C
                  !!!MAT PRINT B; !debug

                  PRINT " +"; !上端
                  FOR x=0 TO N-1
                     PRINT B(x,0); "+";
                  NEXT x
                  PRINT
                  FOR y=0 TO M-1 !y行目
                     FOR x=0 TO N-1
                        PRINT B(y*N+x,3); " ";
                     NEXT x
                     PRINT B(y*N+N-1,1)

                     PRINT " +";
                     FOR x=0 TO N-1
                        PRINT B(y*N+x,2); "+";
                     NEXT x
                     PRINT
                  NEXT y


                  FOR y=1 TO M*N !ピース番号で並びを表示する
                     FOR x=0 TO M*N-1
                        IF F(x)=y THEN EXIT FOR
                     NEXT x
                     PRINT x+1;
                  NEXT y
                  PRINT


                    PRINT
               ELSE
                  CALL try(z+1) !次へ
               END IF


            END IF


         END IF
      NEXT R


      LET F(i)=0 !元に戻す
   END IF
NEXT i
END SUB

 		 

新たな疑問

 投稿者：GAI  投稿日：2012年 2月15日(水)16時15分28秒
  > No.1766[元記事へ]

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

マイパソコンでも解が１時間も走らせれば、ぞろぞろと出てきました。
もう３つほど発見できれば大満足です。

パソコンは指令された命令を忠実に実行しているだけでしょうが、いやはや人間の能力を遙かに凌いでいます。（これに命令を与えられない自分にもどかしさを感じています。）

話はまったく変わりますが、近頃円周率のπの無限級数表示で

π＝Σ(n=0~∞)(4/(8n+1)-2/(8n+4)-1/(8n+5)-1/(8n+6))*(1/16)^n

という式にお目にかかりました。

計算ソフトでPARI/GP というものをダウンロードして、これを計算で確かめましたら
3.141592・・・・と小数点２７桁まで（計算で画面に表示されるのがそこまでなので・・・）
真の値と一致しておりました。（この式は正しいのであろう・・・）

この式は(1/16)^nで固まっているのだからπの１６進数表示の小数部分表示がその前の係数部分と解釈できるのではないのでしょうか。
つまり、πは１６進数では規則をもって数字を表していくことになり、ひいては１０進数へ変換してやれば、例えば小数点以下１０００桁目には何の数字が現れるのかが解る手がかりにできるのではないでしょうか？（途中の部分が解らなくても）

自分は数論の専門家でも何でもなく、この式に出会って感じたことを述べたまでです。

この式を上手く活用する何らかの方法はないのでしょうか。
プログラム的にこの性質を解明できる何かがありましたら、研究願えませんか？






 		 

Re: 新たな疑問

 投稿者：山中和義  投稿日：2012年 2月15日(水)17時02分27秒
  > No.1767[元記事へ]

GAIさんへのお返事です。

> 話はまったく変わりますが、近頃円周率のπの無限級数表示で
>
> π＝Σ(n=0~∞)(4/(8n+1)-2/(8n+4)-1/(8n+5)-1/(8n+6))*(1/16)^n
>
> という式にお目にかかりました。


リンク集より

KK62526のホームページ
　BBPアルゴリズムのプログラム
　http://www14.ocn.ne.jp/~kk62526/pi/BBP.html （直リンク）

を参照してください。
 		 

魔方陣の変形

 投稿者：ＧＡＩ  投稿日：2012年 2月16日(木)20時01分20秒
  紹介して頂いたＨＰはとっても参考になりました。
自分でも相当探していたんですが、まさに調べたいことがここにあったんだと膝を打つ気持ちでした。
またまた

３×３の魔方陣として
４　３　８

９　５　１

２　７　６

は有名で、これはなんとかプログラムを組んで発見することは可能であると感じます。

これを

A^2  B^2  C^2

D^2  E^2  F^2

G^2  H^2  I^2

の計算で魔方陣となる配列がとれるか探せるものでしょうか？

 		 

Re: プログラムリストが見れません

 投稿者：名なしさん  投稿日：2012年 2月16日(木)22時33分12秒
  > No.1765[元記事へ]

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

拡張子.BASのファイル（ソース・プログラム）を右クリックして、
> 出てきたメニューの「プロパティ」から、アプリケーションの「変更」を選び、
> 「メモ帳」などのテキストを表示するアプリケーションに割り付ければよいと思います。

> 以前は、そのようになっていたのではないでしょうか？（アイコンの形状をみれば分かります）

> BASIC本体は、「編集＋実行」を行ういわゆるプログラムを開発する統合環境ですから、
> BASIC本体を起動して、ソースプログラムを見るのが通常の使い方だと思います。

　ご返事ありがとうございます。
　併し、ご指摘の方法も考えついてはおりました。以前は、BASファイルのアイコンをクリックすれば、BASIC本
体の編集ウィンドウがプログラムリストごと起動するようになっていたんですよ。アイコンの絵も、メモ帳の
それではなく、「BASIC」の字が書いてあるデザインになっていましたから。
　揚げ足を取るような内容ですみません。 		 

Re: 魔方陣の変形

 投稿者：山中和義  投稿日：2012年 2月17日(金)13時32分17秒
  > No.1769[元記事へ]

ＧＡＩさんへのお返事です。

> A^2  B^2  C^2
> D^2  E^2  F^2
> G^2  H^2  I^2
> の計算で魔方陣となる配列がとれるか探せるものでしょうか？

汎用的には、バックトラック法で解決します。

魔方陣を
123
456
789
の順に、数値を埋めていけばよいです。

和をSとして、0≦A,B,C≦Sがおおざっぱな候補ですが、
1行目は、A^2+B^2+C^2=Sですから、
Aは、A^2≦S
Bは、A^2+B^2≦S
Cは、A^2+B^2+C^2=S
を満たさないといけません。

このようなチェックを途中にコーディングすれば完成です。


!３×３魔方陣

LET t0=TIME

PUBLIC NUMERIC C !解の数
PUBLIC NUMERIC M(9) !魔方陣
PUBLIC NUMERIC S !和
FOR S=0 TO 1500
   PRINT "S=";S
   LET C=0
   CALL try(1)
NEXT S

PRINT "実行時間=";TIME-t0

END

EXTERNAL SUB try(p) !バックトラック法で探索する
FOR i=0 TO S !候補
   LET t=i*i !埋め込む数値

   !M(p) 123
   !　　 456
   !　　 789
   LET OK=1
   IF p=1 THEN
      IF t>S THEN EXIT SUB !不適切
   ELSEIF p=2 THEN
      IF M(1)+t>S THEN EXIT SUB !不適切
   ELSEIF p=3 THEN
      IF M(1)+M(2)+t< S THEN LET OK=0 !不適切

      IF M(1)+M(2)+t>S THEN EXIT SUB !不適切
   ELSEIF p=4 THEN
      IF M(1)+t>S THEN EXIT SUB !不適切
   ELSEIF p=5 THEN
      IF M(1)+t>S THEN EXIT SUB !不適切
      IF M(2)+t>S THEN EXIT SUB !不適切
      IF M(3)+t>S THEN EXIT SUB !不適切
      IF M(4)+t>S THEN EXIT SUB !不適切
   ELSEIF p=6 THEN
      IF M(4)+M(5)+t< S THEN LET OK=0 !不適切

      IF M(3)+t>S THEN EXIT SUB !不適切
      IF M(4)+M(5)+t>S THEN EXIT SUB !不適切
   ELSEIF p=7 THEN
      IF M(1)+M(4)+t< S THEN LET OK=0 !不適切
      IF M(3)+M(5)+t< S THEN LET OK=0 !不適切

      IF M(1)+M(4)+t>S THEN EXIT SUB !不適切
      IF M(3)+M(5)+t>S THEN EXIT SUB !不適切
   ELSEIF p=8 THEN
      IF M(2)+M(5)+t< S THEN LET OK=0 !不適切

      IF M(7)+t>S THEN EXIT SUB !不適切
      IF M(2)+M(5)+t>S THEN EXIT SUB !不適切
   ELSEIF p=9 THEN
      IF M(1)+M(5)+t< S THEN LET OK=0 !不適切
      IF M(3)+M(6)+t< S THEN LET OK=0 !不適切
      IF M(7)+M(8)+t< S THEN LET OK=0 !不適切

      IF M(1)+M(5)+t>S THEN EXIT SUB !不適切
      IF M(3)+M(6)+t>S THEN EXIT SUB !不適切
      IF M(7)+M(8)+t>S THEN EXIT SUB !不適切
   ELSE
      PRINT "論理エラー"; p
      STOP
   END IF
   IF OK=1 THEN !条件を満たすなら
      LET M(p)=t !上書き

      IF p=9 THEN !すべて揃ったなら

         IF M(1)<=M(9) AND M(1)<=M(2) AND M(2)<=M(4) THEN !対称性

            LET C=C+1 !結果を表示する
            PRINT "No.";C

            FOR j=1 TO 9 !3x3
               PRINT M(j);
               IF MOD(j,3)=0 THEN PRINT
            NEXT j
            PRINT

         END IF

      ELSE
         CALL try(p+1) !次へ

      END IF

   END IF
NEXT i
END SUB

 		 

疑似　.exe ファイル化について

 投稿者：TOM  投稿日：2012年 2月17日(金)14時57分53秒
  　大分以前(2004年２月）の話題ですが，
「ＥＸＥファイルにする方法」のテーマがありました．

　最近，私も.exeファイル化が必要になり，いろいろと検討してみましたのでご報告します．

　走らせたいプログラムの名前を仮に，「走らせたい十進BASICプログラム」.BASとしますと，
要は，もうひとつ，十進BASICプログラム，たとえば「ダミーEXE」．BAS　という名のプログラムを作っておき，そのプログラムから　EXECUTE　させます．


　「ダミーEXE」．BAS の中身は，例えば以下のように，２行だけです．
つまり，「ダミーEXE」．BASには「走らせたい十進BASICプログラム」.BAS　のための「EXECUTE　***   with *** 」を書いておきます．
　「ダミーEXE」．BASを実行すると，「走らせたい十進BASICプログラム」.BASが走ります．なお，その際，「走らせたい十進BASICプログラム」.BASの中身は表示されません．

　EXECUTE "C:\Program Files\Decimal BASIC\BASICw32\Basic.exe" WITH ("「走らせたい十進BASICプログラム」.BAS")
　END

　もし，「走らせたい十進BASICプログラム」.BAS　の中身を触られたくなければ，「走らせたい十進BASICプログラム」.BAS　を分かりにくい場所に移動させておいて，EXECUTE 文でパスを示しておけば，有る程度セキュリティは保てます．もちろん，このパスから，ファイルの存在場所は分かるのですが....．．

　ご参考になれば，幸いです．
 		 

Re: プログラムリストが見れません

 投稿者：山中和義  投稿日：2012年 2月17日(金)17時25分58秒
  > No.1770[元記事へ]

名なしさんさんへのお返事です。

> 以前は、BASファイルのアイコンをクリックすれば、
> BASIC本体の編集ウィンドウがプログラムリストごと起動するようになっていたんですよ。

こちらでは、どうでしょうか？

Full BASICと十進BASICの Q&A　内
　BASファイルの関連付けの修正
　http://hp.vector.co.jp/authors/VA008683/Assoc.htm
 		 

Re: プログラムリストが見れません

 投稿者：白石和夫  投稿日：2012年 2月19日(日)09時49分23秒
  名なしさんさんへのお返事です。

再セットアップを試みていますか？
アーカイブ版を使っているのなら
http://hp.vector.co.jp/authors/VA008683/basicw32.htm
にセットアップ手順が書いてあります。
インストーラ版だったら，コントロールパネルでアンインストールしてから再実行。
http://hp.vector.co.jp/authors/VA008683/setup.htm
 		 

視力検査

 投稿者：しばっち  投稿日：2012年 2月19日(日)21時22分36秒
  (ご注意)

できるだけモニター画面から離れて(50-500cm程度)行ってください。
画面解像度や距離によっては、文字や図形の表示位置や大きさなどプログラムの一部修正が必要になる場合があります。
測定結果はあくまで参考程度にしてください。信憑性はありません。
一人での実行で操作上困難になる場合は、二人で行うなどしてください。

!'ランドルト環
PUBLIC NUMERIC XSIZE,YSIZE
LET XSIZE=1280 !'画面解像度1280*800(画面のプロパティの「設定」より)
LET YSIZE=800
LET XSIZE=XSIZE-50 !'スクロールバーが出ない程度に(できるだけ広く表示させるため)
LET YSIZE=YSIZE-100
CALL GINIT(XSIZE,YSIZE)
DIM A$(8),S$(13)
MAT READ A$
DATA "1.右","2.右上","3.上","4.左上","5.左","6.左下","7.下","8.右下"
MAT READ S$ !'視力
DATA 0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0,1.2,1.5,2.0
RANDOMIZE
LET MODE=2 !'入力モード
LET L=192 !'←書き換えること。画面上での長さ5cm(※15.4インチモニター、画面解像度1280*800の場合です)
CALL DISPSCALE(L) !'初回実行時のみ。実行2度目以降では変数 L値を書き換え、この行を削除、又は注釈にしてください
INPUT  PROMPT "モニター画面との距離(cm) (50-500)":DISTANCE
WAIT DELAY 2
CALL DISP(XSIZE*.05,YSIZE*.85,YSIZE*.05,7,"LEFT","TOP","画面との距離 " & STR$(DISTANCE) & "cm")
CALL DISP(XSIZE*.2,YSIZE*.7,YSIZE*.06,7,"CENTER","HALF","向き")
FOR I=0 TO 7
   CALL LINE(XSIZE/2,YSIZE*.7,XSIZE/2+XSIZE*.1*COS(I/4*PI),YSIZE*.7-XSIZE*.1*SIN(I/4*PI),7)
   CALL CIRCLEFULL(XSIZE/2+XSIZE*.1*COS(I/4*PI),YSIZE*.7-XSIZE*.1*SIN(I/4*PI),YSIZE*.04,0)
   CALL CIRCLE(XSIZE/2+XSIZE*.1*COS(I/4*PI),YSIZE*.7-XSIZE*.1*SIN(I/4*PI),YSIZE*.04,7)
   CALL DISP(XSIZE/2+XSIZE*.1*COS(I/4*PI),YSIZE*.7-XSIZE*.1*SIN(I/4*PI),YSIZE*.05,7,"CENTER","HALF",STR$(I+1))
NEXT I
DO
   LET MISS=0
   LET N=N+1
   LET D$=S$(N) & "  "
   DO
      CALL BOXFULL(0,0,XSIZE-1,YSIZE*.48,0)
      CALL DISP(XSIZE*.1,YSIZE*.25,XSIZE*.08,7,"LEFT","HALF",S$(N))
      LET R=1.5*L/20/VAL(S$(N))*DISTANCE/500
      IF R<4 THEN !'半径4dot未満で測定中止(判別不可能)
         CALL BOXFULL(0,0,XSIZE-1,YSIZE*.48,0)
         CALL DISP(XSIZE*.5,YSIZE*.15,YSIZE*.05,7,"CENTER","BOTTOM","これ以上測定できません")
         CALL DISP(XSIZE*.5,YSIZE*.21,YSIZE*.05,7,"CENTER","BOTTOM","あなたの視力は" & S$(N-1) & "以上です")
         STOP
      END IF
      LET K=INT(RND*8)
      CALL CIRCLEFULL(XSIZE/2,YSIZE*.25,R,7) !'ランドルト環表示
      CALL CIRCLEFULL(XSIZE/2,YSIZE*.25,R*.6,0)
      DRAW BOX(R) WITH ROTATE(-K*PI/4)*SHIFT(XSIZE/2,YSIZE*.25)
      SELECT CASE MODE
      CASE 0
         INPUT  PROMPT "向き (1 - 8)":H
      CASE 1
         LOCATE CHOICE(A$) : H
      CASE 2
         CALL GETNUM(H)
      END SELECT
      IF H<>(K+1) THEN
         CALL BOXFULL(0,0,XSIZE-1,YSIZE*.48,0)
         CALL DISP(XSIZE/2,YSIZE*.25,XSIZE*.08,2,"CENTER","HALF","不正解")
         LET D$=D$ & "×"
         LET MISS=MISS+1
      ELSE
         CALL BOXFULL(0,0,XSIZE-1,YSIZE*.48,0)
         CALL DISP(XSIZE/2,YSIZE*.25,XSIZE*.08,2,"CENTER","HALF","正解")
         LET D$=D$ & "○"
      END IF
      IF N<10 THEN
         CALL DISP(XSIZE*.65,YSIZE/2+YSIZE*.04*N,YSIZE*.03,7,"LEFT","HALF",D$)
      ELSE
         CALL DISP(XSIZE*.83,YSIZE/2+YSIZE*.04*(N-9),YSIZE*.03,7,"LEFT","HALF",D$)
      END IF
      WAIT DELAY 1.2
      IF MISS=2 THEN !'連続ミス2回で測定終了
         CALL BOXFULL(0,0,XSIZE-1,YSIZE*.48,0)
         IF N=1 THEN
            CALL DISP(XSIZE*.5,YSIZE*.2,YSIZE*.05,7,"CENTER","BOTTOM","あなたの視力は0.1未満です")
         ELSE
            CALL DISP(XSIZE*.5,YSIZE*.2,YSIZE*.05,7,"CENTER","BOTTOM","あなたの視力は" & S$(N-1) & "です")
         END IF
         STOP
      END IF
   LOOP WHILE H<>(K+1)
LOOP UNTIL N=13
CALL BOXFULL(0,0,XSIZE-1,YSIZE*.48,0)
CALL DISP(XSIZE*.5,YSIZE*.2,YSIZE*.05,7,"CENTER","BOTTOM","あなたの視力は" & S$(N) & "です")
END

EXTERNAL  SUB GETNUM(K) !'マウス操作による入力
CALL DISP(XSIZE/2,YSIZE*.95,YSIZE*.03,3,"CENTER","HALF","数字をクリックしてください")
DO
   DO
      LET XX=X
      LET YY=Y
      MOUSE POLL X,Y,LEFT,RIGHT
   LOOP WHILE X=XX AND Y=YY AND LEFT=0 AND RIGHT=0
   FOR I=0 TO 7
      LET XO=XSIZE/2+XSIZE*.1*COS(I/4*PI)
      LET YO=YSIZE*.7-XSIZE*.1*SIN(I/4*PI)
      IF SQR((X-XO)^2+(Y-YO)^2)<YSIZE*.05 THEN
         CALL CIRCLEFULL(XSIZE/2+XSIZE*.1*COS(I/4*PI),YSIZE*.7-XSIZE*.1*SIN(I/4*PI),YSIZE*.04,4)
         CALL DISP(XSIZE/2+XSIZE*.1*COS(I/4*PI),YSIZE*.7-XSIZE*.1*SIN(I/4*PI),YSIZE*.05,2,"CENTER","HALF",STR$(I+1))
         IF LEFT=1 OR RIGHT=1 THEN
            LET K=I+1
            EXIT SUB
         END IF
      ELSE
         CALL CIRCLEFULL(XSIZE/2+XSIZE*.1*COS(I/4*PI),YSIZE*.7-XSIZE*.1*SIN(I/4*PI),YSIZE*.04,0)
         CALL CIRCLE(XSIZE/2+XSIZE*.1*COS(I/4*PI),YSIZE*.7-XSIZE*.1*SIN(I/4*PI),YSIZE*.04,7)
         CALL DISP(XSIZE/2+XSIZE*.1*COS(I/4*PI),YSIZE*.7-XSIZE*.1*SIN(I/4*PI),YSIZE*.05,7,"CENTER","HALF",STR$(I+1))
      END IF
   NEXT I
LOOP
END SUB

EXTERNAL  PICTURE BOX(R)
SET AREA COLOR 0
PLOT AREA: 0,0-R*.2;0,0+R*.2;0+R*1.1,0+R*.2;0+R*1.1,0-R*.2
END PICTURE

EXTERNAL  SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW  0 , XSIZE-1 , YSIZE-1, 0
SET POINT STYLE  1
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 1,1,1
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 0,0,0
CLEAR
END SUB

EXTERNAL  SUB DISPSCALE(L) !'画面にものさしをあてて調整して下さい。初回実行時は要調整
CALL DISP(XSIZE*.5,YSIZE*.18,YSIZE*.04,7,"CENTER","HALF","下記目盛りの長さが5cmになるように調整してください")
CALL DISP(XSIZE*.15,YSIZE*.7,YSIZE*.03,7,"CENTER","HALF","'+' or '-' Key")
CALL DISP(XSIZE*.15,YSIZE*.8,YSIZE*.03,7,"CENTER","HALF","SPACE Key")
DO
   CALL BOXFULL(XSIZE*.1,YSIZE*.25,XSIZE,YSIZE*.65,0)
   CALL LINE(XSIZE*.5-100,YSIZE*.3124,XSIZE*.5-100+L,YSIZE*.3124,7)
   FOR I=0 TO 5
      IF I=0 OR I=5 THEN LET K=YSIZE*.0125 ELSE LET K=0
      CALL LINE(XSIZE*.5-100+I*L/5,YSIZE*.3062-K,XSIZE*.5-100+I*L/5,YSIZE*.3187+K,7)
   NEXT I
   CALL DISP(XSIZE/2,YSIZE*.55,YSIZE*.04,7,"CENTER","HALF","L=" & STR$(L))
   CHARACTER INPUT S$
   IF S$="+" THEN LET L=L+1
   IF S$="-" THEN LET L=L-1
LOOP UNTIL S$=" " OR S$="　"
CLEAR
END SUB

EXTERNAL  SUB DISP(X,Y,H,C,M$,N$,MES$)
SET TEXT HEIGHT H
SET TEXT COLOR C
SET TEXT JUSTIFY M$,N$
PLOT TEXT ,AT X,Y:MES$
END SUB

EXTERNAL  SUB CIRCLEFULL(X,Y,RR,C)
SET COLOR C
DRAW DISK WITH SCALE(RR)*SHIFT(X,Y)
END SUB

EXTERNAL  SUB CIRCLE(X,Y,RR,C)
SET COLOR C
DRAW CIRCLE WITH SCALE(RR)*SHIFT(X,Y)
END SUB

EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
SET AREA COLOR C
PLOT AREA: X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
END SUB

EXTERNAL  SUB LINE(XS,YS,XE,YE,C)
SET LINE COLOR C
PLOT LINES
PLOT LINES: XS,YS;XE,YE
END SUB
 		 

平方魔方陣への挑戦

 投稿者：GAI  投稿日：2012年 2月22日(水)11時27分53秒
  > > A^2  B^2  C^2
> > D^2  E^2  F^2
> > G^2  H^2  I^2
> > の計算で魔方陣となる配列がとれるか探せるものでしょうか？
>
> 汎用的には、バックトラック法で解決します。
> 和をSとして、0≦A,B,C≦Sがおおざっぱな候補ですが、
> 1行目は、A^2+B^2+C^2=Sですから、
> Aは、A^2≦S
> Bは、A^2+B^2≦S
> Cは、A^2+B^2+C^2=S
> を満たさないといけません。

以前このヒントを頂き、これを４×４の平方魔方陣して

68^2  29^2  41^2  37^2

17^2  31^2  79^2  32^2

59^2  28^2  23^2  61^2

11^2  77^2   8^2  49^2

（1770年にオイラーがラグランジュへ教えたの記事を見る。）
の組合せをコンピュータで見つけ出そうとプログラムを４×４用に変更し、三日三晩走らせ続けましたが、いつ果てるかわからない計算をし続けるばかりで、一向に求めたい組合せをはじき出す様子がありません。

この解を求めるためには、なにか別の工夫や使える定理などがあるのでしょうか？

さらに調べものをしていましたら、

25^2  45^2  15^2  14^2  44^2   5^2  20^2

16^2  10^2  22^2   6^2  46^2  26^2  42^2

48^2   9^2  18^2  41^2  27^2  13^2  12^2

34^2  37^2  31^2  33^2   0^2  29^2   4^2

19^2   7^2  35^2  30^2   1^2  36^2  40^2

21^2  32^2   2^2  39^2  23^2  43^2   8^2

17^2  28^2  47^2   3^2  11^2  24^2  38^2

(0^2から48^2まで連続する整数の平方で構成されている。)
などが見つかっており、これはいったいコンピュータの仕事で可能なのかと不思議に感じてしまいます。

 		 

RSA暗号についての疑問

 投稿者：GAI  投稿日：2012年 2月24日(金)13時44分41秒
  これは自分なりの解釈なので、間違っている可能性が大ですが次の点が疑問に感じます。
ご指摘して下さい。

Ａ氏からＢ氏へメッセージを送るとする。
Ａ氏は２つの公開鍵e,n(=p×qの２つの素数の積)を発表しておく。
（メッセージ）＾e≡信号　（mod(n))
として、信号を送る。

一方Ｂ氏は公開されている公開鍵から
modinv(e,(p-1)(q-1))=d を秘密鍵として入手し
(このmodinv関数は山中氏のプログラム”UBASICの移植(整数論)"中に組まれている関数）
（信号）＾ｄ≡メッセージ　（mod(n))
でＡ氏のメッセージを受け取る。

ここで疑問に感じることは、この暗号がｎの素因数分解の困難さにその機密性の要因をもつなら、Ｂ氏が秘密鍵を入手する手段でnの素因数p,qを利用している所です。

公開鍵と秘密鍵の関係はどのようになっているものか、解りやすく説明願えませんか？




 		 

Re: RSA暗号についての疑問

 投稿者：山中和義  投稿日：2012年 2月24日(金)14時56分59秒
  > No.1778[元記事へ]

GAIさんへのお返事です。

> 公開鍵と秘密鍵の関係はどのようになっているものか、解りやすく説明願えませんか？

第3回　公開鍵と秘密鍵を作るアルゴリズム
http://itpro.nikkeibp.co.jp/article/COLUMN/20071031/286010/
 		 

だまし絵のしくみ

 投稿者：SECOND  投稿日：2012年 2月24日(金)19時38分17秒
  !だまし絵のしくみ
!------------------------------->
SET TEXT JUSTIFY "center","half"
SET WINDOW -1,13, -10,4
!---
DO
   CALL type(3,2)
   CALL type(4,2)       !(周期分割のインターバル幅, インターバル回数)
   CALL type(2,3)
   CALL type(1,5)
LOOP

SUB type(C,n)           !( C=周期分割のインターバル幅, n=インターバル回数)
   CLEAR
   DRAW grid
   PLOT TEXT,AT 4.4, 3.3:"だまし絵のしくみ。　周期分割インターバル "& STR$(C)
   PLOT TEXT,AT 4.4,-7.3:"左クリック：次へ進む。　右クリック：終了。"
   LET L=1                                !棒の長さ
   LET P=n                                !C=１   の周期 P=n     (棒の個数)
   IF C=1 THEN LET n=1 ELSE LET P=C*n-1   !C=２～ の周期 P=C*n-1 (棒の個数)
   !---
   DRAW cheat(n,  L, 0,n, 40,0)
   DRAW cheat(n,  L, n,P, 39,2)
   DRAW cheat(n, -L, 0,P, 15,1)
   !---
   DRAW cheat(n,  L, 0,n, 40,2) WITH SHIFT(P-n, -4)
   DRAW cheat(n,  L, n,P, 39,0) WITH SHIFT( -n, -4)
   DRAW cheat(n, -L, 0,P, 15,1) WITH SHIFT(  0, -4)
   DO
      LET mlbak=mlb
      WAIT DELAY .05
      mouse poll x,y,mlb,mrb
      IF 0< mrb THEN STOP
   LOOP UNTIL mlbak< mlb
END SUB

PICTURE cheat(n, L, x1,x2, col,txt)
   SET AREA COLOR col
   PLOT AREA: x1,0; x2,0; x2,L*1.3; x1,L*1.3
   SET LINE width 5
   FOR i=0 TO P-1
      LET x=MOD(i*n, P)+.5
      IF x1< x AND x< x2 THEN
         LET y=ABS(L)/(P-1)*i+(L-ABS(L))/2
         PLOT LINES: x, y; x, 0
         PLOT TEXT,AT x, L*1.5-.03: STR$(i+1)
      END IF
   NEXT i
   SET LINE width 1
   IF txt=>1 THEN PLOT TEXT,AT x2+1.3, L*1.5-.03: "← 位相番号"
   IF txt=2 THEN PLOT TEXT,AT x2+2, L*.7-.03: "← 左右 絵の逆置き"
END PICTURE

END
 

不具合 - 配列の宣言文

 投稿者：山中和義  投稿日：2012年 2月26日(日)10時18分2秒
  DIM A(0 TO INT(4,4))
END

「)が必要です」の警告が表示される。
「いいえ」を選ぶと、翻訳時内部エラーとなる。

DIM A(-1 TO 1//2)
END

のような不正な計算式を含む場合に発生する。



DIM A(INT(4,4))
END

では、ＯＫである。
 		 

Re: 不具合 - 配列の宣言文

 投稿者：白石和夫  投稿日：2012年 2月26日(日)15時40分39秒
  > No.1782[元記事へ]

ご報告ありがとうございました。
原因は特定できたので，修正版を作ります。


> DIM A(0 TO INT(4,4))
> END
>
> 「)が必要です」の警告が表示される。
> 「いいえ」を選ぶと、翻訳時内部エラーとなる。
>
> DIM A(-1 TO 1//2)
> END
>
> のような不正な計算式を含む場合に発生する。
>
>
>
> DIM A(INT(4,4))
> END
>
> では、ＯＫである。
> 		 

ユーザー・レポート

 投稿者：SECOND  投稿日：2012年 2月28日(火)15時01分38秒
  CALL test(1/3)

SUB test(n)
   LET xm=n
   IF xm=n THEN PRINT "xm=n"  ELSE PRINT "xm<>n"
END SUB

END

!※実行結果が、DECIMAL 及び DECIMAL_HIGH で、xm<>n
!　引数ｎは、丸められていないのでしょうか。
 		 

Re: ユーザー・レポート

 投稿者：白石和夫  投稿日：2012年 2月28日(火)16時22分46秒
  > No.1791[元記事へ]

ご報告ありがとうございます。
数値変数が中間結果の値をもつのはまずいような気がするので，規格を詳細に検討してみます。
 		 

そんなのある？

 投稿者：ＧＡＩ  投稿日：2012年 2月28日(火)19時57分0秒
  10桁のランダムな数字を書いた時
そこに使用した各数字の頻度を表にすることを考える。（０，１，２，３・・の順で）

ランダムな数字：2 9 8 4 0 2 8 3 9 9・・・・①
上の数の各数字の使用頻度調査
　　　　　　　　0 1 2 3 4 5 6 7 8 9 の数字が
　　　　　　　　1 0 2 1 1 0 0 0 2 3・・・・②の回数での使用頻度となる。

ここで、①でのランダムな数字と調査結果の②の数字がピタリ一致するものを探すことがしたい。
果たして、この条件を満たす１０桁の数は存在するか？
また存在すれば何個あるのか？

これをプログラムに組んで頂きたいです。
 		 

Re: そんなのある？

 投稿者：山中和義  投稿日：2012年 3月 2日(金)10時35分34秒
  > No.1794[元記事へ]

ＧＡＩさんへのお返事です。

> 10桁のランダムな数字を書いた時
> そこに使用した各数字の頻度を表にすることを考える。（０，１，２，３・・の順で）
>
> ランダムな数字：2 9 8 4 0 2 8 3 9 9・・・・①
> 上の数の各数字の使用頻度調査
> 　　　　　　　　0 1 2 3 4 5 6 7 8 9 の数字が
> 　　　　　　　　1 0 2 1 1 0 0 0 2 3・・・・②の回数での使用頻度となる。
>
> ここで、①でのランダムな数字と調査結果の②の数字がピタリ一致するものを探すことがしたい。
> 果たして、この条件を満たす１０桁の数は存在するか？
> また存在すれば何個あるのか？


単純に考えると、総当りとなるが、これも、PCでは困難です。。。

  LET P=5 !p進法p桁
  DIM A(0 TO P-1) !使用頻度
  DIM B(0 TO P-1) !各桁の数値　※B(0)が最上位
  FOR i=P^(P-1) TO P^P-1 !p桁の範囲
  !FOR i=6210001000 TO 10^10-1 !10桁の範囲
     MAT A=ZER
     LET t=i
     FOR k=0 TO P-1 !1p進法p桁へ（進数変換）
        LET w=MOD(t,P)
        LET A(w)=A(w)+1
        LET B((P-1)-k)=w
        LET t=INT(t/P)
     NEXT k
     FOR k=0 TO P-1 !並びが一致するか
        IF A(k)<>B(k) THEN EXIT FOR
     NEXT k
     IF k>P-1 THEN MAT PRINT A;
  NEXT i
  END


そこで、

10進法10桁の数なので、自然数10の分割を考える。（自然数10を10個の非負の整数の和で表す）
ただし、a[0]≦a[1]≦a[2]≦ … ≦a[8]≦a[9]（昇順に並べたもの）とする。
その組は、
　 1  1  1  1  1  1  1  1  1  1
　 1  1  1  1  1  1  1  1  2  0
　　　　：
　 1  1  2  6  0  0  0  0  0  0 　←　※
　　　　：
　10  0  0  0  0  0  0  0  0  0
の42通り。（この値を分割数という）

この並びを、数 0,1,2,3,4,5,6,7,8,9 の使用頻度とすると、
まず、0に着目すると、
　並びの中に「0の個数」と「数値の1つ」が同じもの
を探す。
すなわち、上記の←が条件を満たす。
同様に、1,2に着目すると、上で選んだ数値を除くことに注意して、上記の※が条件を満たす。
次に、6に着目すると、この並びでは条件を満たさないが、
　 6  2  1  0  0  0  1  0  0  0 　←　※
と並べ替えると条件を満たす。

うまく並べ替えられるかは、
まず、分割した数の並びMの使用頻度Aを求める。
　 M:  1  1  2  6  0  0  0  0  0  0
　　　　↓
　 A:  6  2  1  0  0  0  1  0  0  0
同様に、並びAの使用頻度Bを求める。
　 A:  6  2  1  0  0  0  1  0  0  0
　　　　↓
　 B:  6  2  1  0  0  0  1  0  0  0
それらが一致するかどうかで確認できる。


また、これらのことはn進法n桁でも議論できる。


PUBLIC NUMERIC C !分割数
LET C=0
LET N=10 !n進法n桁
DIM M(0 TO N-1) !数の並び
MAT M=ZER
CALL search(0,0,M,N)
END

EXTERNAL SUB search(p,s,M(),N) !バックトラック法で検索する
IF p=0 THEN LET t=1 ELSE LET t=M(p-1) !昇順
FOR i=t TO N-s !※sは、0から(p-1)番目までの和
   LET M(p)=i !p番目を設定する
   IF s+i=N THEN !条件を満たせば
      LET C=C+1
      CALL try(N,M,C)
   ELSE
      CALL search(p+1,s+i,M,N) !次へ
   END IF
   LET M(p)=0 !元に戻す
NEXT i
END SUB

EXTERNAL SUB try(N,M(),C)
DIM A(0 TO N),B(0 TO N) !※Nは、10,0,0,…,0のような並びに対応するため
MAT A=ZER !並びMの使用頻度Aを求める
FOR i=0 TO N-1
   LET t=M(i)
   LET A(t)=A(t)+1
NEXT i
MAT B=ZER !並びAの使用頻度Bを求める
FOR i=0 TO N-1
   LET t=A(i)
   LET B(t)=B(t)+1
NEXT i
FOR i=0 TO N-1 !並びA,Bが同じかどうか確認する
   IF A(i)<>B(i) THEN EXIT FOR
NEXT i
IF i>N-1 THEN
   FOR j=0 TO N-1 !結果を表示する
      PRINT B(j);
   NEXT j
   PRINT
END IF
END SUB

 		 

Re: そんなのある？

 投稿者：山中和義  投稿日：2012年 3月 2日(金)15時47分21秒
  > No.1799[元記事へ]

参考サイト　http://en.wikipedia.org/wiki/Self-descriptive_number
 		 

新そんなのある？

 投稿者：ＧＡＩ  投稿日：2012年 3月 2日(金)19時47分51秒
  > No.1800[元記事へ]

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

例のオンライン整数列辞典
http://oeis.org/A046043
にたどり着きました。（既にいろいろな人が調べつくしているものですね。）

このごろ凄いと思った数列に　Gobel's Sequence
というものがあることを知りました。

x0=1
x1=(1+x0^2)/1
x2=(1+x0^2+x1^2)/2
x3=(1+x0^2+x1^2+x2^2)/3
・・・・・
xn=(1+x0^2+x1^2+x2^2+・・・・+xn-1^2)/n

と次々と数を生み出して行くと、
1,2,3,5,10,28,154,・・・となって奇跡のように項が整数になっていくようだが、なんと
x1,x2,x3,・・・,x42 までは順調に（奇跡的に）整数が揃っていくがx43で初めて分数が現れるという。
これは数字が急速に大きくなっていくので、確かめられずにいます。

信じてよいものでしょうか？

 		 
 

交点を求める

 投稿者：エス・テーﾒｰﾙ  投稿日：2012年 3月 6日(火)11時49分9秒
  いつも十進ベーシックを利用させて頂いています。有難うございます。
今回、十進ベーシックを使って、円：x^2+y^2+Ax+By+C=0 と 放物線：y=px^2+qx+r の交点を
求めるプログラムをつくろうとしたのですが、どのようなプログラムをつくればよいのか全くわかりません。どなたかお教え下さい。お願い致します。 		 

Re: 交点を求める

 投稿者：山中和義  投稿日：2012年 3月 6日(火)15時28分20秒
  > No.1802[元記事へ]

エス・テーさんへのお返事です。

> 今回、十進ベーシックを使って、円：x^2+y^2+Ax+By+C=0 と 放物線：y=px^2+qx+r の交点を
> 求めるプログラムをつくろうとしたのですが、どのようなプログラムをつくればよいのか全くわかりません。

　円: x^2+y^2+Ax+By+C=0　←式1
　放物線: y=Px^2+Qx+R　←式2
とすると、
式1に式2を代入して、yを消去する。
　x^2+(Px^2+Qx+R)^2+Ax+B(Px^2+Qx+R)+C=0
　x^2+((Px^2+Qx)+R)^2+Ax+B(Px^2+Qx+R)+C=0
　x^2+(Px^2+Qx)^2+2R(Px^2+Qx)+R^2+Ax+B(Px^2+Qx+R)+C=0
　x^2+P^2x^4+2PQx^3+Q^2x^2+2PRx^2+2QRx+R^2+Ax+BPx^2+BQx+BR+C=0
整理して、
　P^2x^4+2PQx^3+(Q^2+2PR+BP+1)x^2+(2QR+A+BQ)x+(R^2+BR+C)=0

この4次方程式の実数解は、（実数解でなくてもよい）
　代数
　・オイラー（Euler）の方法

　数値計算
　・DKA法
などの解法があります。詳しい説明は、数値計算の文献を参照してください。

ここでは、
　数値計算
　　因数分解して、次数を下げていく
　　・ニュートン法＋組立除法
で求めてみました。

また、計算結果の確認のため、作図関連のプログラムも組み込んでみました。（半分程度）



!図形と方程式

SET WINDOW -8,8,-8,8 !表示領域を設定する　※調整が必要である
DRAW grid !XY座標

PUBLIC NUMERIC gcCOLOR,gcSTYLE,gcLINESTYLE !描画色、線種
LET gcCOLOR=1 !黒色
LET gcLINESTYLE=1 !実線
!------------------------------ ここまでがサブルーチン


LET A=2 !円x^2+y^2+Ax+By+C=0
LET B=-3
LET C=-20
CALL gcDRAWCIRCLE(A,B,C) !円を描く

LET P=1 !放物線y=Px^2+Qx+R
LET Q=2
LET R=-4
CALL gcDRAWFNC2(P,Q,R, -10,10) !放物線を描く



!ニュートン法による１変数の代数方程式の根

LET N=4 !ｎ次
DIM D(0 TO N) !x^nの係数  d(n)*x^n+d(n-1)*x^(n-1)+ … +d(1)*x+d(0)

LET D(4)=P^2
LET D(3)=2*P*Q
LET D(2)=Q^2+2*P*R+B*P+1
LET D(1)=2*Q*R+A+B*Q
LET D(0)=R^2+B*R+C


!ニュートン法で零点（根）を求める

LET cEps=1e-10 !精度  ※要調整

LET M=N
FOR i=1 TO N !ｎ個

   LET Xk=COS((4*i-1)*PI/(4*M+2)) !近似根

   LET iter=200 !反復回数
   FOR k=1 TO iter
      CALL FxdFx(M,D,Xk, f,df) !f(Xk),f'(Xk)の算出
      LET WXk=Xk-f/df !Xk+1=Xk-f(Xk)/f'(Xk)
      IF ABS(WXk-Xk)<=ABS(Xk)*cEps THEN EXIT FOR !収束すれば終了
      LET Xk=WXk !次へ
   NEXT k
   IF k>iter THEN
      PRINT iter;"回では収束しません。"
      STOP
   END IF

   PRINT USING "## ###.###############": i,Xk

   CALL gcDRAWPOINT(Xk,P*Xk^2+Q*Xk+R) !交点を描く


   DIM QQ(0 TO N) !組立除法で、f(x)=(x-α)Q(x)と因数分解する
   CALL poly_divByLin(M,D,Xk, QQ,RR)
   MAT D=QQ !copy it
   LET M=M-1 !次数を下げる

NEXT i


END


EXTERNAL SUB FxdFx(N,A(),x0, f,df) !関数値f(x0)と微分係数f'(x0)を求める　※n≧1
LET f=A(N)
LET df=f
FOR j=N-1 TO 1 STEP -1 !ホーナー法（組立除法）
   LET f=f*x0+A(j)
   LET df=df*x0+f
NEXT j
LET f=f*x0+A(0)
END SUB

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



!作図ルーチン

EXTERNAL SUB gcDRAWPOINT(x,y) !点(x,y)を描く
SET AREA COLOR gcCOLOR
DRAW disk WITH SCALE(0.15)*SHIFT(x,y) !※拡大率0.1は調整が必要である
END SUB

EXTERNAL SUB gcDRAWCIRCLE(A,B,C) !円x^2+y^2+Ax+By+C=0を描く
LET RR=(A^2+B^2)/4-C !判別式
IF RR>=0 THEN
   SET LINE COLOR gcCOLOR
   SET LINE STYLE gcLINESTYLE

   LET CX=-A/2 !中心
   LET CY=-B/2
   LET R=SQR(RR) !半径
   FOR i=0 TO 360 !(x-CX)^2+(y-CY)^2=R^2として描く
      PLOT LINES: R*COS(RAD(i))+CX,R*SIN(RAD(i))+CY;
   NEXT i
   PLOT LINES
ELSE
   PRINT "半径が負なので、円が成立しません。"; A;B;C
END IF
END SUB

EXTERNAL SUB gcDRAWFNC2(A,B,C,d1,d2) !2次関数y=Ax^2+Bx+C、x=[d1,d2]を描く
IF A=0 THEN
   PRINT "A=0なので、2次関数ではありません。"; A;B;C
ELSE
   ASK WINDOW x1,x2,y1,y2
   LET x1=MAX(x1,d1)
   LET x2=MIN(x2,d2)
   SET LINE COLOR gcCOLOR
   FOR x=x1 TO x2 STEP 1/2^8 !※折れ線による
      PLOT LINES: x,A*x^2+B*x+C;
   NEXT x
   PLOT LINES
END IF
END SUB
 

Re: 平方魔方陣への挑戦

 投稿者：山中和義  投稿日：2012年 3月 6日(火)15時43分14秒
  > No.1776[元記事へ]

GAIさんへのお返事です。

> ４×４の平方魔方陣して
>
> 68^2  29^2  41^2  37^2
>
> 17^2  31^2  79^2  32^2
>
> 59^2  28^2  23^2  61^2
>
> 11^2  77^2   8^2  49^2
>
> （1770年にオイラーがラグランジュへ教えたの記事を見る。）

30分程度で解を見つけることができます。この魔方陣専用のコーディングになっています。

斜め　高々C(212,2)×4!/2×4!/2通り
1行目　高々210×2!通り
これを埋めることによって、
　2列目　高々209通り
　3列目　高々208通り
　4行目　高々207通り
が確定する。
同様に、
1列目　高々206×2!通り
　2行目　高々205通り
　3行目　高々204通り
　4列目　高々203通り
で確認しています。


!平方数による４×４魔方陣

!実行結果
!
!No. 1
! 105  181  77  193  82  198  101  179  145  203
!
! 11  77  8  49
! 59  28  23  61
! 17  31  79  32
! 68  29  41  37
!
!No. 2
! 105  181  77  82  193  198  101  145  179  203
!
! 11  8  77  49
! 17  79  31  32
! 59  23  28  61
! 68  41  29  37
!
!No. 3
! 105  181  179  101  203  145  193  77  198  82
!
! 28  59  61  23
! 77  11  49  8
! 29  68  37  41
! 31  17  32  79
!
!No. 4
! 105  181  179  203  101  145  193  198  77  82
!
! 28  61  59  23
! 29  37  68  41
! 77  49  11  8
! 31  32  17  79


LET t0=TIME


PUBLIC NUMERIC S !和（魔法数）
LET S=29^2+37^2+41^2+68^2
PRINT S


PUBLIC NUMERIC H(0 TO 500,4) !和Sを4つの平方数で表現する　S=A^2+B^2+C^2+D^2、ただし、A＜B＜C＜D
MAT H=ZER

PUBLIC NUMERIC X !その個数
LET X=0

FOR A=0 TO S !A^2＜S/4
   LET AA=A*A
   IF 4*AA>S THEN EXIT FOR !これ以上は不適切な値である
   FOR B=A+1 TO S
      LET BB=B*B
      IF AA+3*BB>S THEN EXIT FOR
      FOR C=B+1 TO S
         LET CC=C*C
         IF AA+BB+2*CC>S THEN EXIT FOR
         FOR D=C+1 TO S !S/4＜D^2
            LET DD=D*D
            IF AA+BB+CC+DD>S THEN EXIT FOR

            IF AA+BB+CC+DD=S THEN !平方数の組(A,B,C,D)を表示する
               LET X=X+1 !平方数の候補、その個数
               LET H(X,1)=A
               LET H(X,2)=B
               LET H(X,3)=C
               LET H(X,4)=D
               PRINT X;" (";STR$(A);",";STR$(B);",";STR$(C);",";STR$(D);")"
            END IF

         NEXT D
      NEXT C
   NEXT B
NEXT A
IF X>10 THEN

!和S=8515を、4つの平方和で表す。この場合、212組ある。
!解は、この212個の組から縦・横・斜めの計10個を選んでうまく並べられたものである。
!
!212個の組から10個を選ぶとき、16個の数値はすべて異なるものである。
!
!解の場合、(77,82,101,105,145,179,181,193,198,203)である。
!実際の数値の並びは、
!　　　 11   77    8   49 |  77
!　　　 59   28   23   61 | 179
!　　　 17   31   79   32 | 145
!　　　 68   29   41   37 | 198
! ----+-------------------+
! 181  101  193   82  203   105
!である。

   PUBLIC NUMERIC F(0 TO 100) !数値の使用回数
   PUBLIC NUMERIC Q1(4),Q2(4) !2つの斜めの数値の並べ方
   PUBLIC NUMERIC R(10) !組10個を選ぶ

   PUBLIC NUMERIC M(16) !魔方陣 4x4

   PUBLIC NUMERIC Z !解の数
   LET Z=0

   !●条件　斜めの2つを選ぶ。8個の数値はすべて異なる。
   !H(R(1),*)={A,B,C,D}、H(R(2),*)={E,F,G,H}とすると、
   ! A * * E
   ! * B F *
   ! * G C *
   ! H * * D

   FOR i=1 TO X-1 !高々C(X,2)通り
      MAT F=ZER
      FOR u=1 TO 4
         LET F(H(i,u))=1
      NEXT u
      LET R(1)=i !1つ目を組iとする

      DIM W(0 TO 100) !save it
      MAT W=F
      FOR j=i+1 TO X
         FOR u=1 TO 4
            LET t=H(j,u)
            IF F(t)=1 THEN EXIT FOR
            LET F(t)=1
         NEXT u
         IF u>4 THEN !異なる8個の数の並びなら

            LET R(2)=j !1つ目を組jとする
            PRINT i;j; Z !debug　←←←←←

            FOR u=0 TO FACT(4)-1 !(4!/2)通り
               CALL Num2PermFactorial(u, Q1,4)
               IF Q1(1)<Q1(4) THEN !※対称性を除く
                  LET M(1)=H(i,Q1(1)) !仮に置いてみる
                  LET M(6)=H(i,Q1(2))
                  LET M(11)=H(i,Q1(3))
                  LET M(16)=H(i,Q1(4))

                  FOR v=0 TO FACT(4)-1 !(4!/2)通り
                     CALL Num2PermFactorial(v, Q2,4)
                     IF Q2(1)<Q2(4) THEN !※対称性を除く

                        LET M(4)=H(j,Q2(1)) !仮に置いてみる
                        LET M(7)=H(j,Q2(2))
                        LET M(10)=H(j,Q2(3))
                        LET M(13)=H(j,Q2(4))

                        !  1  *  *  4　← 1行目
                        !  *  6  7  *
                        !  * 10 11  *
                        ! 13 14 15 16
                        CALL try1row(1, M(1),M(4)) !1行目へ

                     END IF
                  NEXT v

               END IF
            NEXT u

         END IF
         MAT F=W !restore it
      NEXT j
   NEXT i

END IF


PRINT "実行時間=";TIME-t0

END


EXTERNAL SUB try1row(p, s1,s2) !バックトラック法で検索する（1行目）　高々210*(2!)通り
DIM W(0 TO 100) !save it
MAT W=F

FOR i=1 TO X !組が重複しないようにする
   FOR u=1 TO p+2-1
      IF i=R(u) THEN EXIT FOR
   NEXT u
   IF u>p+2-1 THEN

      LET tt=0
      FOR u=1 TO 4 !この「数値」を含む必要がある
         LET t=H(i,u)
         IF (t=s1 OR t=s2) THEN LET tt=tt+1
      NEXT u
      IF tt=2 THEN

      !●条件　「3箇所現れる数」が8個、「2箇所現れる数」が8個となる。
      !　数値の発生分布
      !　　3223　← 1行目
      !　　2332
      !　　2332
      !　　3223
         FOR u=1 TO 4
            LET t=H(i,u)
            LET F(t)=F(t)+1
            IF F(t)>3 THEN EXIT FOR
         NEXT u
         IF u>4 THEN

            LET R(p+2)=i !組iとする

            LET t2=0 !2数を切り出して、並べ替える
            FOR u=1 TO 4
               LET t=H(i,u)
               IF NOT(t=s1 OR t=s2) THEN
                  IF t2=0 THEN
                     LET A=t
                     LET t2=1
                  ELSE
                     LET B=t
                  END IF
               END IF
            NEXT u

            LET M(2)=A
            LET M(3)=B
            CALL try2col(p+1, M(2),M(6),M(10)) !2列目へ

            LET M(2)=B !swap it
            LET M(3)=A
            CALL try2col(p+1, M(2),M(6),M(10)) !2列目へ

         END IF
         MAT F=W !restore it
      END IF

   END IF
NEXT i
END SUB

EXTERNAL SUB try2col(p, s1,s2,s3) !バックトラック法で検索する（2列目）　高々209通り
DIM W(0 TO 100) !save it
MAT W=F

FOR i=1 TO X !組が重複しないようにする
   FOR u=1 TO p+2-1
      IF i=R(u) THEN EXIT FOR
   NEXT u
   IF u>p+2-1 THEN

      LET tt=0
      FOR u=1 TO 4 !この「数値」を含む必要がある
         LET t=H(i,u)
         IF (t=s1 OR t=s2 OR t=s3) THEN
            LET tt=tt+1
         ELSE
            LET V=t
         END IF
      NEXT u
      IF tt=3 THEN

         FOR u=1 TO 4 !●条件　「3箇所現れる数」が8個、「2箇所現れる数」が8個となる。
            LET t=H(i,u)
            LET F(t)=F(t)+1
            IF F(t)>3 THEN EXIT FOR
         NEXT u
         IF u>4 THEN

            LET R(p+2)=i !組iとする

            LET M(14)=V
            CALL try3col(p+1, M(3),M(7),M(11)) !3列目へ

         END IF
         MAT F=W !restore it
      END IF

   END IF
NEXT i
END SUB

EXTERNAL SUB try3col(p, s1,s2,s3) !バックトラック法で検索する（3列目）　高々208通り
DIM W(0 TO 100) !save it
MAT W=F

FOR i=1 TO X !組が重複しないようにする
   FOR u=1 TO p+2-1
      IF i=R(u) THEN EXIT FOR
   NEXT u
   IF u>p+2-1 THEN

      LET tt=0
      FOR u=1 TO 4 !この「数値」を含む必要がある
         LET t=H(i,u)
         IF (t=s1 OR t=s2 OR t=s3) THEN
            LET tt=tt+1
         ELSE
            LET V=t
         END IF
      NEXT u
      IF tt=3 THEN

         FOR u=1 TO 4 !●条件　「3箇所現れる数」が8個、「2箇所現れる数」が8個となる。
            LET t=H(i,u)
            LET F(t)=F(t)+1
            IF F(t)>3 THEN EXIT FOR
         NEXT u
         IF u>4 THEN

            LET R(p+2)=i !組iとする

            LET M(15)=V
            CALL try4row(p+1, M(13),M(14),M(15),M(16)) !4行目へ

         END IF
         MAT F=W !restore it
      END IF

   END IF
NEXT i
END SUB

EXTERNAL SUB try4row(p, s1,s2,s3,s4) !バックトラック法で検索する（4行目）　高々207通り
DIM W(0 TO 100) !save it
MAT W=F

FOR i=1 TO X !組が重複しないようにする
   FOR u=1 TO p+2-1
      IF i=R(u) THEN EXIT FOR
   NEXT u
   IF u>p+2-1 THEN

      LET tt=0
      FOR u=1 TO 4 !この「数値」を含む必要がある
         LET t=H(i,u)
         IF NOT(t=s1 OR t=s2 OR t=s3 OR t=s4) THEN EXIT FOR
         LET tt=tt+1
      NEXT u
      IF tt=4 THEN

         FOR u=1 TO 4 !●条件　「3箇所現れる数」が8個、「2箇所現れる数」が8個となる。
            LET t=H(i,u)
            LET F(t)=F(t)+1
            IF F(t)>3 THEN EXIT FOR
         NEXT u
         IF u>4 THEN

            LET R(p+2)=i !組iとする

            CALL try1col(p+1, M(1),M(13)) !1列目へ

         END IF
         MAT F=W !restore it
      END IF

   END IF
NEXT i
END SUB


続く
 		 

Re: 平方魔方陣への挑戦

 投稿者：山中和義  投稿日：2012年 3月 6日(火)15時44分43秒
  > No.1804[元記事へ]

続き


!同様に

EXTERNAL SUB try1col(p, s1,s2) !バックトラック法で検索する（1列目）　高々206*(2!)通り
DIM W(0 TO 100) !save it
MAT W=F

FOR i=1 TO X !組が重複しないようにする
   FOR u=1 TO p+2-1
      IF i=R(u) THEN EXIT FOR
   NEXT u
   IF u>p+2-1 THEN

      LET tt=0
      FOR u=1 TO 4 !この「数値」を含む必要がある
         LET t=H(i,u)
         IF (t=s1 OR t=s2) THEN LET tt=tt+1
      NEXT u
      IF tt=2 THEN

         FOR u=1 TO 4 !●条件　「3箇所現れる数」が8個、「2箇所現れる数」が8個となる。
            LET t=H(i,u)
            LET F(t)=F(t)+1
            IF F(t)>3 THEN EXIT FOR
         NEXT u
         IF u>4 THEN

            LET R(p+2)=i !組iとする

            LET t2=0 !2数を切り出して、並べ替える
            FOR u=1 TO 4
               LET t=H(i,u)
               IF NOT(t=s1 OR t=s2) THEN
                  IF t2=0 THEN
                     LET A=t
                     LET t2=1
                  ELSE
                     LET B=t
                  END IF
               END IF
            NEXT u

            LET M(5)=A
            LET M(9)=B
            CALL try2row(p+1, M(5),M(6),M(7)) !2行目へ

            LET M(5)=B !swap it
            LET M(9)=A
            CALL try2row(p+1, M(5),M(6),M(7)) !2行目へ

         END IF
         MAT F=W !restore it
      END IF

   END IF
NEXT i
END SUB


EXTERNAL SUB try2row(p, s1,s2,s3) !バックトラック法で検索する（2行目）　高々205通り
DIM W(0 TO 100) !save it
MAT W=F

FOR i=1 TO X !組が重複しないようにする
   FOR u=1 TO p+2-1
      IF i=R(u) THEN EXIT FOR
   NEXT u
   IF u>p+2-1 THEN

      LET tt=0
      FOR u=1 TO 4 !この「数値」を含む必要がある
         LET t=H(i,u)
         IF (t=s1 OR t=s2 OR t=s3) THEN
            LET tt=tt+1
         ELSE
            LET V=t
         END IF
      NEXT u
      IF tt=3 THEN

         FOR u=1 TO 4 !●条件　「3箇所現れる数」が8個、「2箇所現れる数」が8個となる。
            LET t=H(i,u)
            LET F(t)=F(t)+1
            IF F(t)>3 THEN EXIT FOR
         NEXT u
         IF u>4 THEN

            LET R(p+2)=i !組iとする

            LET M(8)=V
            CALL try3row(p+1, M(9),M(10),M(11)) !3行目へ

         END IF
         MAT F=W !restore it
      END IF

   END IF
NEXT i
END SUB

EXTERNAL SUB try3row(p, s1,s2,s3) !バックトラック法で検索する（3行目）　高々204通り
FOR i=1 TO X !組が重複しないようにする
   FOR u=1 TO p+2-1
      IF i=R(u) THEN EXIT FOR
   NEXT u
   IF u>p+2-1 THEN

      LET tt=0
      FOR u=1 TO 4 !この「数値」を含む必要がある
         LET t=H(i,u)
         IF (t=s1 OR t=s2 OR t=s3) THEN
            LET tt=tt+1
         ELSE
            LET V=t
         END IF
      NEXT u
      IF tt=3 THEN

         FOR u=1 TO 4 !●条件　「3箇所現れる数」が8個、「2箇所現れる数」が8個となる。
            LET t=H(i,u)
            LET F(t)=F(t)+1
            IF F(t)>3 THEN EXIT FOR
         NEXT u
         IF u>4 THEN

            LET R(p+2)=i !組iとする

            LET M(12)=V
            CALL try4col(p+1, M(4),M(8),M(12),M(16)) !4列目へ

         END IF

      END IF

   END IF
NEXT i
END SUB

EXTERNAL SUB try4col(p, s1,s2,s3,s4) !バックトラック法で検索する（4列目）　高々203通り
FOR i=1 TO X !組が重複しないようにする
   FOR u=1 TO p+2-1
      IF i=R(u) THEN EXIT FOR
   NEXT u
   IF u>p+2-1 THEN

      LET tt=0
      FOR u=1 TO 4 !この「数値」を含む必要がある
         LET t=H(i,u)
         IF NOT(t=s1 OR t=s2 OR t=s3 OR t=s4) THEN EXIT FOR
         LET tt=tt+1
      NEXT u
      IF tt=4 THEN

         LET R(p+2)=i !組iとする

         !--------------------
         LET Z=Z+1 !結果を表示する
         PRINT "No.";Z

         MAT PRINT R; !組

         FOR j=1 TO 16 !魔方陣 4x4
            PRINT M(j);
            IF MOD(j,4)=0 THEN PRINT
         NEXT j
         !--------------------

      END IF

   END IF
NEXT i
END SUB



!n!の順列パターン ⇔ 0～(n!-1)の番号

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 !階乗進数の各桁の値＋１　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

 		 

!　観賞グラフ ６２_６２_９２

 投稿者：SECOND  投稿日：2012年 3月 7日(水)07時57分47秒
  !　観賞グラフ ６２_６２_９２
!----------------------------
OPTION ARITHMETIC NATIVE
SET TEXT JUSTIFY "center","half"
DIM rotx(4,4), rotx2(4,4), Axys(4,4), shxyz(4,4), Abak(4,4)
DIM Vi(4), Vo(4), m(4,4)
!
LET imax=3                                !item maxim.
DIM D3( 92+1, 0 TO 10+1, 3), D1(10+1,2)   !(面数, 面の角数+1, xyz), (面の角数+1, xy)
DIM msk(imax, 0 TO 185), cg(imax,3)       !(item数, 写像数), (item数, xyz)
!
DIM p3(0 TO 3, 2), p4(0 TO 4, 2), p5(0 TO 5, 2), p6(0 TO 6, 2), p10(0 TO 10, 2)
!
CALL polygon(3, 1/2, cr3,ir3, p3)     !正３角形, 中心(0,0)底辺(-1/2,-ir3)~(1/2,-ir3)
CALL polygon(4, 1/2, cr4,ir4, p4)     !正４角形, 中心(0,0)底辺(-1/2,-ir4)~(1/2,-ir4)
CALL polygon(5, 1/2, cr5,ir5, p5)     !正５角形, 中心(0,0)底辺(-1/2,-ir5)~(1/2,-ir5)
CALL polygon(6, 1/2, cr6,ir6, p6)     !正６角形, 中心(0,0)底辺(-1/2,-ir6)~(1/2,-ir6)
CALL polygon(10,1/2, cr10,ir10, p10)  !正10角形, 中心(0,0)底辺(-1/2,-ir10)~(1/2,-ir10)

SUB polygon(n, s, cr,ir, p(,))        !n=角数 s=底辺/2 → cr=外接円半径 ir=内接円半径 p(,)=頂点座標
   LET a=PI/n
   LET cr=s/SIN(a)
   LET ir=cr*COS(a)
   FOR i=1 TO n                             !座標 p(0,1),p(0,2) ＝中心(0,0) ＝ｎ角形の重心。
      LET p(i,1)=cr*COS((2*i-1)*a-PI/2)
      LET p(i,2)=cr*SIN((2*i-1)*a-PI/2)
   NEXT i
END SUB

MAT Axys=IDN
MAT rotx=IDN
MAT rotx2=IDN
LET Vi(4)=1
READ x0, y0, hw                             !主画面 中心(x0,y0),縦横半幅hw
DATA  0, .1, 1.5
!
LET Ax=COS(PI*.93)*1.8                      !開始のｚ軸方向( 画面垂直０度からｘ軸回転成分)
LET Ay=SIN(PI*.93)*1.8                      !　　〃　〃　　( 　　　〃　〃　　ｙ軸回転成分)
LET opA=0.3                                 !多面体 開度の振幅
LET opS=0.95                                !多面体 開度のバイアス
LET item=3                                  !開始 item
LET t0=TIME
DO
   SET DRAW mode hidden
   CLEAR
   LET sq=0
   LET sq0=0
   CALL control_
   SELECT CASE item
   CASE 1
      CALL mat_rotx(rotx, op1*PI/5.675)        !６２面体　５角～４角 折り角
      CALL mat_rotx(rotx2, op1*PI/8.61)        !　　　　　４角～３角 折り角
      DRAW D62_320430512 WITH SCALE(.4)*ROTATE(Az)*shxyz*Axys
   CASE 2
      CALL mat_rotx(rotx, op1*PI/4.815)        !６２面体　１０角～６角 折り角
      CALL mat_rotx(rotx2, op1*PI/8.61)        !　　　　　６角～４角 折り角
      DRAW D62_4306201012 WITH SCALE(.24)*ROTATE(Az)*shxyz*Axys
   CASE 3
      CALL mat_rotx(rotx, op1*PI/6.65)         !９２面体　５角～３角 折り角
      CALL mat_rotx(rotx2, op1*PI/11.373)      !　　　　　３角～３角 折り角
      DRAW D92_380512 WITH SCALE(.5)*ROTATE(Az)*shxyz*Axys
   END SELECT
   CALL priority                               !描画
   SET DRAW mode explicit
   !--------------------
   IF msk(item,0)=0 THEN     !各item は初回、標準 折り角 op1=1 で採取画 位置を → msk(item,1~sq0)
      LET msk(item,0)=1      !← 完了マーク。以降 msk(,) を マスク にして画を取捨。
      MAT Axys=Abak          !※Restore Condition《２》
   END IF
   !----------------------
   IF mlb=0 AND DEL=0 THEN
      LET Az=Az-PI/64        !debug rotate Az
      LET ss=ss+PI/48        !debug expand ss
      IF 2*PI<=ss THEN
         LET ss=0
         LET item=MOD(item,imax)+1  !debug increase item
      END IF
      LET op1=MIN(MAX( opA*COS(ss)+opS ,0),1)
   ELSEIF mlb=1 THEN
      LET DEL=10             !「左 click 一時停止」解除から再開までの 遅延回数( *80ms)
   ELSE
      LET DEL=DEL-1
   END IF
   !------------
   WAIT DELAY t2                              !t2: 制御出力の休止秒。
   LET t1=TIME                                !t1: 前の周期の終り。※TIME は 約.05秒毎の更新。
   LET t2=MAX(0,t2+(.08-MOD(t1-t0,86400))/20) !80ms－検出周期(t1-t0)＝偏差 →t2(積分 Gain=1/20)
   LET t0=t1                                  !t0: 次の周期の始め＝ 前の周期の終り
LOOP UNTIL mrb=1             !右クリック

SUB control_
   SET WINDOW x0-hw, x0+hw, y0-hw, y0+hw       !主画面スケール
   mouse poll mx,my,mlb,mrb
   IF msk(item,0)=0 THEN
   !-----initial setup            !各item 初回、op1=1 (標準 折り角)に強制。
      MAT Abak=Axys               !※Save Condition《２》
      MAT Axys=IDN
      MAT shxyz=IDN
      LET op1=1
   ELSE
      PLOT label,AT x0-.2*hw, y0+.95*hw:"左 click 一時停止、drag 手動回転。右 click 終了。"
      !-----click_drag-----
      CALL mat_shxyz( cg(item,1),cg(item,2),cg(item,3))     !重心を原点へ移動する行列 shxyz 作成
      IF mlb=1 THEN
         LET Ax= -(my-mybak)*PI/2              !ドラッグ方向から、軸方向と回転量
         LET Ay= +(mx-mxbak)*PI/2
      END IF
      LET mxbak=mx
      LET mybak=my
      !-----
      LET ar0=SQR(Ax^2+Ay^2)                   !回転の角度(∝マウス・ドラッグの長さ)
      IF ar0<>0 THEN
         LET DIRar0=ANGLE(Ax,Ay)               !軸の角度
         CALL mat_rotx(rotx, ar0)
         MAT Axys=Axys*ROTATE(-DIRar0)*rotx*ROTATE(DIRar0)  !ドラッグ累積 (方向,回転)
         LET Ax=0
         LET Ay=0
      END IF                                   !with ～～*shxyz*Axys の順序で使用。
   END IF
END SUB

SUB priority
   IF msk(item,0)=0 THEN
   !-----initial setup
      CALL centerG                             !初回は、多面体 重心計算のみ、描画なし。
   ELSE
   !-----real draw with priority
      FOR j=1 TO sq
         LET z=1e9
         FOR i=1 TO sq
            IF D3(i,0,3)< z THEN
               LET z=D3(i,0,3)
               LET ib=i                        !ib= ｚ最小(奥) の配列番号。
            END IF
         NEXT i
         LET D3(ib,0,3)=2e9                    !済み。zone out
         !-----
         LET c=ib+1
         SET AREA COLOR c                      !各面の色。
         ASK COLOR MIX(c) r,g,b
         IF .3*r+.59*g+.11*b< .5 THEN SET TEXT COLOR 0 ELSE SET TEXT COLOR 1  !明るさに 対比する文字色
         FOR i=1 TO D3(ib,11,1)
            LET D1(i,1)=D3(ib,i,1)
            LET D1(i,2)=D3(ib,i,2)
         NEXT i
         LET D1(i,1)=D3(ib,1,1)
         LET D1(i,2)=D3(ib,1,2)
         MAT PLOT AREA ,LIMIT i:D1
         MAT PLOT LINES ,LIMIT i:D1
         PLOT label,AT D3(ib,0,1),D3(ib,0,2):STR$(ib)
      NEXT j
      SET TEXT COLOR 1
   END IF
END SUB

SUB centerG                                    !cg(item,1~3) …各多面体の重心座標(x,y,z)
   LET cg(item,1)=0
   LET cg(item,2)=0
   LET cg(item,3)=0
   FOR i=1 TO sq
      LET cg(item,1)=cg(item,1)+D3(i,0,1)      !D3(i,0,1~3) …各面の重心座標(x,y,z)
      LET cg(item,2)=cg(item,2)+D3(i,0,2)
      LET cg(item,3)=cg(item,3)+D3(i,0,3)
   NEXT i
   LET cg(item,1)=cg(item,1)/sq
   LET cg(item,2)=cg(item,2)/sq
   LET cg(item,3)=cg(item,3)/sq
END SUB

!---------プロット配列~配列
PICTURE getpos(n, p(,))         !return with ･･･ 採取画 msk(item,sq0)=1,  重複画 msk(item,sq0)=0
   LET sq0=sq0+1                !呼出し 順番
   IF msk(item,0)=1 AND msk(item,sq0)=0 THEN EXIT PICTURE
   LET sq=sq+1                  !採取画 順番
   MAT m=TRANSFORM
   FOR j=0 TO n                 !各面の、0=重心 1~n=頂点
      LET Vi(1)=p(j,1)
      LET Vi(2)=p(j,2)
      MAT Vo=Vi*m
      LET D3(sq,j,1)=Vo(1)
      LET D3(sq,j,2)=Vo(2)
      LET D3(sq,j,3)=Vo(3)
   NEXT j
   LET D3(sq,11,1)=n                           !n= 各面の角数
   IF msk(item,0)=1 THEN EXIT PICTURE
   FOR i=1 TO sq-1
      IF (D3(i,0,1)-D3(sq,0,1))^2+(D3(i,0,2)-D3(sq,0,2))^2+(D3(i,0,3)-D3(sq,0,3))^2< .05 THEN EXIT FOR
   NEXT i
   IF sq<=i THEN LET msk(item,sq0)=1 ELSE LET sq=sq-1  !採取画 位置の記憶と、重複画の除去
END PICTURE

PICTURE D62_320430512
   DRAW getpos(5, p5)                                                      !基５角
   DRAW D62_320430512_2 WITH SHIFT(0,ir4)*rotx*SHIFT(0,ir5)*ROTATE(-.2*PI) !右上2nd.４角
   DRAW D62_320430512_2 WITH SHIFT(0,ir4)*rotx*SHIFT(0,ir5)*ROTATE( .2*PI) !左上2nd.４角
END PICTURE
PICTURE D62_320430512_2
   DRAW getpos(4, p4)                                                     !2nd.４角
   IF msk(item,sq0)=0 THEN EXIT PICTURE
   DRAW D62_320430512 WITH SHIFT(0,ir5)*rotx*SHIFT(0,ir4)                 !上.基５角
   DRAW getpos(3, p3) WITH SHIFT(0,ir3)*rotx2*SHIFT(0,ir4)*ROTATE(-.5*PI) !右2nd.３角
   IF msk(item,sq0)=0 THEN EXIT PICTURE
   DRAW getpos(3, p3) WITH SHIFT(0,ir3)*rotx2*SHIFT(0,ir4)*ROTATE( .5*PI) !左2nd.３角
END PICTURE

PICTURE D62_4306201012
   DRAW getpos(10, p10)                                                      !基１０角
   DRAW D62_4306201012_2 WITH SHIFT(0,ir6)*rotx*SHIFT(0,ir10)*ROTATE(-.2*PI) !右上2nd.６角
   DRAW D62_4306201012_2 WITH SHIFT(0,ir6)*rotx*SHIFT(0,ir10)*ROTATE( .2*PI) !左上2nd.６角
END PICTURE
PICTURE D62_4306201012_2
   DRAW getpos(6, p6)                                                      !2nd.６角
   IF msk(item,sq0)=0 THEN EXIT PICTURE
   DRAW D62_4306201012 WITH SHIFT(0,ir10)*rotx*SHIFT(0,ir6)*ROTATE( PI/3)  !右上.基１０角
   DRAW D62_4306201012 WITH SHIFT(0,ir10)*rotx*SHIFT(0,ir6)*ROTATE(-PI/3)  !左上.基１０角
   DRAW getpos(4, p4) WITH SHIFT(0,ir4)*rotx2*SHIFT(0,ir6)                 !上2nd.４角
   DRAW getpos(4, p4) WITH SHIFT(0,ir4)*rotx2*SHIFT(0,ir6)*ROTATE(-2/3*PI) !左2nd.４角
   IF msk(item,sq0)=0 THEN EXIT PICTURE
   DRAW getpos(4, p4) WITH SHIFT(0,ir4)*rotx2*SHIFT(0,ir6)*ROTATE(2/3*PI)  !右2nd.４角
END PICTURE

PICTURE D92_380512
   DRAW getpos(5, p5)                                                   !基５角
   DRAW D92_380512_2 WITH SHIFT(0,ir3)*rotx*SHIFT(0,ir5)*ROTATE( .2*PI) !左上2nd.３角
   DRAW D92_380512_2 WITH SHIFT(0,ir3)*rotx*SHIFT(0,ir5)*ROTATE(-.2*PI) !右上2nd.３角
END PICTURE
PICTURE D92_380512_2
   DRAW getpos(3, p3)                                                    !2nd.３角
   IF msk(item,sq0)=0 THEN EXIT PICTURE
   DRAW getpos(3, p3) WITH SHIFT(0,ir3)*rotx2*SHIFT(0,ir3)*ROTATE(-PI/3) !右上2nd.３角
   DRAW D92_380512_3 WITH SHIFT(0,ir3)*rotx2*SHIFT(0,ir3)*ROTATE( PI/3)  !左上3rd.３角
END PICTURE
PICTURE D92_380512_3
   DRAW getpos(3, p3)                                                   !3rd.３角
   DRAW getpos(3, p3) WITH SHIFT(0,ir3)*rotx2*SHIFT(0,ir3)*ROTATE(PI/3) !左上3rd.３角
   DRAW D92_380512 WITH SHIFT(0,ir5)*rotx*SHIFT(0,ir3)*ROTATE(-PI/3)    !右上.基５角
END PICTURE

!---------------------------------
! ｘ軸で 回転する行列 → 配列引数
!(x,y,z,1)| 1,      0,      0, 0 |
!         | 0, cos(a), sin(a), 0 |
!         | 0,-sin(a), cos(a), 0 |
!         | 0,      0,      0, 1 |
!---------------------------------
SUB mat_rotx(m(,), a)
   LET m(2,2)=COS(a)
   LET m(3,2)=-SIN(a)
   LET m(2,3)=SIN(a)
   LET m(3,3)=COS(a)     !他の要素は、呼出し側で管理
END SUB

!-----------------------------
! 平行移動。(sx,sy,sz) → 原点
!(x,y,z,1)|   1,  0,  0, 0 |
!         |   0,  1,  0, 0 |
!         |   0,  0,  1, 0 |
!         | -sx,-sy,-sz, 1 |
!-----------------------------
SUB mat_shxyz( sx,sy,sz)
   LET shxyz(4,1)=-sx
   LET shxyz(4,2)=-sy
   LET shxyz(4,3)=-sz    !他の要素は、呼出し側で管理
END SUB

END
 

交点を求める

 投稿者：エス・テー  投稿日：2012年 3月 7日(水)09時06分58秒
  山中先生、円と放物線の交点を求めるプログラム、説明、本当に有難う御座いました。ニュートン法と組立除法を使ったプログラムは予想もしていませんでしたが、大変参考になりました。と同時にまだまだ勉強不足であることを思い知りました。私には非常に難しいプログラムでした。これからもどうぞよろしくご指導お願い致します。  

平方剰余の相互法則の理解のために

 投稿者：GAI  投稿日：2012年 3月 9日(金)11時37分23秒
  ＜やりたいことのイメージ＞

x^2≡a (mod b) を満たすxが存在するとき、aRb
また、解が存在しないとき、aNb
の記号を使用するものとし
１００までの素数（2の素数を除く）で、4k+1型の素数を赤色（ピーチ味の素数イメージで）、4k+3型の素数を黄色（オレンジ味の素数イメージで）で表示してもらい
これらから作られる全ての組合せで,ＲかＮを判定しながら


   5Ｎ3, 3Ｎ5
   7Ｒ3, 3Ｎ7
   7Ｎ5, 5Ｎ7
  11Ｎ3, 3Ｒ11
  11Ｒ5, 5Ｒ11
  11Ｒ7, 7Ｎ11
  13Ｒ3, 3Ｒ13
  .........
  .........
というようにＲかＮを判定しながら、元の式と入れ替えた式を横に並べて表示してもらいたい。（5,13,17,・・・は赤色で表示、3,7,11,19・・・は黄色で表示）

平方剰余の相互法則によると、
どちらかがピーチ味の素数なら、ＲかＮかが一致して
また
両方がオレンジ味の素数なら、入れ替えた式は不一致が起こる。

ということを確認したい。

このことを色で判断できるプログラムを作っていただきたいのです。



 		 

Re: 平方剰余の相互法則の理解のために

 投稿者：山中和義  投稿日：2012年 3月 9日(金)13時47分49秒
  > No.1811[元記事へ]

GAIさんへのお返事です。

> x^2≡a (mod b) を満たすxが存在するとき、aRb
> また、解が存在しないとき、aNb
> の記号を使用するものとし

　　：

> 平方剰余の相互法則によると、
> どちらかがピーチ味の素数なら、ＲかＮかが一致して
> また
> 両方がオレンジ味の素数なら、入れ替えた式は不一致が起こる。
>
> ということを確認したい。
>
> このことを色で判断できるプログラムを作っていただきたいのです。


色は付いていません。


!平方剰余の相互法則

LET N=25 !100以下の素数の個数
DIM M(N)
CALL PrimeList(N,M) !n個の素数列を返す

FOR i=2 TO N !奇素数の組合せ　※1番目の2を除く
   LET a=M(i)
   FOR j=2 TO i-1
      LET b=M(j)

      LET p=MOD(a,4) !素数の型 4k+1,4k+3
      LET q=MOD(b,4)
      PRINT p;q;
      LET AB$=test$(a,b) !x^2≡a (mod b)が解を持つかどうか
      PRINT " "; STR$(a); AB$; STR$(b);
      LET BA$=test$(b,a)
      PRINT " "; STR$(b); BA$; STR$(a)

      IF (p=1 OR q=1) AND AB$=BA$ THEN !(R,R)、(N,N)
      ELSE
         IF (p=3 AND q=3) AND AB$<>BA$ THEN !(N,R)、(R,N)
         ELSE
            PRINT "議論と食違う"
            STOP
         END IF
      END IF

   NEXT j
NEXT i

END


EXTERNAL FUNCTION test$(a,b) !x^2≡a (mod b)を満たす非負整数xがあるかどうか確認する
LET t=MOD(a,b) !平方剰余
FOR x=0 TO b-1
   IF MOD(x*x,b)=t THEN EXIT FOR
NEXT x
LET test$="R"
IF x>b-1 THEN LET test$="N" !存在しないなら
END FUNCTION


!試行割算法

EXTERNAL FUNCTION PrimeQ(n) !素数判定　1:素数、0:素数でない
LET PrimeQ=0
IF n<2 OR n<>INT(n) THEN EXIT FUNCTION !引数を確認する
!２以上の自然数なら
IF MOD(n,2)=0 THEN !２の倍数
   IF n=2 THEN LET PrimeQ=1 !２は素数
ELSEIF MOD(n,3)=0 THEN !３の倍数
   IF n=3 THEN LET PrimeQ=1 !３は素数
ELSE
   LET k=5
   DO WHILE k*k<=n !√nまで検証する
      IF MOD(n,k)=0 THEN !5,11,17,23,29,…
         EXIT FUNCTION
      ELSEIF MOD(n,k+2)=0 THEN !7,13,19,25,31,…
         EXIT FUNCTION
      END IF !+1,+3,+5は２の倍数（偶数）、+1,+4は３の倍数、+5は５の倍数
      LET k=k+6
   LOOP
   LET PrimeQ=1 !最後まで割り切れなければ、素数である
END IF
END FUNCTION


EXTERNAL SUB PrimeList(n,p()) !ｎ個の素数列を返す
IF n<1 THEN EXIT SUB !引数を確認する

LET c=1 !見つけた個数
LET p(c)=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は２の倍数（偶数）、+1,+4は３の倍数、+5は５の倍数

   LET k=k+6 !次へ
LOOP
END SUB

 		 

不思議数

 投稿者：永野護  投稿日：2012年 3月13日(火)10時37分4秒
  不思議数（ふしぎすう、英: weird number）は、自然数のうち過剰数でありながら擬似完全数でない数のことである。言い換えるとその数自身を除く約数の総和が元の数より大きくなる数で、どのように約数を（重複させずに）組み合わせてその和をとっても元の数にならないような数である。例えば70の自身を除く約数の総和は 1+2+5+7+10+14+35=74>70 であり元の数より大きくなるが、どのようにこれらの約数を組み合わせて和を計算しても70にはならないので70は不思議数である。不思議数は無数に存在し、そのうち最小のものは70である。

不思議数を70から小さい順に列記すると

70, 836, 4030, 5830, 7192, 7912, 9272, 10430, 10570, 10792, 10990, 11410, 11690, 12110, 12530, 12670, 13370, 13510, …
奇数の不思議数は発見されていないが、もし存在するなら 10＾18 より大きい数であることが知られている。以上WIKIPEDIAより。
-----------------------------------------------------------------------------------
この不思議数を10万以下で求めるにはどのようなプログラムを組めばよろしいでしょうか。
ご教授いただければ幸いです。よろしくお願いします。

 		 

Re: 不思議数

 投稿者：山中和義  投稿日：2012年 3月13日(火)17時16分32秒
  > No.1813[元記事へ]

永野護さんへのお返事です。

> 不思議数を70から小さい順に列記すると
>
> 70, 836, 4030, 5830, 7192, 7912, 9272, 10430, 10570, 10792, 10990, 11410, 11690, 12110, 12530, 12670, 13370, 13510, …

10万は、マシンパワーがかなり必要です。


!不思議数

!参考サイト　http://oeis.org/A006037

LET t0=TIME


LET N=20000 !検索範囲 [1,N]
FOR i=0 TO N
   IF WeirdNumberQ(i)=1 THEN PRINT i;"は、不思議数です。"
NEXT i


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

END


EXTERNAL FUNCTION WeirdNumberQ(N) !不思議数かどうか確認する　1:不思議数、0:そうでない
LET WeirdNumberQ=0

IF N<0 OR N<>INT(N) THEN EXIT FUNCTION !引数を確認する
!０以上の整数なら

IF MOD(N,6)<>0 THEN !∵完全数6とその倍数は、n=n/2+n/3+n/6より、擬似完全数となる

   LET M=INT(N/2)+1 !高々
   DIM D(M)
   CALL Divisors(N,C,D) !約数を得る

   LET S=0 !その数自身を除くすべての約数の和
   FOR k=1 TO C-1
      LET S=S+D(k)
   NEXT k
   IF S>N THEN !過剰数なら
   !!!PRINT N;C !debug

      FOR L=0 TO 2^(C-1)-1 !組合せと2進法（ビットパターン）を対応させる
         LET t=L

         LET S=0 !その数自身を除くいくつかの約数の和
         LET k=C-1 !大きい約数から順に
         DO WHILE t>0
            IF MOD(t,2)=1 THEN
               LET S=S+D(k)
               IF S>N THEN EXIT DO !これ以降は可能性なし
            END IF
            LET t=INT(t/2)
            LET k=k-1
         LOOP
         IF S=N THEN EXIT FOR !一致する
      NEXT L
      IF L>2^(C-1)-1 THEN LET WeirdNumberQ=1 !すべての組合せで一致しないなら

   END IF

END IF
END FUNCTION


EXTERNAL SUB Divisors(N, C,D()) !正の約数を列挙する　※N≧1
LET C=0 !個数
IF N<1 OR N<>INT(N) THEN EXIT SUB !引数を確認する
!１以上の整数なら
LET C=1
LET D(1)=1 !１

LET i=2
DO WHILE i*i<=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 !平方数の場合

FOR i=1 TO M
   LET D(C+i)=N/D(M-i+1) !商
NEXT i

LET C=C+M !個数
END SUB

 		 

不思議数

 投稿者：永野護  投稿日：2012年 3月14日(水)11時23分1秒
  山中様、お忙しい中ありがとうございました。丁寧なプログラムを作っていただきましたことに深く感謝いたします。季節の変わり目です。お体を大切になさってください。
敬具 		 

再び・・・

 投稿者：信一郎  投稿日：2012年 3月16日(金)06時32分37秒
  はじめまして。
以前、(仮称)十進BASIC を使わせていただいておりましたが、その後 JAVA に移行。今回、簡単なグラフィックを行ないたいと思い、再びインストールさせていただきました。Windows7 対応とあったので、安心しています。
下記に、マンデルブロ集合の立体画像を描画する自作プログラムがあるので、興味があればどうぞ。

信一郎の(小さな)サイト http://www.geocities.jp/space20012010_3141592/index.html

十進BASIC、色々遊ばせていただきます。 		 

Re: 不思議数

 投稿者：山中和義  投稿日：2012年 3月16日(金)19時26分46秒
  > No.1814[元記事へ]

10万個の数値の配列は確保可能なので、篩い法で求めてみました。
原始擬似完全数の倍数で篩います。かなり速く処理できます。


!不思議数 - 自然数のうち過剰数でありながら擬似完全数でない数
!擬似完全数 - 自然数のうち自身を除くいくつかの約数の和が元の数に等しい数
!原始擬似完全数 - 擬似完全数の内、その約数に他の擬似完全数を含まない数

!参考サイト　http://oeis.org/A006037　Weird numbers
!参考サイト　http://oeis.org/A006036　Primitive pseudoperfect numbers


LET t0=TIME


LET N=100000 !1～Nの範囲


!Step.1　不足数、完全数、過剰数に分ける。

DIM F(N) !篩い

FOR k=1 TO N !自明な約数は1
   LET F(k)=1
NEXT k
FOR t=2 TO N !約数（2以上）の候補
   FOR k=t TO N STEP t !倍数に対して
      LET F(k)=F(k)+t !約数の和
   NEXT k
NEXT t
!!!MAT PRINT F; !debug


!Step.2　過剰数が候補である。

FOR J=1 TO N
   IF F(J)>2*J THEN !未確認の過剰数（元の数自身を除く約数の和が元の数より大きい）なら

      DIM D(500)
      CALL Divisors(J,C,D) !約数を得る

      !!LET S=0 !その数自身を除くすべての約数の和
      !!FOR k=1 TO C-1
      !!   LET S=S+D(k)
      !!NEXT k
      LET S=F(J)-J !その数自身を除くすべての約数の和


      LET V=S-J !過剰な値

      FOR i=2 TO C-1 !約数でこれ以下のものを選んで組み合わせる
         IF D(i)>V THEN EXIT FOR
      NEXT i
      !!!PRINT N; V; i-1; C !debug

      FOR L=0 TO 2^(i-1)-1 !組合せと2進法（ビットパターン）を対応させる
         LET t=L

         LET S=0 !その数自身を除くいくつかの約数の和
         LET k=i-1 !大きい約数から順に
         DO WHILE t>0
            IF MOD(t,2)=1 THEN
               LET S=S+D(k)
               IF S>V THEN EXIT DO !これ以降は可能性なし
            END IF
            LET t=INT(t/2)
            LET k=k-1
         LOOP
         IF S=V THEN EXIT FOR !一致する
      NEXT L
      IF L>2^(i-1)-1 THEN !すべての組合せで一致しないなら
         PRINT J;"は、不思議数です。"

      ELSE
         PRINT J;"は、原始擬似完全数です。"

         FOR k=2*J TO N STEP J !その倍数は、擬似完全数となる
            LET F(k)=-ABS(F(k)) !「確認済み」とする
         NEXT k

      END IF


   ELSEIF F(J)=2*J THEN !完全数（元の数自身を除く約数の和が元の数と等しい）なら
      PRINT J;"は、完全数です。"

      FOR k=2*J TO N STEP J !その倍数は、擬似完全数となる
         LET F(k)=-ABS(F(k)) !「確認済み」とする
      NEXT k


   END IF
NEXT J


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

END


EXTERNAL SUB Divisors(N, C,D()) !正の約数を列挙する　※N≧1
LET C=0 !個数
IF N<1 OR N<>INT(N) THEN EXIT SUB !引数を確認する
!１以上の整数なら
LET C=1
LET D(1)=1 !１

LET i=2
DO WHILE i*i<=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 !平方数の場合

FOR i=1 TO M
   LET D(C+i)=N/D(M-i+1) !商
NEXT i

LET C=C+M !個数
END SUB

 		 

不思議数

 投稿者：永野護  投稿日：2012年 3月17日(土)13時31分44秒
  山中様のたびたびの回答に感謝します。ＥＸＣＥＬのソルバー機能を使うことも
考えたのですが。私がぜひ欲しかったのは部分和をどのように計算するかということでした。貴重なアドバイスありがとうございました。
敬具 		 

部分和問題

 投稿者：山中和義  投稿日：2012年 3月18日(日)09時58分10秒
  部分和問題
　与えられたn個の整数a1,a2,…,anから部分集合をうまく選んで、
　その集合内の数の和が与えられた数N（0≦N≦Σak）に等しくなるようにできるかどうかを判定する。


組合せと2進法のビットパターンを対応させる場合、O(2^n)となりますが、
1～Nまでの配列が確保できれば、O(n*N)で算出できます。



!部分和問題（Subset Sum Problem）を動的計画法（Dynamic Programming）で解く

LET C=8 !個数
DATA 1,2,3,4,6,8,12,24 !集合　※正の整数

DIM D(C)
MAT READ D


LET S=0 !総和 Σak
FOR i=1 TO C
   LET S=S+D(i)
NEXT i


DIM W(0 TO S) !整数1～Sを部分集合の和で表す
LET W(0)=0
FOR i=1 TO S
   LET W(i)=-1
NEXT i

LET k=1 !集合から１つ要素を取り出す
DO WHILE k<=C
   LET M=D(k)

   FOR i=S TO 0 STEP -1 !最後からみていき、-1以外のインデックスをiとする
      IF W(i)<>-1 THEN
         LET t=i+M
         IF t<=S AND W(t)=-1 THEN LET W(t)=M
      END IF
      IF W(S)<>-1 THEN EXIT DO !部分和が見つかれば、終了する
   NEXT i

   LET k=k+1
LOOP
!!!MAT PRINT W; !debug


FOR i=1 TO S
   IF W(i)<>-1 THEN
      PRINT i;"= {";

      LET T=i !部分和を表示する
      DO WHILE T>0
         PRINT STR$(W(T));
         LET T=T-W(T)
         IF T>0 THEN PRINT ",";
      LOOP
      PRINT "}"
   END IF
NEXT i

END


実行結果

1 = {1}
2 = {2}
3 = {2,1}
4 = {3,1}
5 = {3,2}
6 = {3,2,1}
7 = {4,2,1}
8 = {4,3,1}
9 = {4,3,2}
10 = {4,3,2,1}
11 = {6,3,2}
12 = {6,3,2,1}
13 = {6,4,2,1}
14 = {6,4,3,1}
15 = {6,4,3,2}
16 = {6,4,3,2,1}
17 = {8,4,3,2}
18 = {8,4,3,2,1}
19 = {8,6,3,2}
20 = {8,6,3,2,1}
21 = {8,6,4,2,1}
22 = {8,6,4,3,1}
23 = {8,6,4,3,2}
24 = {8,6,4,3,2,1}
25 = {12,6,4,2,1}
26 = {12,6,4,3,1}
27 = {12,6,4,3,2}
28 = {12,6,4,3,2,1}
29 = {12,8,4,3,2}
30 = {12,8,4,3,2,1}
31 = {12,8,6,3,2}
32 = {12,8,6,3,2,1}
33 = {12,8,6,4,2,1}
34 = {12,8,6,4,3,1}
35 = {12,8,6,4,3,2}
36 = {12,8,6,4,3,2,1}
60 = {24,12,8,6,4,3,2,1}

 		 

オプションの保存はできますか？

 投稿者：信一郎  投稿日：2012年 3月20日(火)11時38分31秒
  オプションの文法で "Microsoft BASIC互換" にてプログラミングし、保存しました。
保存したファイルのアイコンをダブルクリックし立ち上げると、"標準(JIS Full BASIC)
" に戻ってしまいます。
文法を "Microsoft BASIC互換" に固定する方法があればお教え下さい。 		 

Re: オプションの保存はできますか？

 投稿者：山中和義  投稿日：2012年 3月20日(火)12時17分38秒
  > No.1820[元記事へ]

信一郎さんへのお返事です。

> オプションの文法で "Microsoft BASIC互換" にてプログラミングし、保存しました。
> 保存したファイルのアイコンをダブルクリックし立ち上げると、"標準(JIS Full BASIC)
> " に戻ってしまいます。
> 文法を "Microsoft BASIC互換" に固定する方法があればお教え下さい。

固定する方法はありません。

質問
http://6317.teacup.com/basic/bbs/1564
回答
http://6317.teacup.com/basic/bbs/1565
 		 

Re: オプションの保存はできますか？

 投稿者：信一郎  投稿日：2012年 3月20日(火)13時07分55秒
  ありがとうございました。

> > 文法を "Microsoft BASIC互換" に固定する方法があればお教え下さい。

> 固定する方法はありません。

> 質問
> http://6317.teacup.com/basic/bbs/1564
> 回答
> http://6317.teacup.com/basic/bbs/1565

スレッド一覧 にて 過去ログ は検索したのですが、うまく引っ掛からないようでした。

追伸: 検索のしかた、今、要領が分かりました。 		 

部分和問題

 投稿者：永野護  投稿日：2012年 3月21日(水)11時06分0秒
  いつもありがとうございます。参考にさせていただきます。  

こんなのは可能ですか？

 投稿者：ＧＡＩ  投稿日：2012年 3月21日(水)14時36分19秒
  サブリミナル映像を実験してみたいんですが、プログラムで可能でしょうか？
人間の目には映らないけれども、例えば「ガンバレ！」という文字を確かに１秒間に何回も表示させておくとかのものとか。
 		 

Re: こんなのは可能ですか？

 投稿者：白石和夫  投稿日：2012年 3月21日(水)15時34分7秒
  > No.1824[元記事へ]

プログラムの問題というよりもPCの描画能力の問題かと思います。
 		 

脳は未来を予想する。

 投稿者：ＧＡＩ  投稿日：2012年 3月21日(水)16時11分9秒
  同一画面の同じ場所に、緑色の円の次に黄色の円、その次に赤色の円を１秒間隔位で見せていくことを繰り返す。
ただし黄色の円の時は横に２つ並べて（２個とも黄色の円）見せる。
緑と赤の円は一個しか表示しない。
黄色の一方の色が橙色に、未来を予想して見えてくるという現象が起こるらしい。
これを確認したいので作っていただけませんか。
 		 

白石センセイへ

 投稿者：名なしさん  投稿日：2012年 3月22日(木)00時03分39秒
  　関連付けの問題、直りました。ありがとうございます。
　ヘルプをもう１度熟読したら解決しました。ありがとうございます。さすが白石センセイだ。
　ヘルプには、「コントロールパネルのフォルダオプションの｢詳細設定｣ボタン」とあるんですが、
この｢詳細設定｣ボタンが時々「元に戻す｣という表示になっていることがあるんですね。これも
WINDOWSの欠陥の１つではないでしょうか。 		 

Re: 脳は未来を予想する。

 投稿者：山中和義  投稿日：2012年 3月22日(木)09時50分24秒
  > No.1826[元記事へ]

ＧＡＩさんへのお返事です。

> 同一画面の同じ場所に、緑色の円の次に黄色の円、その次に赤色の円を１秒間隔位で見せていくことを繰り返す。
> ただし黄色の円の時は横に２つ並べて（２個とも黄色の円）見せる。
> 緑と赤の円は一個しか表示しない。
> 黄色の一方の色が橙色に、未来を予想して見えてくるという現象が起こるらしい。


SET WINDOW -2,2,-2,2

LET i=0 !カウンタ
DO
   SELECT CASE i
   CASE 0
      SET AREA COLOR "GREEN"
   CASE 1
      SET AREA COLOR "YELLOW"
   CASE 2
      SET AREA COLOR "RED"
   END SELECT

   SET DRAW mode hidden !ちらつき防止開始
   CLEAR
   DRAW disk WITH SCALE(0.8)*SHIFT(-1,0)
   IF i=1 THEN DRAW disk WITH SCALE(0.8)*SHIFT(1,0)
   SET DRAW mode explicit !ちらつき防止終了

   WAIT DELAY 1 !1秒待ち

   LET i=MOD(i+1,3)
LOOP

END
 		 

パズル　おもりの個数

 投稿者：山中和義  投稿日：2012年 3月22日(木)13時22分58秒
  > No.1819[元記事へ]

> 部分和問題
> 　与えられたn個の整数a1,a2,…,anから部分集合をうまく選んで、
> 　その集合内の数の和が与えられた数N（0≦N≦Σak）に等しくなるようにできるかどうかを判定する。

パズルの解法に用いてみました。


!問題
!今、1gと10gと25gの3種類のおもりがある。
!この3種類のおもりを用いて（何個使ってもよい）、
!指定された重さを、おもりの個数が最少になるように計る。
!そのとき、3種類のおもりのそれぞれの個数を求めよ。

!参考サイト
!「数学の部屋」（http://math.a.la9.jp/index.htm）内
!　　パズル問題 シリーズ
!　　　おもりの個数は？　http://math.a.la9.jp/omori.htm


DATA 3 !種類
DATA 1,10,25 !おもり
LET M=58 !計りたい重さ


READ N !種類

DIM A(N) !おもり
MAT READ A


!それぞれの重さの1,2,2^2,2^3,…個のおもさを考える。
!すなわち、
!　1, 1*2, 1*2^2, 1*2^3,…
!　10, 10*2, 10*2^2, 10*2^3,…
!　25, 25*2, 25*2^2, 25*2^3,…
!を全体集合と考えて、その部分和に帰着させる。

DIM F(0 TO M) !0からMまで
FOR i=1 TO M
   LET F(i)=-1
NEXT i

LET x=0 !おもりを2^xずつ増やしていく
DO
   FOR k=1 TO N
      LET w=A(k)*2^x

      FOR i=M TO 0 STEP -1 !最後からみていく
         IF F(i)<>-1 THEN
            LET t=i+w
            IF t<=M AND F(t)=-1 THEN !最初に見つかったものが、最少個数となる
               LET F(t)=w
               IF t=M THEN EXIT DO !部分和が見つかれば、終了する
            END IF
         END IF
      NEXT i

   NEXT k
   LET x=x+1 !次へ
LOOP
MAT PRINT F; !debug



DIM C(N) !求めるおもりの個数
MAT C=ZER

PRINT M;"= {"; !部分和を表示する
LET T=M
DO WHILE T>0 !リンクを辿っていく
   PRINT STR$(F(T));

   FOR i=N TO 1 STEP -1 !重いおもりから
      IF MOD(F(T),A(i))=0 THEN !そのおもりで計ることができるなら、
         LET C(i)=C(i)+INT(F(T)/A(i)) !これが最少なので、個数を求める
         EXIT FOR
      END IF
   NEXT i

   LET T=T-F(T) !次へ
   IF T>0 THEN PRINT ",";
LOOP
PRINT "}"

MAT PRINT C; !解を表示する


END

 		 

幽霊が見てみたい。

 投稿者：ＧＡＩ  投稿日：2012年 3月23日(金)07時35分28秒
  時計の文字盤（円形）の数字の部分にピンク色の●を配置しておき、時計回りに１，２，３，・・・の部分の●を消しては（0.1秒位の間隔)、点けて文字盤の時刻の部分がクルクルと回っている状態を作っておく。
中心部分（＋の印）をじっと見つめておくと、何も点いてないクルクル回っている部分に緑の●か見え始め、更に見つめ続けているとピンクの●がすべて消えて無くなっていき、緑の●だけが（１個だけ）クルクルと回っているように見えてくる。

ありもしない幽霊（緑の●）が、頭の中に見える現象が再現できるという。
 		 

4次方程式を解くプログラム

 投稿者：エス・テー  投稿日：2012年 3月23日(金)11時18分43秒
  Ferrariの公式で4次方程式を解くプログラムを作ろうとしているのですが、ゼロ除算等があって、どうしてもうまくいきません。代数的な方法（解の公式等）で4次方程式を解くプログラムをお教え下さい。お願いします。  

Re: 4次方程式を解くプログラム

 投稿者：山中和義  投稿日：2012年 3月23日(金)22時30分2秒
  > No.1831[元記事へ]

エス・テーさんへのお返事です。

> Ferrariの公式で4次方程式を解くプログラム


!フェラーリ（Ferrari）の方法

OPTION ARITHMETIC COMPLEX !複素数を扱う

!a4*x^4+a3*x^3+a2*x^2+a1*x+a0=0、a4≠0の解

LET a4=1 !1±√-1,-1±√-3
LET a3=0
LET a2=2
LET a1=-4
LET a0=8


PRINT a4;a3;a2;a1;a0 !debug

!x=y-a3/(4*a4)を代入して、3次の項を消去すると、
!y^4+py^2+qy+r=0
!ただし、
!　p=-3*a3^2/(8*a4^2)+a2/a4
!　q=a3^3/(8*a4^3)-a2*a3/(2*a4^2)+a1/a4
!　r=-3*a3^4/(256*a4^4)+a2*a3^2/(16*a4^3)-a1*a3/(4*a4^2)+a0/a4

LET p=-3*a3^2/(8*a4^2)+a2/a4
LET q=a3^3/(8*a4^3)-a2*a3/(2*a4^2)+a1/a4
LET r=-3*a3^4/(256*a4^4)+a2*a3^2/(16*a4^3)-a1*a3/(4*a4^2)+a0/a4

!!!PRINT p;q;r !debug


!q=0のとき、
!　複2次式 (y^2 - (-p-√{p^2-4r})/2)(y^2 - (-p+√{p^2-4r})/2)=0 と因数分解される。
!q≠0のとき、
!　y^4=-p*y^2-q*y-rとして、両辺にy^2*z+z^2/4を加えて、変形すると、
!　(y^2+z/2)^2=(z-p){y-q/(2*(z-p))}^2 + {1/(4*(z-p))}(z^3-p*z^2-4*r*z+4*p*r-q^2)
!　ここで、z^3-p*z^2-4*r*z+4*p*r-q^2=0となるzを1つ求めると、
!　同様に、複2次式
!　　(y^2+z/2 - √(z-p){y-q/(2*(z-p))})(y^2+z/2 + √(z-p){y-q/(2*(z-p))})=0
!　と因数分解できる。

IF q=0 THEN
   LET t=p^2-4*r !判別式
   CALL Solve2Equ(0,-(-p-SQR(t))/2 ,y1,y2)
   CALL Solve2Equ(0,-(-p+SQR(t))/2 ,y3,y4)

ELSE
   CALL Solve3Equ(-p,-4*r,4*p*r-q^2, z1,z2,z3)
   LET t=SQR(z1-p)

   CALL Solve2Equ(-t, q/(2*t)+z1/2, y1,y2)
   CALL Solve2Equ( t,-q/(2*t)+z1/2, y3,y4)

END IF

LET x1=y1-a3/(4*a4) !x=y-a3/(4*a4)
LET x2=y2-a3/(4*a4)
LET x3=y3-a3/(4*a4)
LET x4=y4-a3/(4*a4)


!解を表示する

PRINT x1
PRINT x2
PRINT x3
PRINT x4

END


EXTERNAL SUB Solve2Equ(P,Q, x1,x2) !代数方程式 x^2+P*x+Q=0 の解
OPTION ARITHMETIC COMPLEX !複素数を扱う

LET D=P^2-4*Q !判別式
LET x1=(-P+SQR(D))/2 !解の公式より
LET x2=(-P-SQR(D))/2
END SUB


EXTERNAL SUB Solve3Equ(P,Q,R, x1,x2,x3)!代数方程式 x^3+P*x^2+Q*x+R=0 の解
OPTION ARITHMETIC COMPLEX !複素数を扱う

LET a=-P^2/3+Q !カルダノ（Cardano）の方法より
LET b=2*P^3/27-P*Q/3+R

LET t=b^2/4+a^3/27 !(b/2)^2+(a/3)^3
LET z1=-b/2+SQR(t)
LET z2=-b/2-SQR(t)
IF t>=0 THEN
   !!!PRINT "1実根と2虚根" !debug
   LET u=SGN(z1)*ABS(z1)^(1/3) !u=(-b/2+SQR(t))^(1/3)∈R
   LET v=SGN(z2)*ABS(z2)^(1/3) !v=(-b/2+SQR(t))^(1/3)∈R

ELSE !不還元の場合
   !!!PRINT "3実根" !debug
   LET u=EXP(LOG(z1)/3) !u=(-b/2+SQR(t))^(1/3)∈C
   LET v=EXP(LOG(z2)/3) !v=(-b/2-SQR(t))^(1/3)∈C

END IF
!!!PRINT u*v; -a/3 !debug

LET w=COMPLEX(-1/2,SQR(3)/2) !ω=(-1+(√3)i)/2は1の原始3乗根の1つ

LET y1=u+v !y^3+a*y+b=0
LET y2=w*u+w^2*v
LET y3=w^2*u+w*v

LET x1=y1-P/3
LET x2=y2-P/3
LET x3=y3-P/3
END SUB

 		 

Re: 幽霊が見てみたい。

 投稿者：山中和義  投稿日：2012年 3月24日(土)09時28分28秒
  > No.1830[元記事へ]

ＧＡＩさんへのお返事です。


SET WINDOW -2,2,-2,2

SET AREA COLOR "MAGENTA"
FOR k=0 TO 12
   CALL moji(k)
NEXT k

PLOT LINES: -0.2,0; 0.2,0 !十字線
PLOT LINES: 0,-0.2; 0,0.2

LET k=3 !「中断」ボタンで停止する
DO
   SET DRAW mode hidden !ちらつき防止開始
   SET AREA COLOR "WHITE" !該当する位置
   CALL moji(k)
   SET AREA COLOR "MAGENTA" !1つ前
   CALL moji(k+1)
   SET DRAW mode explicit !ちらつき防止終了

   WAIT DELAY 0.1 !0.1秒待ち

   LET k=MOD(k-1,12)
LOOP

SUB moji(k)
   LET x=1.5*COS(2*PI*k/12)
   LET y=1.5*SIN(2*PI*k/12)
   DRAW disk WITH SCALE(0.2)*SHIFT(x,y)
END SUB

END

 		 

BASICAcc でエラー表示 "-St+"

 投稿者：信一郎  投稿日：2012年 3月26日(月)07時39分43秒
  「 Decimal BASIC Open Source Project 公開討議フォーラム 」にて検索したのですが有りませんでしたので、こちらで質問させて下さい。

BASICAcc(version 0.9.4.6) フォルダ内のサンプルプログラムを実行した処、エラーとなりました。
output フォルダには、NoName.lpr と NoName.err があります。

NoName.err の内容

    Warning: You are using the obsolete switch -St
    Error: Illegal parameter: -St+

サンプルプログラム三つとも、同じエラーです。
対処法を教えていただければ幸いです。

Windows7 64ビット版 を使っています。
"Windowsが64ビットの場合でも，32ビット版Lazarusを選択してください。" とあったので、
lazarus-0.9.30.4-fpc-2.6.0-win32 をインストールしました。

path は以下の通りです。
fpc.exe path
C:\Lazarus\fpc\2.6.0\bin\i386-win32
Lazarus path
C:\Lazarus 		 

Re: BASICAcc でエラー表示 "-St+"

 投稿者：山中和義  投稿日：2012年 3月26日(月)10時57分19秒
  > No.1834[元記事へ]

信一郎さんへのお返事です。

> BASICAcc(version 0.9.4.6) フォルダ内のサンプルプログラムを実行した処、エラーとなりました。
> output フォルダには、NoName.lpr と NoName.err があります。
>
> NoName.err の内容
>
>     Warning: You are using the obsolete switch -St
>     Error: Illegal parameter: -St+
>
> サンプルプログラム三つとも、同じエラーです。
> 対処法を教えていただければ幸いです。


新しいfpc(PASCALコンパイラ)では、うまくコンパイルできないようですね。
こちらでもWindowsMEで確認しました。

以前議論があったかと思いますが、新しいfpcとの整合性の問題があるようです。
新しいBASICAccがリリースされるのを待ちましょう。

お急ぎの場合は、BASCIAccの説明の箇所に、
　Note.
　Lazarus-0.9.30.2-fpc-2.4.4-win32.exeを使うこともできます。
　その場合，Setup - Path で fpc path を
　C:\Lazarus\fpc\2.4.4\bin\i386-win32
　に書き換える必要があります。
とあるように、
この版のBASICAccでは、旧版のfpcを選択してください。

 		 

Re 4次方程式を解くプログラム

 投稿者：エス・テー  投稿日：2012年 3月26日(月)11時38分30秒
  山中先生、4次方程式を解くプログラム有難うございました。今回は複素数計算の威力を知りました。なお、計算結果が複素数の場合、例えば虚数部が10^-8以下なら、虚数部＝0にして、実数部のみにすることはできないのでしょうか。ご教示よろしくお願いします。
 		 

Re: Re 4次方程式を解くプログラム

 投稿者：山中和義  投稿日：2012年 3月26日(月)12時45分10秒
  > No.1836[元記事へ]

エス・テーさんへのお返事です。

> 計算結果が複素数の場合、例えば虚数部が10^-8以下なら、虚数部＝0にして、実数部のみにすることはできないのでしょうか。

複素数xの実部と虚部は、RE(x),IM(x)関数で取得できるので、次のようにすれば良いかと思います。

　：
　：

LET x1=y1-a3/(4*a4) !x=y-a3/(4*a4)
LET x2=y2-a3/(4*a4)
LET x3=y3-a3/(4*a4)
LET x4=y4-a3/(4*a4)


IF ABS(Im(x1))<1E-8 THEN LET x1=Re(x1)
IF ABS(Im(x2))<1E-8 THEN LET x2=Re(x2)
IF ABS(Im(x3))<1E-8 THEN LET x3=Re(x3)
IF ABS(Im(x4))<1E-8 THEN LET x4=Re(x4)


!解を表示する

PRINT x1
PRINT x2
PRINT x3
PRINT x4

END

　：
　：
 		 

Re: BASICAcc でエラー表示 "-St+"

 投稿者：信一郎  投稿日：2012年 3月26日(月)12時54分41秒
  ありがとうございました。

> この版のBASICAccでは、旧版のfpcを選択してください。

速～ :) 		 

Re: BASICAcc でエラー表示 "-St+"

 投稿者：白石和夫  投稿日：2012年 3月26日(月)14時53分4秒
  > No.1834[元記事へ]

情報ありがとうございます。

確認を進めていくと次の情報に行き当たりました。
User Changes 2.6.0
-Stスイッチがなくなったとあってあせりましたが，-St+を指定しなくてもstaticは有効と読めたので一安心。
時間の余裕ができたら，FPC 2.6.0 への対応を進めます。



 		 

Re Re ４次方程式を解くプログラム

 投稿者：エス・テー  投稿日：2012年 3月26日(月)15時27分2秒
  山中先生、再度有難うございました。十進ベーシックは非常に使い易いので、今後いろいろな技術計算に使用したいと思っています。よろしくお願い致します。  

もやもやを解決して下さい。

 投稿者：ＧＡＩ  投稿日：2012年 3月29日(木)20時42分2秒
  開区間（０，１）
において、これを２等分するＰ２１＝（０，１／２）、Ｐ２２＝（１／２，１）
にそれぞれ含まれるように例えば、ｘ１∈Ｐ２１、ｘ２∈Ｐ２２
を任意に選ぶ。
次に（０，１）を３等分する区間の
Ｐ３１＝（０，１／３）、Ｐ３２＝（１／３，２／３）、Ｐ３３＝（２／３，１）
各部分にｘ１，ｘ２，ｘ３が含まれるようにｘ３を任意に選ぶ。
（選んだｘ１，ｘ２，ｘ３はそのまま値を変化させずにしておく。）
同様に、次に４等分する
Ｐ４１＝（０，１／４）、Ｐ４２＝（１／４，２／４），
Ｐ４３＝（２／４，３／４）、Ｐ４４＝（３／４，１）
各区間に一つずつｘ１，ｘ２，ｘ３，ｘ４が含まれるようにｘ４を任意に選ぶ。

この作業をいつまで続けられるかが疑問点なのです。




実際のやり方は例えば５等分までだと、
（０，１）区間で考えていると区間の境目が分数となるので、本質的に変わらない
（０，５！）＝（０，１２０）の区間に拡張し
２等分（０，６０）、（６０，１２０）
３等分（０，４０）、（４０，８０）、（８０，１２０）
４等分（０，３０）、（３０，６０）、（６０，９０）、（９０，１２０）
５等分（０，２４）、（２４，４８）、（４８，７２）、（７２，９６）、（９６，１２０）
と境目の座標を整数となるようにして考えると
たとえば
ｘ１＝１５、ｘ２＝１００、ｘ３＝４５、ｘ４＝６５、ｘ５＝７５
の点はこれを満たす一つの取り方になる。


現在１５等分の分割まで実際にｘ１，ｘ２，・・・、ｘ１５を配置することに成功しました。



そこで、この先の１６、１７等分の分割までの選び方を何方か挑戦してもらいたいんですが・・・
｛（０，１６！）（０，１７！）区間で考えています。｝
いつもあと少しのおしい所で完成せずにいます。


そしてこれが永遠に可能かというと、そうでは無いらしく１８等分以上の分割では点をどう自由に選んだとしても不可能であるらしいのです。


限界ぎりぎりの１７分割までは成功させたいと努力中なのですが未だ成功していません。このもやもやを解決して下さい。


 		 

Re: もやもやを解決して下さい。

 投稿者：山中和義  投稿日：2012年 3月31日(土)10時13分37秒
  > No.1841[元記事へ]

ＧＡＩさんへのお返事です。

> （０，５！）＝（０，１２０）の区間に拡張し

6等分の場合

開区間(0,60)
　 1 : {1,2,3,4,5,6,7,8,9}
　 2 : {11}
　 3 : {13,14}
　 4 : {16,17,18,19}
　 5 : {21,22,23}
　 6 : {25,26,27,28,29}
　 7 : {31,32,33,34,35}
　 8 : {37,38,39}
　 9 : {41,42,43,44}
　10 : {46,47}
　11 : {49}
　12 : {51,52,53,54,55,56,57,58,59}
とする。
各等分における区間は、
　 1 : 0  0  0  0  0
　 2 : 0  0  0  0  1
　 3 : 0  0  0  1  1
　 4 : 0  0  1  1  1
　 5 : 0  1  1  1  2
　 6 : 0  1  1  2  2
　 7 : 1  1  2  2  3
　 8 : 1  1  2  3  3
　 9 : 1  2  2  3  4
　10 : 1  2  3  3  4
　11 : 1  2  3  4  4
　12 : 1  2  3  4  5
となる。
よって、最初の値をその区間の代表として、その１つは、
　x1, x2, x3, x4, x5, x6
　 1, 51, 21, 31, 41, 11
とすればよい。



16等分の場合
　80個の区間に分割されるので、並びはPERM(80,16)の検証となる。

解
開区間(0, 720720)
1, 675676, 262081, 411841, 524161, 131041, 327601, 589681, 205921, 463321, 65521, 630631, 360361, 154441, 540541, 270271

　         2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 分割
　     1 : 0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
　675676 : 1* 2  3  4  5  6  7  8  9 10 11 12 13 14 15
　262081 : 0  1* 1  1  2  2  2  3  3  4  4  4  5  5  5
　411841 : 1  1  2* 2  3  4  4  5  5  6  6  7  8  8  9
　524161 : 1  2  2  3* 4  5  5  6  7  8  8  9 10 10 11
　131041 : 0  0  0  0  1* 1  1  1  1  2  2  2  2  2  2
　327601 : 0  1  1  2  2  3* 3  4  4  5  5  5  6  6  7
　589681 : 1  2  3  4  4  5  6* 7  8  9  9 10 11 12 13
　205921 : 0  0  1  1  1  2  2  2* 2  3  3  3  4  4  4
　463321 : 1  1  2  3  3  4  5  5  6* 7  7  8  9  9 10
　 65521 : 0  0  0  0  0  0  0  0  0  1* 1  1  1  1  1
　630631 : 1  2  3  4  5  6  7  7  8  9 10*11 12 13 14
　360361 : 1  1  2  2  3  3  4  4  5  5  6  6* 7  7  8
　154441 : 0  0  0  1  1  1  1  1  2  2  2  2  3* 3  3
　540541 : 1  2  3  3  4  5  6  6  7  8  9  9 10 11*12
　270271 : 0  1  1  1  2  2  3  3  3  4  4  4  5  5  6*

と、1時間程度で、1つ目の解が見つかりました。

17等分は、3時間検索中で、まだ見つかっていません。
 		 

Re: もやもやを解決して下さい。

 投稿者：山中和義  投稿日：2012年 3月31日(土)15時40分2秒
  > No.1842[元記事へ]

ＧＡＩさんへのお返事です。

16等分は、1分程度。 17等分は、15分程度で1つ目の解が見つかります。
プログラムは、1つ目で停止するようになっています。
いくつか求める場合は、STOP文をコメントアウトしてください。

18等分は、1つ目と2つ目を固定したときに解は見つかりません。（1時間程度）


LET N=6 !n等分

!開区間をつくる数値を算出する
LET M=4 !N=1,2の場合
FOR i=3 TO N !最小公倍数ならすべての数で割り切れる
   LET M=LCM(M,i)
NEXT i
PRINT "開区間(0,";STR$(M);")"


DIM G(200) !開区間　x1,x2,…,xnの候補
LET S=0 !開区間の個数
LET FLG=0
FOR i=1 TO M !数値を区間に割り当てる
   FOR j=2 TO N
      IF MOD(i,M/j)=0 THEN EXIT FOR
   NEXT j
   IF j>N THEN !割り切れないなら、その区間に属する
      IF FLG=0 THEN !search left
         LET S=S+1 !最初の値をその区間の代表とする
         LET G(S)=i
         PRINT S;": {";STR$(i);

         LET FLG=1
      ELSE
      !PRINT ",";STR$(i); !←←←←←←←←←←
      END IF
   ELSE !割り切れるなら、区間の左端または右端である
      IF FLG=1 THEN PRINT "}" !find right

      LET FLG=0
   END IF
NEXT i
PRINT

FOR i=1 TO S !各数値の各等分における開区間
   PRINT i;":";
   FOR j=2 TO N !2,3,4,… 等分
      PRINT INT(G(i)/(M/j));
   NEXT j
   PRINT
NEXT i
PRINT


!実際に選んでみる
DIM P(N) !数値の並び　x1,x2,…,xn
DIM Q(S) !その数値の使用状況　0:未使用、1:使用中
MAT Q=ZER
!!FOR i=1 TO S !1つ目を選ぶ
!!   LET Q(i)=1 !仮に使用する
!!   LET P(1)=G(i)
!!   CALL try(2,P,Q, M,N,G,S) !2つ目以降
!!   LET Q(i)=0 !元に戻す
!!NEXT i
LET Q(1)=1 !1つ目を選ぶ
LET P(1)=G(1)
LET Q(S)=1 !2つ目を選ぶ
LET P(2)=G(S)
CALL try(3,P,Q, M,N,G,S) !3つ目以降

END


EXTERNAL SUB try(X,P(),Q(), M,N,G(),S) !バックトラック法で検証する
DIM H(0 TO X-1) !各区間の頻出度数
MAT H=ZER
FOR j=1 TO X-1 !各区間に分布するかどうか確認する
   LET t=INT(P(j)/(M/X)) !区間を算出する
   IF H(t)<>0 THEN EXIT FOR !1つずつ
   LET H(t)=1
NEXT j
IF j>X-1 THEN !既に選んだ数値x1,x2,…,xn-1で、条件を満たすなら

   FOR i=1 TO S !足らない区間（1つだけ）にxnを追加する
      IF Q(i)=0 THEN
         LET t=INT(G(i)/(M/X)) !区間を算出する
         IF H(t)=0 THEN !条件を満たすなら

            LET Q(i)=1 !仮に使用する
            LET P(X)=G(i)

            IF X=N THEN !すべて揃ったなら
               IF P(1)<P(N) THEN !対称性を考慮する
                  FOR k=1 TO N !結果を表示する
                     PRINT P(k);
                  NEXT k
                  PRINT

                  STOP !※1つのみ　←←←←←←←←←←
               END IF
            ELSE
               CALL try(X+1,P,Q, M,N,G,S) !次へ
            END IF

            LET Q(i)=0 !元に戻す

         END IF
      END IF
   NEXT i

END IF
END SUB


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/GCD(a,b)*b
END FUNCTION

 		 

スッキリです。

 投稿者：ＧＡＩ  投稿日：2012年 3月31日(土)19時59分29秒
  > No.1843[元記事へ]

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

> 16等分は、1分程度。 17等分は、15分程度で1つ目の解が見つかります。
> プログラムは、1つ目で停止するようになっています。
> いくつか求める場合は、STOP文をコメントアウトしてください。
>
> 18等分は、1つ目と2つ目を固定したときに解は見つかりません。（1時間程度）

これで、スッキリしました。
山中さんが投稿する寸前に、１６分割の配置を試行錯誤の上見つけ出しました。
ただ１７分割は１週間程度試行錯誤を繰り返していたんですが、どうしても探し出すことが出来ずにいました。
さっそく掲載して頂いたプログラムを走らせてその配置を調べておりましたら、なんと私が用意していた作業用のシートで区間を８分割したときの５番目の位置Ｐ（８，５）と１６等分したときの１０番目の位置Ｐ（１６，１０）の計算が異なる数値であることが判明した。
さらにＰ（４，３）＝Ｐ（１２，９）＝Ｐ（１６，１２）にもかかわらずＰ（８，６）の座標の位置が異なっている。
１７等分の区間を（０，１７！）と最小公倍数としなくて、大きな数値を表計算ソフトに任せて作業していたら原因はよくは分かりませんが、異なる数値で算出されていたことがその原因とわかりました。
それまでの分割シートも同様な方法で作成していたので、安心して信じ切っていました。

何度やってもできないはずでした。

掲載して頂いたプログラムはいろいろな分割にすべて対応できて、しかも何種類も配置のパターンがわかるのでとっても重宝します。


迅速な対応して頂いて感謝いたします。





 		 

L関数

 投稿者：匿名希望  投稿日：2012年 4月 2日(月)11時07分18秒
  数論に興味を持っています。今フェルマーの最終定理の本（ブルーバックス、フェルマーの最終定理が解けた）を読んでいます。質問なのですが、L関数の値の計算方法がわかりません。PARI　GP　という数学用のソフトを使って楕円曲線をE=
y^2=x^3-xとした場合判別式の値が64
となり、L関数の値がL(E,s)=L(E,1)=0.6555となりました。
このL(E,1)の値の計算方法を教えていただけないでしょうか。

E:y^2=x^3-x,
s=1
の場合だけで結構です。
プログラムでも文章による説明でもかまいません。
まことに恐縮ですがご迷惑でなければよろしくお願いします。 		 

複素数の内積計算

 投稿者：島村１２４３  投稿日：2012年 4月 6日(金)21時18分51秒
  十進BASICには内積を求めるキーコード「DOT」が有ることを知り、複素数の配列変数a(2),b(2)の内積cを次のコードで求めました。
OPTION ARITHMETIC complex
a(1)=complex(1,2)
a(2)=complex(3,4)
b(1)=complex(5,6)
b(2)=complex(7,8)
c=dot(a,b)
print Re(c),Im(c)
END
-18    68

となりました。
そこで複素数ベクトルの内積の計算定義をネット（下記URL)
<http://tau.doshisha.ac.jp/~kon/lectures/2005.linear-algebra-II/html.dir/node17.html>
で調べたら、bは共役複素数を使う、と説明されていたので筆算で
c=a(1)xb(1)*+a(2)xb(2)*
（ただし*は共役複素数の意味）
を求めると、前記「-18  68」になりません。
そこで試しに共役複素数を使わずに
c=a(1)xb(1)+a(2)xb(2)
を筆算で求めると、「-18  68」になりj十進BASICでの計算結果に合致します。

ネットの説明が誤っているのかなと思いましたが、どうなのでしょうか。 		 

Re: 複素数の内積計算

 投稿者：白石和夫  投稿日：2012年 4月 7日(土)08時08分14秒
  > No.1846[元記事へ]

ご指摘ありがとうございました。
内積に思い至らず，実数の場合の計算手順そのままにしていました。
次バージョンで，内積の定義を変更します。
 		 

BASICAcc 0.9.4.7 Windows

 投稿者：白石和夫  投稿日：2012年 4月 7日(土)11時52分1秒
  Windows版BASICAcc 0.9.4.7のダウンロードファイルBASICAcc0947.zipの誤ったバージョンが登録されていました。
BASICAccを起動してHelp-Aboutに表示されるバージョン番号が正しくない場合は，再度，ダウンロードしてください。
 		 

BASICAcc 0.9.4.8 Windows

 投稿者：白石和夫  投稿日：2012年 4月 9日(月)05時28分57秒
  Windows版BASICAcc 0.9.4.8のダウンロードファイルBASICAcc0948.zipに古いままのBASICAcc.exeが登録されていました。
BASICAccを起動してHelp-Aboutに表示されるバージョン番号が正しくない場合は，再度，ダウンロードしてください.
 		 

食塩水の混合

 投稿者：エス・テー  投稿日：2012年 4月20日(金)11時31分31秒
  1000ccの攪拌機付き容器に濃度３％の食塩水が満杯（1000cc）入っています。いま、ここへ濃度７％の食塩水を徐々に注入していき、ちょうど1000cc注入したところで注入を止めます。このとき、食塩水の濃度は何％になっていますか。という問題です。十進ベーシックでプログラムを組んで解を得たいのですが、どのようなプログラムをつくればよいのか、どなたかお教え下さい。  

Re: 食塩水の混合

 投稿者：山中和義  投稿日：2012年 4月20日(金)18時55分59秒
  > No.1851[元記事へ]

エス・テーさんへのお返事です。

> 1000ccの攪拌機付き容器に濃度３％の食塩水が満杯（1000cc）入っています。いま、ここへ濃度７％の食塩水を徐々に注入していき、ちょうど1000cc注入したところで注入を止めます。このとき、食塩水の濃度は何％になっていますか。という問題です。十進ベーシックでプログラムを組んで解を得たいのですが、どのようなプログラムをつくればよいのか、どなたかお教え下さい。


!食塩水の問題

!a[%]の食塩水x[g]とb[%]の食塩水y[g]を混ぜると、(a*x+b*y)/(x+y)[%]の食塩水x+y[g]となる。

!濃度[%]　食塩水の重さ[g]　食塩の重さ[g]
! a        x                a*x/100
! b        y                b*y/100
! c        x+y              c*(x+y)/100=(a*x+b*y)/100

LET a=1 !1%の食塩水200g
LET x=200
LET b=100 !塩20g
LET y=20
LET c=(a*x+b*y)/(x+y)

PRINT c; "%の食塩水"; x+y; "g"

END
 		 

Re: 食塩水の混合

 投稿者：島村1243  投稿日：2012年 4月21日(土)07時28分49秒
  > No.1851[元記事へ]

エス・テーさんへのお返事です。

> 1000ccの攪拌機付き容器に濃度３％の食塩水が満杯（1000cc）入っています。いま、ここへ濃度７％の食塩水を徐々に注入していき、ちょうど1000cc注入したところで注入を止めます。このとき、食塩水の濃度は何％になっていますか。という問題です。十進ベーシックでプログラムを組んで解を得たいのですが、どのようなプログラムをつくればよいのか、どなたかお教え下さい。

この問題は、濃度X[%]食塩水の比重[g/cc]がm(X)というXの関数で与えられるなら、次の様にしてXの時間経過値を得ることができると思います。

（１）7%食塩水注入流量Q[cc/s](一定)と微小時間Δt[s](一定)を設定する。
（２）注入する食塩水は、微小時間Δt[s]で容器1000[cc]内に一様拡散する。

時刻t=0[s] で注入を開始し、開始t[s]後の溶液濃度をX(t)[%]とすると、この時の容器内塩と水それぞれの重量[g]は、X(t)をXと略記して
  塩[g]= X/100*m(X)*1000=10*X*m(X)    　　　　　　 (1)
  水[g]=(100-X)/100*m(X)*1000=(1000-10*X)*m(X)     (2)

時刻がtから微小時間Δt[s]経過する間に、
　容器に流入する７％食塩水の塩と水それぞれの重量は
  　塩[g]= 7/100*m(7)*QΔt     　　　(3)
  　水[g]=(100-7)/100*m(7)*QΔt      (4)
　容器から流出するX％食塩水の塩と水それぞれの重量は
  　塩[g]= X/100*m(X)*QΔt     　　　(5)
  　水[g]=(100-X)/100*m(X)*QΔt      (6)

したがってt+Δt[s]後の容器内濃度X(t+Δt)[%]は
　X(t+Δt)={(1)式+(3)式－(5)式}/{(1)式＋(2)式＋(3)式＋(4)式－(5)式－(6)式}*100
         ={(7*m(7)－X*m(X))*QΔt+1000*X*m(X)}
　　　　　　/{(m(7)－m(X))*QΔt+1000*m(X)}
で表される。

上式を「t=0でX(0)=3」の初期条件を付けて順次各時刻のXを求めて行き、t=1000/Qで計算を停止すれば1000cc注入完了後のXが得られる。

プログラム例は次のようになります。

!SET WINDOW    ,  ,  ,
DEF m(X)=  !ここにmの関数式を記載
Q=1.0 !Q値をセット
dt=0.01 !Δt値をセット
N=1000/Q/dt
t0=0
X0=3
PRINT t0,X0
For k=1 To N
  t1=k*dt
  X1=((7*m(7)-X0*m(X0))*Q*dt+1000*X0*m(X0))/((m(7)-m(X0))*Q*dt+1000*m(X0))
  cc=k*Q*dt !注入量の合計
  PRINT t1,X1,cc
  !PLOT LINES:t0,X0;t1,X1
  t0=t1
  X0=X1
Next k
END 		 

Re: 食塩水の混合

 投稿者：島村1243  投稿日：2012年 4月21日(土)13時57分15秒
  > No.1853[元記事へ]

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

> エス・テーさんへのお返事です。
>
> > 1000ccの攪拌機付き容器に濃度３％の食塩水が満杯（1000cc）入っています。いま、ここへ濃度７％の食塩水を徐々に注入していき、ちょうど1000cc注入したところで注入を止めます。このとき、食塩水の濃度は何％になっていますか。という問題です。十進ベーシックでプログラムを組んで解を得たいのですが、どのようなプログラムをつくればよいのか、どなたかお教え下さい。

濃度X[%]の溶液の比重関数m(X)を m(X)=1+X/100 と近似して下記プログラムを動かすと、濃度Xの時間変化と最終値が見えます。

DEF m(X)=1+X/100  !m(X)の近似式(これで良いのか？ですが。。）
Q=1.0 !Q値をセット
dt=0.05 !Δt値をセット
N=1000/Q/dt
SET WINDOW  -100,N*dt,-1,7
DRAW GRID(100,1)

t0=0
X0=3
PRINT "t=";t0;", X(0)=";X0
For k=1 To N
  t1=k*dt
  X1=((7*m(7)-X0*m(X0))*Q*dt+1000*X0*m(X0))/((m(7)-m(X0))*Q*dt+1000*m(X0))
  cc=k*Q*dt !注入量の合計
  !PRINT t1;X1;cc
  PLOT LINES:t0,X0;t1,X1
  t0=t1
  X0=X1
Next k
PRINT "t=";t1;", X(t)=";X1;", cc=";cc
END 		 

食塩水の混合

 投稿者：エステー  投稿日：2012年 4月21日(土)18時08分17秒
  山中先生、島村1243先生 丁寧な説明とプログラム 本当に有難うございました。濃度X[%]食塩水の比重[g/cc]をm(X)というXの関数で与えて、濃度Xの時間変化と最終値を見るという方法は全く思いつきませんでした。今後共よろしくご指導お願い致します。
ところで。私もプログラムをつくってみました。十進ベーシックを学び始めたばかりで、こういうプログラムでよいのかどうかもわからないのですが、とにかく見て頂きたいと思います。ご意見お聞かせ下さい。

! 食塩水の混合

! 1000ccの攪拌機付き容器に濃度３％の食塩水が満杯（1000cc）
! 入っています。いま、ここへ濃度７％の食塩水を徐々に注入
! していき、ちょうど1000cc注入したところで注入を止める。
! このとき、食塩水の濃度は何％になっているか。

! 注入した食塩水は瞬時に混合されて均質になり、注入された量に
! 等しい量は容器からあふれ出て、容器内は常に1000ccに保たれて
! いるものとする。

LET d=3
LET h=1                        ! 注入する食塩水の量（hを小さくすれば精度がよくなる？）

FOR i=1 TO 1000 STEP h
   LET s=(d/100)*1000          ! 容器内の食塩の量
   LET t=(7/100)*h             ! 注入する食塩水中の食塩の量
   LET d=(s+t)/(1000+h)*100    ! 容器内の食塩水の濃度

   PRINT i;TAB(10);s;TAB(35);t;TAB(45);d
NEXT i

PRINT ""
PRINT "  食塩の量 s=";s
PRINT "  濃度     d=";d

END


! 結果
!   h=0.05 cc のとき     5.5270468 %
!   h=0.1  cc            5.5270837 %
!   h=1    cc            5.5277467 %
!   h=10   cc            5.5211551 %
!   h=50   cc            5.4924420 %
!   h=100  cc            5.4578268 %


 		 

Re: 食塩水の混合

 投稿者：島村１２４３  投稿日：2012年 4月21日(土)20時38分46秒
  エステーさんへのお返事です。

> ところで。私もプログラムをつくってみました。十進ベーシックを学び始めたばかりで、こういうプログラムでよいのかどうかもわからないのですが、とにかく見て頂きたいと思います。ご意見お聞かせ下さい。

エステーさん、こんにちわ。島村1243です。
エステーさんのプログラム読ませて頂きました。
私はプログラムテクニックは無いので、物理的な観点での意見を書きます。

（疑問点１）
1000という数字は容器の体積[cc]を、記号hは注入溶液の体積[cc]を表しているようですが、溶液の質量パーセント濃度X[%]は
  X=溶液中の塩の重量/溶液全体の重量＊100
で定義されている。したがって1000ccに濃度%/100を乗じても塩の重量を求めることは出来ない。
求める為にはその濃度を持つ溶液の比重[g/cc]値が必要。

エステーさんは溶液1[cc]は重量1[g]と捉えているようですが、そうだとすると、溶液の濃度に関わらず溶液の比重は常に１[g/cc]になってしまい、一般に食塩水は濃度が増加するに従い比重が1[g/cc]より大きくなる事実に反する。

(疑問点２）
式「d=(s+t)/(1000+h)*100」の分母は、容器の体積が(1000+h)に増大して攪拌していることを意味するから、エステーさんの命題主旨（容器は常に1000ccの体積を保ち攪拌する）に反する。

以上参考になれば幸いです。
なお蛇足ですが、私は「先生」の職ではないので「さん」付けで良いです。 		 

Re: 食塩水の混合

 投稿者：山中和義  投稿日：2012年 4月22日(日)13時44分59秒
  > No.1855[元記事へ]

エステーさんへのお返事です。

> 食塩水の混合
>
> 1000ccの攪拌機付き容器に濃度３％の食塩水が満杯（1000cc）
> 入っています。いま、ここへ濃度７％の食塩水を徐々に注入
> していき、ちょうど1000cc注入したところで注入を止める。
> このとき、食塩水の濃度は何％になっているか。
>
> 注入した食塩水は瞬時に混合されて均質になり、注入された量に
> 等しい量は容器からあふれ出て、容器内は常に1000ccに保たれて
> いるものとする。

物理的、化学的な複雑な現象を避けるために、
　数理モデル
　・比重は1[g/mL]とする
　・1[cc]=1[mL]（=1[g]）とする
　・飽和を考えない
　とする。
このような条件（大まかな考え方）があると思います。



> LET s=(d/100)*1000          ! 容器内の食塩の量
> LET t=(7/100)*h             ! 注入する食塩水中の食塩の量
> LET d=(s+t)/(1000+h)*100    ! 容器内の食塩水の濃度
>
> 結果
>   h=0.05 cc のとき     5.5270468 %

・『ΔXよりは、dX/dtの式を使う』

上記の現象を、
　(a) 濃度b[g/L]の食塩水PΔt[L]を加えて、よくかき混ぜる。
　(b) 次に食塩水をPΔt[L]捨てる。
　このことをΔtごとに繰り返す。
と考える。

時刻tにおける食塩水の濃度をX(t)[g/L]として、

(a)を行った段階では、
食塩量はX(t)V+(b/100)PΔt、水量はPΔtだけ増えるので、
食塩濃度は、X(t)から(X(t)V+(b/100)PΔt)/(V+PΔt)に変化する。

(b)を行った段階では、
食塩量は減るが濃度は変わらない。

よって、X(t+Δt)≒(X(t)V+(b/100)PΔt)/(V+PΔt)

これより、X(t)が満たす微分方程式をつくる。

X(0),X(Δt),X(2Δt),X(3Δt),…から、Δt→0として連続関数X(t)を得る。

X'(t)
=lim[Δt→0]{(X(t+Δt)-X(t))/Δt}
=lim[Δt→0]{X(t)( V/(V+PΔt) - 1 )/Δt + (b/100)P/(V+PΔt)}
=lim[Δt→0]{-X(t)P/(V+PΔt) + (b/100)P/(V+PΔt)}
=(-P/V)X(t) + (b/100)P/V
=(-X(t) + b/100)P/V

初期条件は、X(0)=a/100となる。



> ところで。私もプログラムをつくってみました。

t秒後の食塩の量をx[g]とする。
時間がtからt+Δtまで変化する間の食塩の増加は、Δx≒((B/100)*PΔt-(x/V)PΔtである。
両辺をΔtで割りΔt→0の極限を取って、微分方程式dx/dt=((B/100)V-x)P/Vを得る。
また、初期条件x(0)=(A/100)*V[g]である。

　　　　　　　　┌──
　　　　　　　　│┌─
　　　　　　　　││
　　　　　　　　 ∬ P[g],B[%]を注入する
　　　│～～～～～～│
　　　│　　　　　　│
　┌─┘ V[g],X[%]　│容器（最初にV[g],A[%] ）
　│┌┐　　　　　　│
　││└──────┘
　 ∬ P[g],X[%]を流出させる


LET A=3 !3%
LET B=7 !7%
LET V=1000 !1000g
LET P=1 !g/秒

LET M=10000 !0～10000gまで注入する

LET h=1 !Δt
LET ITER=M/P/h !繰り返し回数

SET WINDOW -2,INT(ITER/100), -1,(INT(B/10)+1)*10
DRAW grid(INT(ITER/100)/10,1) !目盛　[ITER/100]/10 秒ごと、1%ごと

!オイラー法（Euler）
DEF f(t,x)=(B/100*V-x)*P/V !常微分方程式x'(t)=f(x(t))

LET t=0 !t=0
LET x=A/100*V !x[0]

FOR i=0 TO ITER
   PRINT t; P*t; x/V*100; (A-B)*EXP((-P/V)*t)+B !時刻[秒]、注入量[g]、濃度[%]
   PLOT LINES: t/100,x/V*100; !折れ線で近似する

   LET x=x+h*f(t,x) !x[i]=x[i-1]+h*f'(t[i-1],x[i-1])
   LET t=t+h
NEXT i
PLOT LINES

END

 		 

食塩水の混合

 投稿者：エス・テー  投稿日：2012年 4月23日(月)09時00分7秒
  島村１２４３ さん、いろいろご指摘ありがとうございました。また、勉強してプログラムにも挑戦したいと思います。  

食塩水の混合

 投稿者：エス・テー  投稿日：2012年 4月23日(月)09時14分40秒
  山中先生、微分方程式作成の手順まで記述していただき、ありがとうございました。
これからもプログラム作成に挑戦してみたいと思います。よろしくお願い致します。 		 

Re: 食塩水の混合

 投稿者：島村１２４３  投稿日：2012年 4月23日(月)10時49分11秒
  > No.1858[元記事へ]

エス・テーさんへのお返事です。

> 島村１２４３ さん、いろいろご指摘ありがとうございました。また、勉強してプログラムにも挑戦したいと思います。

山中さんの解法はm(X)=1と扱い、微係数（導関数）dX/dtを求めてからオイラー法で数値計算を行う、という数学的に正統な方法で、微分や微分方程式の数値解法をご存知の場合はこの方法を使用すべきでしょう。

一方、私の示したX(t+Δt）の計算式は微分やオイラー法という知識を使わない近似計算式ですが、m(X)=1として
　{X(t+Δt）-X(t)}/Δt
を展開してからΔtを無限小（ゼロ）にすれば山中さんの示された導関数と同じ式が得られます。

この問題においてm(X)=1と扱った場合の数学的厳密解は、山中さんがプログラム中のPRINT行に示されているように
　X(t)=7-4exp(-Qt/1000)
となるので、7%濃度食塩水を1000cc注入完了した時点での容器内濃度X[%]の厳密解は、上式に
　Qt=1000[cc]
を代入して得られる
X=7-4exp(-1)=5.528482235....
となるので、エステーさんが作られるプログラムが適切か否かを判断する数値として用いると良いと思います。

なお、私の示したプログラムでも、m(X)=1、Q=1、Δt=0.01とセットし計算実行すると、上記厳密解の小数点以下第5位迄一致する数値が得られます（Δt=0.05にすると少数点以下第3位まで一致に精度低下する）。 		 

プログラマー入門

 投稿者：匿名  投稿日：2012年 4月24日(火)12時24分30秒
  http://1c-job.net
このサイトにはプログラマーとして必要だと思うことが載っています。
これをとっかかりにしてプログラムに興味が出てくること間違いないです。

http://1c-job.net

  

行列の積

 投稿者：永野護  投稿日：2012年 5月 8日(火)11時12分11秒
  プログラムの話ではありませんがよろしくお願いします。
行列の積（高校で学習するような2行2列の行列Aと2行2列の行列B
との積）というのはテンソル積なのでしょうか。それとも内積か外積
なのでしょうか。




 		 

Re: 行列の積

 投稿者：島村1243  投稿日：2012年 5月 9日(水)08時20分35秒
  > No.1862[元記事へ]

永野護さんへのお返事です。

> プログラムの話ではありませんがよろしくお願いします。
> 行列の積（高校で学習するような2行2列の行列Aと2行2列の行列B
> との積）というのはテンソル積なのでしょうか。それとも内積か外積
> なのでしょうか。

２行２列の正方行列はベクトルを表していない（ベクトルは、列ベクトルか行ベクトルのいずれかで表現する）ので、それら２個の正方行列AとBの積Cは（ベクトルの）内積・外積のいずれでもないと思います。

一方、共変１階反変１階のテンソルAと共変１階反変１階のテンソルBから、共変１階反変１階のテンソルCを得るテンソル積の計算法は、そのテンソルAとテンソルBを正方行列AとBで表して行列Aと行列Bの掛け算で得られる正方行列Cの成分計算法と同じになります。

したがって「正方行列の積はテンソル積」と言うよりは、「特定のテンソル積は行列の積で求めることも出来る」と言うのが適切の様です。この辺りについては下記サイト

　テンソルの概念 [物理のかぎしっぽ]
　http://hooktail.sub.jp/vectoranalysis/TensorConcept/

の中ほどに「テンソルの成分」という節が有り、その中の注[キ]にテンソルと行列の関係についての注意書きがあり参考になると思います。 		 

行列の積

 投稿者：永野護  投稿日：2012年 5月 9日(水)10時38分16秒
  島村様、丁寧な解説をありがとうございました。
大変助かりました。 		 

y= SIN(x) の線積分

 投稿者：SECOND  投稿日：2012年 5月11日(金)00時30分29秒
  ! y=SIN(x) の線積分 L=∫√{1+(dy/dx)^2}dx =∫√(1+cos(x)^2)dx
!
! 解かないまま、その積分曲線を、ルンゲクッタ４で、描く。
!
!     L =∫√(1+cos(x)^2) dx
!  dL/dx=  √(1+cos(x)^2)
!-------------------------------
SET TEXT background "opaque"
SET COLOR MIX(15) .4,.4,.4

SUB Diff( dL,x)
   LET dL=SQR(1+COS(x)^2)         !dL: (dL/dx) ※この部分を、COS(x), 2*x などに換えると、
END SUB                           !               その積分 SIN(x), x^2 の曲線が、描ける。

SUB RungeKutta
   CALL Diff( dL1,x)
   CALL Diff( dL2,x+dx/2)
   CALL Diff( dL3,x+dx/2)
   CALL Diff( dL4,x+dx)
   LET  L=L+(dL1 +2*dL2 +2*dL3 +dL4)*dx/6
END SUB

SET WINDOW -2.3, 7, -2, 9
DRAW grid( PI/2, 1)
PLOT TEXT,AT 1.7, 8.5:"    L=∫√(1+cos(x)^2) dx"
PLOT TEXT,AT 1.7, 8.0:"dL/dx=  √(1+cos(x)^2)"
!----
LET L=0                           !出力初期値 (上下に平行移動。積分定数の調整)
LET dx=PI/(pixelx(PI)-pixelx(0))  !計算 間隔
FOR x=0 TO 2*PI STEP dx           !計算 範囲
   PLOT LINES: x,L;
   CALL RungeKutta
NEXT x

END
 		 

n次多項式f(x)の法pでの因数分解

 投稿者：山中和義  投稿日：2012年 5月16日(水)09時29分16秒
 
!n次多項式f(x)の法pでの因数分解

!例
!f(x)=x^4+x^3+x^2+x+1なら、
!f(x)=(x-1)^4 (mod 5)
!f(x)=(x-3)(x-4)(x-5)(x-9) (mod 11)

!考察
!通常、実数の範囲での因数分解を考えると、
!fは2次式とする。
!　f(x)≡f(x) (mod p)　fは既約
!　f(x)≡g(x)h(x) (mod p)、g,hは1次式
!と因数分解される。
!
!fは3次式とする。
!　f(x)≡f(x) (mod p)　fは既約
!　f(x)≡g(x)h(x) (mod p)、gは2次式、hは1次式
!　f(x)≡g(x)h(x)s(x) (mod p)、g,h,sは1次式
!と因数分解される。
!
!fは4次式とする。
!　f(x)≡f(x) (mod p)　fは既約
!　f(x)≡g(x)h(x) (mod p)、gは3次式、hは1次式
!　f(x)≡g(x)h(x) (mod p)、g,hは2次式
!　f(x)≡g(x)h(x)s(x) (mod p)、gは2次式、h,sは1次式
!　f(x)≡g(x)h(x)s(x)t(x) (mod p)、g,h,s,tは1次式
!と因数分解される。
!
!fは5次式とする。5=1+4=2+3=(1+1)+3=1+2+2=1+(1+1)+2=1+(1+1)+(1+1)
!次数5を1,2,3,4の和で表せばよい。
!　　：
!　　：
!
!
!考察
!aが解なら、-(P-a)も解である。すなわち、x-a≡0 (mod p)またはx+(P-a)≡0 (mod p)


!参考サイト　http://www.e.ics.nara-wu.ac.jp/~kako/teaching/ca2005/chap6.pdf


DEF f(x)=x^4+x^3+x^2+x+1 !x^4+9*x^2+2*x+42

DEF e(x)=x^3+a*x^2+b*x+c !3次式
DEF g(x)=x^2+a*x+b !2次式
DEF h(x)=x^2+c*x+d
DEF s(x)=x-a !1次式
DEF t(x)=x-b
DEF u(x)=x-c
DEF v(x)=x-d

LET p=11 !素数


!3次式×1次式
LET K=0 !個数
FOR a=0 TO p-1 !係数　※剰余の範囲
   FOR b=0 TO p-1
      FOR c=0 TO p-1
         FOR d=0 TO p-1

            FOR x=0 TO p-1 !同じ値となるなら
               IF MOD(f(x) - e(x)*v(x) ,p)<>0 THEN EXIT FOR
            NEXT x
            IF x>p-1 THEN !因数分解される
               LET K=K+1

               PRINT "(x^3+";STR$(a);"x^2+";STR$(b);"x+";STR$(c);")"; !因数
               PRINT "(x-";STR$(d);")"

               PRINT "(x^3+";STR$(a);"x^2+";STR$(b);"x+";STR$(c);")"; !因数
               PRINT "(x+";STR$(p-d);")"
            END IF

         NEXT d
      NEXT c
   NEXT b
NEXT a
IF K=0 THEN PRINT "解なし"

PRINT


!2次式×2次式
LET K=0 !個数
FOR a=0 TO p-1 !係数　※剰余の範囲、a≦c
   FOR b=0 TO p-1
      FOR c=a TO p-1
         FOR d=0 TO p-1

            FOR x=0 TO p-1 !同じ値となるなら
               IF MOD(f(x) - g(x)*h(x) ,p)<>0 THEN EXIT FOR
            NEXT x
            IF x>p-1 THEN !因数分解される
               LET K=K+1
               PRINT "(x^2+";STR$(a);"x+";STR$(b);")"; !因数
               PRINT "(x^2+";STR$(c);"x+";STR$(d);")"
            END IF

         NEXT d
      NEXT c
   NEXT b
NEXT a
IF K=0 THEN PRINT "解なし"

PRINT


!2次式×1次式×1次式
LET K=0 !個数
FOR a=0 TO p-1 !係数　※剰余の範囲、c≦d
   FOR b=0 TO p-1
      FOR c=0 TO p-1
         FOR d=c TO p-1

            FOR x=0 TO p-1 !同じ値となるなら
               IF MOD(f(x) - g(x)*u(x)*v(x) ,p)<>0 THEN EXIT FOR
            NEXT x
            IF x>p-1 THEN !因数分解される
               LET K=K+1

               PRINT "(x^2+";STR$(a);"x+";STR$(b);")"; !因数
               PRINT "(x-";STR$(c);")(x-";STR$(d);")"

               PRINT "(x^2+";STR$(a);"x+";STR$(b);")"; !因数
               PRINT "(x+";STR$(p-d);")(x+";STR$(p-c);")"
            END IF

         NEXT d
      NEXT c
   NEXT b
NEXT a
IF K=0 THEN PRINT "解なし"

PRINT


!1次式×1次式×1次式×1次式
LET K=0 !個数
FOR a=0 TO p-1 !係数　※剰余の範囲、a≦b≦c≦d
   FOR b=a TO p-1
      FOR c=b TO p-1
         FOR d=c TO p-1

            FOR x=0 TO p-1 !同じ値となるなら
               IF MOD(f(x) - s(x)*t(x)*u(x)*v(x) ,p)<>0 THEN EXIT FOR
            NEXT x
            IF x>p-1 THEN !因数分解される
               LET K=K+1

               PRINT "(x-";STR$(a);")(x-";STR$(b);")"; !因数
               PRINT "(x-";STR$(c);")(x-";STR$(d);")"

               PRINT "(x+";STR$(p-d);")(x+";STR$(p-c);")"; !因数
               PRINT "(x+";STR$(p-b);")(x+";STR$(p-a);")"
            END IF

         NEXT d
      NEXT c
   NEXT b
NEXT a
IF K=0 THEN PRINT "解なし"

END

 		 

質問です

 投稿者：南澤  投稿日：2012年 5月17日(木)16時24分23秒
  十進BASICを勉強し始めたばかりの者なのですが、解説を見てもさっぱり分からないのでどなたか教えてください。
Sn:=n Σ i=1 1/i,
Tn:=n Σ i=1 1/i^2,
rn:=n Σ i=1 1/i^2+i
を計算するプログラムを作らねばならないのですが、私だけすっかり遅れを取ってしまい全く分かりません…。
自分でも試行錯誤しているのですが、どうしても分かりません。
よろしかったらどなたか解説等していただけないでしょうか…？ 		 

Re: 質問です

 投稿者：山中和義  投稿日：2012年 5月17日(木)16時41分52秒
  > No.1867[元記事へ]

南澤さんへのお返事です。

> Sn:=n Σ i=1 1/i,

　100
S=Σ 1/i
　i=1
とすると、

110 LET S=0
120 FOR i=1 TO 100
130    LET S=S+(1/i)
140 NEXT i
150 PRINT S
160 END

となります。後は、同様です。
 		 

Re: 質問です

 投稿者：南澤  投稿日：2012年 5月17日(木)18時33分46秒
  > No.1868[元記事へ]

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

ありがとうございます。
試してみて、もし分からなかったらまた質問させていただくかもしれません。
本当にありがとうございます！ 		 

(無題)

 投稿者：南澤  投稿日：2012年 5月18日(金)19時15分26秒
  たびたびすみません。

LET T=0
FOR i=1 TO 100
   LET T=T+(1/i^2)
NEXT i
PRINT T
END

二番目のTn:=n Σ i=1 1/i^2,は此れであっているのでしょうか？ 		 

Re: (無題)

 投稿者：南澤  投稿日：2012年 5月18日(金)19時34分4秒
  > No.1870[元記事へ]

付け足しなのですが、
nを１、１０，１００…と階乗させていき、其れを計算させることは可能でしょうか？
説明が下手ですみません； 		 

Re: (無題)

 投稿者：山中和義  投稿日：2012年 5月18日(金)20時27分22秒
  > No.1870[元記事へ]

南澤さんへのお返事です。

> たびたびすみません。
>
> LET T=0
> FOR i=1 TO 100
>    LET T=T+(1/i^2)
> NEXT i
> PRINT T
> END
>
> 二番目のTn:=n Σ i=1 1/i^2,は此れであっているのでしょうか？

あっています。理論値は、n→∞として、π^2/6です。


> N=1,10,100,1000,…

収束していくのが見えます。

110 LET M=0 !区間[M+1,N]
120 LET N=1
130 LET T=0 !和
140 DO WHILE N<=100000 !終端
150    FOR i=M+1 TO N !継続させる　T[N]=T[M]+Σ[i=M+1,N]
160       LET T=T+(1/i^2)
170    NEXT i
180    PRINT N;T; PI^2/6 !結果を表示する
190    LET M=N !次へ
200    LET N=N*10 !1,10,100,1000,…　10倍
210 LOOP
220 END


N=1のとき
　T[1]=1/1^2
N=10のとき
　T[10]=T[1] + 1/2^2+1/3^2+ … +1/10^2
　T[1]は既に算出しているので、それ以降の2から10までを計算すればよい。
N=100のとき
　T[100]=T[10] + 1/11^2+1/12^2+ … +1/100^2
　T[10]は既に算出しているので、それ以降の11から100までを計算すればよい。
N=1000のとき
　T[1000]=T[100] + 1/101^2+1/102^2+ … +1/1000^2
　T[100]は既に算出しているので、それ以降の101から1000までを計算すればよい。

　：
　：
 		 

Re: (無題)

 投稿者：山中和義  投稿日：2012年 5月19日(土)13時01分48秒
  > No.1872[元記事へ]

別解

> N=1,10,100,1000,…

等比数列（Nの数列）の部分もFOR文で記述できるので、二重のFOR文によるループで実現します。

110 LET T=0 !和
120 LET M=0 !区間[M+1,N]
130 FOR K=0 TO 5
140    LET N=10^K !1,10,100,1000,…
150    FOR i=M+1 TO N !継続させる　T[N]=T[M]+Σ[i=M+1,N]
160       LET T=T+(1/i^2)
170    NEXT i
180    PRINT N;T; PI^2/6 !結果を表示する
190    LET M=N !次へ
200 NEXT K
210 END



別解

> N=1,10,100,1000,…

Σ(1/i^2)で、i=1,2,3,…,10,…,100,…,1000,…の1,10,100,1000,…のタイミングで表示してもよいでしょう。


110 LET T=0 !和
120 LET K=0
130 LET M=1
140 FOR i=1 TO 10000 !1,2,3,4,…,9999,10000
150    LET T=T+(1/i^2) !Σ(1/i^2)
160    IF i=M THEN !等比数列1,10,100,…
170       LET M=M*10
180       PRINT i;T; PI^2/6 !結果を表示する
190    END IF
200 NEXT i
210 END

 		 

Re: (無題)

 投稿者：南澤  投稿日：2012年 5月19日(土)19時21分47秒
  ありがとうございます。
Σの一つの式なら段々わかって来ました。

また質問なのですが、
複数の式を一つのプログラムに纏めて計算させることも出来ると聞きました。
Σの計算に、その方法もあるのでしょうか？ 		 

Re: (無題)

 投稿者：山中和義  投稿日：2012年 5月19日(土)20時08分30秒
  > No.1874[元記事へ]

南澤さんへのお返事です。

> 複数の式を一つのプログラムに纏めて計算させることも出来ると聞きました。
> Σの計算に、その方法もあるのでしょうか？

100　　　　100
Σ(1/i) と Σ(1/i^2) を計算するプログラム
i=1　　　　i=1

110 LET S=0
120 LET T=0
130 FOR i=1 TO 100
140    LET S=S+(1/i)
150    LET T=T+(1/i^2)
160 NEXT i
170 PRINT S;T
180 END

という意味でしょうか？
 		 

Re: (無題)

 投稿者：南澤  投稿日：2012年 5月19日(土)20時16分13秒
  ありがとうございます。
これにもう一つの式を足せば、
三つを一遍に計算出来ると言うことでしょうか？ 		 

Re: (無題)

 投稿者：山中和義  投稿日：2012年 5月19日(土)20時58分14秒
  > No.1876[元記事へ]

南澤さんへのお返事です。

> これにもう一つの式を足せば、三つを一遍に計算出来ると言うことでしょうか？

そうです。

先のプログラムは、

110 LET S=0
120 FOR i=1 TO 100
130    LET S=S+(1/i)
140 NEXT i
150 PRINT S
160 LET T=0
170 FOR i=1 TO 100
180    LET T=T+(1/i^2)
190 NEXT i
200 PRINT T
210 END

と同じで、FOR-NEXT文が共通なので、まとめて記述したということです。
 		 

隣接2項がピタゴラス数になる数列

 投稿者：山中和義  投稿日：2012年 5月20日(日)14時02分37秒
  100項すべて求めるには、PCパワーがかなり必要である。


!問題
!次の条件を満たすような100個の相異なる正整数の数列 a[1],a[2], … ,a[100]
!が存在することを証明せよ。
!
!(条件) 99以下のすべての正整数nに対して、(a[n])^2 + (a[n+1])^2 は平方数である。

!参考サイト
!　http://oeis.org/A076671　並び 5,…
!　http://oeis.org/A076672　並び 6,…
!　http://oeis.org/A076673　並び 7,…
!　http://oeis.org/A076674　並び 9,…
!　http://oeis.org/A076675　並び 10,…
!　http://oeis.org/A076676　並び 11,…

!答え
!0＜a[1]＜a[2]＜a[3]＜a[4]＜a[5]＜ … となる増加列を考える。
!
!a[1]^2  a[2]^2  p^2
!a[2]^2  a[3]^2  q^2
!a[3]^2  a[4]^2  r^2
!a[4]^2  a[5]^2  s^2
!　　 ：
!
!実際に、いくつかの並びを求めてみる。
!サイト http://oeis.org/A076600 によると、以下の数で始まる並びはない。
!　1,…
!　2,…
!　3,4,…　下記の4から始まる並びに吸収される
!　4,…
!
!一般に、a[1]≧5（予想）では、いずれかの並びに吸収されて、無限に増加列がつくれる。
!　5,12,…　　12から始まる並び
!　6,8,…　　8から始まる並び
!　7,24,…　　24から始まる並び
!　8,15,…　　15から始まる並び
!　9,12,…　　12から始まる並び
!　10,24,…　　24から始まる並び
!　11,60,…　　60から始まる並び
!　12,16,…　　16から始まる並び
!　　：
!　15,20,…　　20から始まる並び
!　16,30,…　　30から始まる並び
!　　：
!
!したがって、a[1]＜a[2]　すなわち、A=1,2,3,4,…として、
!A＜BかつA^2+B^2=P^2となるBを探せばよい。
!
!実際に、数の並びの生成を考察してみる。
!
!自然数m,nかつm＞nとして、(m^2-n^2, 2mn, m^2+n^2)は、ピタゴラス数をつくるので、
!(A,B,P)=(m^2-n^2, 2mn, m^2+n^2)または(2mn, m^2-n^2, m^2+n^2)を考える。
!Aが1の場合、ピタゴラス数はない。
!Aが素数
!　Aが2の場合、ピタゴラス数はない。
!　奇素数
!　　A=m^2-n^2の形で、A=(m+n)(m-n)=p*1より、m=(p+1)/2, n=(p-1)/2
!　　このとき、mとnは互いに素なので、既約なピタゴラス数をつくる。
!Aが合成数
!　Aが奇数
!　　A=m^2-n^2の形で、A=(m+n)(m-n)=s*t（s,tは奇数かつs＞t）より、
!　　m=(s+t)/2, n=(s-t)/2とするピタゴラス数をつくる（つくれる）。
!　　または、既約なピタゴラス数のk倍(p*k,q*k,r*k)
!　Aが偶数
!　　Aが4の場合、ピタゴラス数はない。
!　　A≧6の場合、
!　　　A=2mnの形で、ピタゴラス数をつくる（つくれる）。
!　　　または、既約なピタゴラス数のk倍(p*k,q*k,r*k)
!
!とすれば良さそうである。

OPTION ARITHMETIC RATIONAL !多桁整数

LET A=6 !a[1]

LET K=0 !個数
DO WHILE K<100
   LET B=A+1 !a[2]　※a[n]＜a[n+1]
   LET T=2*A*B+1 !A^2+B^2=A^2+(A+1)^2=2A(A+1)+1=2AB+1

   DO !A＜Bとして、A^2+B^2=P^2となるBを探す
      LET P=INTSQR(T)
      IF P*P=T THEN EXIT DO !平方数なら

      !ピタゴラス数
      LET T=T+2*B+1 !A^2+(B+1)^2=(A^2+B^2)+2B+1
      LET B=B+1
   LOOP

   LET K=K+1 !結果を表示する
   PRINT STR$(K);": "; A;B;P; T

   LET A=B !a[2],a[3],…
LOOP

END

 		 

Re: 隣接2項がピタゴラス数になる数列

 投稿者：山中和義  投稿日：2012年 5月21日(月)10時49分1秒
  > No.1878[元記事へ]

> 問題
> 次の条件を満たすような100個の相異なる正整数の数列 a[1],a[2], … ,a[100]
> が存在することを証明せよ。
>
> (条件) 99以下のすべての正整数nに対して、(a[n])^2 + (a[n+1])^2 は平方数である。

数学的には、
　a,b,cはピタゴラス数、すなわちa^2+b^2=c^2を満たすとして、
　初項a^99、公比(b/a)の等比数列を考える。
　n項目は、b^(n-1)*a^(100-n)となる。
　具体的には、a^99, b*a^98, b^2*a^97, … , b^98*a, b^99 の100項となる。
とすればよい。
（証明）
a^2+b^2=c^2なので、そのk倍、すなわちk*(a^2+b^2)=k*c^2もピタゴラス数となる。
k={b^(n-1)*a^(100-n)}^2、n=1,2,3,…,100 とすると、
左辺
=k*(a^2+b^2)
={b^(n-1)*a^(100-n)}^2*(a^2+b^2)
={ b^(n-1)*a^(100-n)*a }^2 + { b^(n-1)*a^(100-n)*b }^2
={ b^(n-1)*a^(100-n) *a }^2 + { {b^(n-1)*a^(100-n)*(b/a)} *a }^2
右辺
={b^(n-1)*a^(100-n)*c}^2
1番目の項は第n項で、2番目の項は第(n+1)項を表す式と考えれば、
b^(n-1)*a^(100-n)は、公比(b/a)の等比数列を表す。
（終り）

かなり大きな数ですが、機械的に生成できます。
 		 

ルート計算の処理方法での質問

 投稿者：GAI  投稿日：2012年 5月21日(月)12時56分44秒
  計算の中で√の処理がどのようになされているのでしょうか？
例えば（１＋√２）＾３
を求めたいときに、プログラムで
let w=(1+sqr(2))^3
print w
end

とやれば、14.0710678118655
と数値で返ってきます。

ここを７＋５√２
で結果が欲しい時は、プログラム的にどのようにしておけばよいのか教えて下さい。
 		 

Re: ルート計算の処理方法での質問

 投稿者：山中和義  投稿日：2012年 5月21日(月)13時39分15秒
  > No.1880[元記事へ]

GAIさんへのお返事です。

> 計算の中で√の処理がどのようになされているのでしょうか？
> 例えば（１＋√２）＾３
> を求めたいときに、プログラムで
> let w=(1+sqr(2))^3
> print w
> end
>
> とやれば、14.0710678118655
> と数値で返ってきます。
>
> ここを７＋５√２
> で結果が欲しい時は、プログラム的にどのようにしておけばよいのか教えて下さい。

この形なら、二項展開すれば数式処理が可能だと思います。


!(a+√b)^n、nは自然数 を展開する

LET a=1 !a
LET b=2 !√b
LET n=3

LET P=0 !aの係数
LET Q=0 !√bの係数
FOR k=0 TO n !二項展開する
   IF MOD(k,2)=0 THEN
      LET P=P+COMB(n,k)*a^(n-k)*b^(k/2) !aの係数
   ELSE
      LET Q=Q+COMB(n,k)*a^(n-k)*b^((k-1)/2) !√bの係数
   END IF
NEXT k

PRINT P;"+";Q;"√";b !結果を表示する

END
 		 

式 A=K*B^M+N

 投稿者：山中和義  投稿日：2012年 5月23日(水)11時31分55秒
  問題
正整数A,B（B≠1）が与えられる。このとき、A=K*B^M+N を満たす非負整数K,M,Nを求めよ。
ただし、K（K＜B）とMは最大とする。　例　10=1*2^3+2、20=2*3^2+2

S,K,Eをからめて解いてみます♪


LET A=10
LET B=2

!その１　割っていく

LET S=1 !B^M
LET K=A
LET M=0
DO WHILE K>=B !A＞B^Mを満たす最大のMを求める
   LET S=S*B
   LET K=INT(K/B) !次へ
   LET M=M+1
LOOP
LET N=A-K*S !余り

PRINT K;M;N !結果を表示する


!その２　かけていく

LET S=1 !B^M
LET E=S*B
LET M=0
DO WHILE A>=E !A＞B^Mを満たす最大のMを求める
   LET S=E
   LET E=E*B !次へ
   LET M=M+1
LOOP
LET K=INT(A/S) !最上位桁の値
LET N=A-K*S !余り

PRINT K;M;N !結果を表示する


END

 		 

Re: 式 A=K*B^M+N

 投稿者：山中和義  投稿日：2012年 5月23日(水)13時19分23秒
  > No.1882[元記事へ]

類題
正整数A,B（B≠1）が与えられる。このとき、A=B^K+S を満たす非負整数K,Sを求めよ。
ただし、Kは最大とする。　例　10=2^3+2、20=3^2+11

答え
B進法表記を利用すると、
A=P*B^K+Q*B^(K-1)+ … +U*B+V=B^K + (P-1)*B^K+Q*B^(K-1)+ … +U*B+V、P≧1より、

例　10=2^3+2
　10は2進法で、1010なので、最上位の桁に注意すると、0010　∴2
例　20=3^2+11
　20は3進法で、202なので、最上位の桁に注意すると、102　∴11

前出の問題も同様です。

S,K,Eをからめて解いてみます♪　センター候補にどうでしょうか！


LET A=15
LET B=3

LET E=A
LET K=0
DO WHILE E>=B !進数変換（B進法へ）
   LET E=INT(E/B) !次へ
   LET K=K+1
LOOP
LET S=A-B^K

PRINT K;S !結果を表示する

END

 		 

不思議な関係

 投稿者：GAI  投稿日：2012年 5月23日(水)22時16分32秒
  無理数を含む式の冪乗の展開式のプログラムを書いて頂いたので、これを少し拡張して
次のものを作って次の現象が成り立つことが確認出来ました。

INPUT PROMPT "e=a+s√bのaは？": a
INPUT PROMPT "e=a+s√bのsは？":s
INPUT PROMPT "e=a+s√bのbは？": b0   !√b0
INPUT PROMPT "eの何乗までですか？": m
FOR w=1 TO m
   LET P=0 !aの係数
   LET Q=0 !√bの係数
   LET b=s^2*b0                          !s√b0=√s^2*b0=√b
   FOR k=0 TO w !二項展開する
      IF MOD(k,2)=0 THEN
         LET P=P+COMB(w,k)*a^(w-k)*b^(k/2) !aの係数
      ELSE
         LET Q=Q+COMB(w,k)*a^(w-k)*b^((k-1)/2) !√bの係数
      END IF
   NEXT k
   PRINT w;"→";P;"+";Q*s;"√";b0              !結果を表示する
NEXT w
END

n:(1+√2)^nの展開式
1 ： 1+1√2→1^2-2*1^2=-1の関係式が成立
2 ： 3+2√2→3^2-2*2^2=1の関係式が成立
3 ： 7+5√2→7^2-2*5^2=-1
4 ： 17+12√2→17^2-2*12^2=1
5 ： 41+29√2→41^2-2*29^2=-1
6 ： 99+70√2→99^2-2*70^2=1
7 ： 239+169√2→239^2-2*169^2=-1
8 ： 577+408√2→577^2-2*408^2=1
9 ： 1393+985√2→1393^2-2*985^2=-1
10 ： 3363+2378√2→3363-2*2378^2=1
11 ： 8119+5741√2→以下同様
12 ： 19601+13860√2
13 ： 47321+33461√2
14 ： 114243+80782√2
15 ： 275807+195025√2
16 ： 665857+470832√2
17 ： 1607521+1136689√2
18 ： 3880899+2744210√2
19 ： 9369319+6625109√2
20 ： 22619537+15994428√2
21 ： 54608393+38613965√2
22 ： 131836323+93222358√2
23 ： 318281039+225058681√2
24 ： 768398401+543339720√2
25 ： 1855077841+1311738121√2
26 ： 4478554083+3166815962√2
27 ： 10812186007+7645370045√2
28 ： 26102926097+18457556052√2
29 ： 63018038201+44560482149√2
30 ： 152139002499+107578520350√2

また(8+3√7)^nの展開式について調べると
n:(8+3√7)^nの展開式
1 ： 8+3√7→8^2-7*3^2=1の関係式が成立
2 ： 127+48√7→127^2-7*48^2=1の関係式が成立
3 ： 2024+765√7→2024^2-7*765^2=1の関係式が成立
4 ： 32257+12192√7→32257^2-7*12192^2=1の関係式が成立
5 ： 514088+194307√7→ 以下同様
6 ： 8193151+3096720√7
7 ： 130576328+49353213√7
8 ： 2081028097+786554688√7
9 ： 33165873224+12535521795√7
10 ： 528572943487+199781794032√7
11 ： 8424001222568+3183973182717√7
12 ： 134255446617601+50743789129440√7


このように不思議な関係が成立する無理数を含む数として
√2→1+√2
√3→2+√3
√5→(1+√5)/2
√6→5+2√6
√7→8+3√7
√10→3+√10
√11→10+3√11
√13→(3+√13)/2
√14→15+4√14
・・・
 		 

Re: 不思議な関係

 投稿者：山中和義  投稿日：2012年 5月24日(木)10時45分53秒
  > No.1884[元記事へ]

GAIさんへのお返事です。

> 無理数を含む式の冪乗の展開式のプログラムを書いて頂いたので、これを少し拡張して
> 次のものを作って次の現象が成り立つことが確認出来ました。

漸化式で求めてみました。


!A,K,B≧0、Eは自然数とする。
!S=(A+K√B)^E=N+M√B を計算する。

!漸化式で表すことを考える。
!べき乗がEまでの値をA[E]+K[E]√Bとすると、
!A[E+1]+K[E+1]√B=(A+K√B)(A[E]+K[E]√B)=(A*A[E]+K*B*K[E])+(K*A[E]+A*K[E])√B
!したがって、
!　A[E+1]=A*A[E]+K*B*K[E]
!　K[E+1]=K*A[E]+A*K[E]
!の連立漸化式を得る。

LET A=5 !a
LET K=2 !k
LET B=6 !√b
LET E=6 !べき乗

LET N=A !a[e]
LET M=K !k[e]
FOR i=2 TO E !漸化式を計算する
   LET T=A*N+K*B*M !※Nの変更に注意する
   LET M=K*N+A*M
   LET N=T
NEXT i

PRINT N;"+";M;"√";B !結果を表示する


PRINT N^2-M^2*B !±1　ペル方程式

PRINT N/M; SQR(B) !√bの近似値

END



> このように不思議な関係が成立する無理数を含む数として

E→∞で、N/Mは√Bとなります。

(A+K√B)(A-K√B)=A^2-K^2*Bなので、
ペル方程式A^2-K^2*B=±1を満たすA,K,Bで、N/M（E→∞）は√Bになる。

ペル方程式を使って、√Bを求めることもできます。



A,K,Bでプログラミング学習にトライ！（笑）
 		 

AKB48に挑戦

 投稿者：GAI  投稿日：2012年 5月24日(木)19時16分38秒
  A+K√BのAは？48
A+K√BのKは？7
A+k√BのBは？47
何乗までですか？10

1 乗は 48 + 7 √ 47
ノルムは 1
  N/M= 6.8571428571428571
√ 47 = 6.8556546004010441


2 乗は 4607 + 672 √ 47
ノルムは 1
  N/M= 6.8556547619047619
√ 47 = 6.8556546004010441


3 乗は 442224 + 64505 √ 47
ノルムは 1
  N/M= 6.8556546004185722
√ 47 = 6.8556546004010441


4 乗は 42448897 + 6191808 √ 47
ノルムは 1
  N/M= 6.8556546004010460
√ 47 = 6.8556546004010441


5 乗は 4074651888 + 594349063 √ 47
ノルムは 1
  N/M= 6.8556546004010441
√ 47 = 6.8556546004010441


6 乗は 391124132351 + 57051318240 √ 47
ノルムは 1
  N/M= 6.8556546004010441
√ 47 = 6.8556546004010441


7 乗は 37543842053808 + 5476332201977 √ 47
ノルムは 1
  N/M= 6.8556546004010441
√ 47 = 6.8556546004010441


8 乗は 3603817713033217 + 525670840071552 √ 47
ノルムは 1
  N/M= 6.8556546004010441
√ 47 = 6.8556546004010441


9 乗は 345928956609135024 + 50458924314667015 √ 47
ノルムは 1
  N/M= 6.8556546004010441
√ 47 = 6.8556546004010441


10 乗は 33205576016763929087 + 4843531063367961888 √ 47
ノルムは 1
  N/M= 6.8556546004010441
√ 47 = 6.8556546004010441
 		 

有理数化

 投稿者：しばっち  投稿日：2012年 5月24日(木)20時57分49秒
  OPTION BASE 0
OPTION ARITHMETIC DECIMAL_HIGH
LET MAXLEVEL=30
DIM P(MAXLEVEL)
FOR XX=2 TO 50
   LET FL=0
   FOR K=2 TO 8
      IF K*K=XX THEN LET FL=1
   NEXT K
   IF FL=0 THEN
      MAT P=ZER
      LET X=SQR(XX)
      PRINT "SQR(";XX;")"
      LET A=X
      LET B=1
      !' IF A < B THEN
      !'    SWAP A,B
      !'    LET L=1
      !'    PRINT "1 / (";
      !' END IF
      FOR I=L TO MAXLEVEL
         LET P(I)=INT(A/B)
         LET BB=A-P(I)*B
         LET AA=B
         LET A=AA
         LET B=BB
         !'  PRINT P(I);
         !'  IF I < MAXLEVEL THEN PRINT "+ 1 / (";
      NEXT I
      !' PRINT REPEAT$(")",MAXLEVEL-L)

      !'FOR J=1 TO MAXLEVEL
      !'   LET S=P(J)
      !'   FOR I=J-1 TO 0 STEP -1
      !'      LET S=P(I)+1/S
      !'   NEXT I
      !'   PRINT USING "-%.##########################################    -%.########^^^^^^":S,X-S
      !'NEXT J
      FOR J=1 TO MAXLEVEL
         LET B=P(J)
         LET A=1
         FOR I=J-1 TO 0 STEP -1
            LET AA=B
            LET BB=B*P(I)+A
            LET A=AA
            LET B=BB
         NEXT I
         LET D=GCD(A,B)
         PRINT B/D;"/";A/D,
         !' PRINT (B/D)^2-(A/D)^2*XX,
         PRINT USING "-%.########^^^^^^":X-B/A
      NEXT J
   END IF
NEXT XX
END

EXTERNAL  FUNCTION GCD(M,N)
OPTION ARITHMETIC DECIMAL_HIGH
DO WHILE N <> 0
   LET  T = MOD(M , N)
   LET  M = N
   LET  N = T
LOOP
LET  GCD=M
END FUNCTION
 		 

Re: 不思議な関係

 投稿者：山中和義  投稿日：2012年 5月25日(金)10時47分42秒
  > No.1885[元記事へ]

GAIさんへのお返事です。

> ペル方程式を使って、√Bを求めることもできます。

√B
A^2-K^2*B=±1の解(a,k)より、S=(a+k√B)^E=N+M√Bを求める。
E→∞として、√B≒N/Mとなる。

次のプログラムで(a,k)を求めて、前出のプログラムでN,Mを求める。


ペル方程式 X^2-D*Y^2=±1 の最小な自然数解を求める


OPTION ARITHMETIC RATIONAL !有理数モード

LET D=48 !Dは平方数でない正整数　※

LET D0=D !Dが1より小さいなら、有理化する
IF D<1 THEN LET D=NUMER(D)*DENOM(D)

LET G0=0 !初期値
LET H0=1
LET Y0=1
LET Y1=0
LET K0=INTSQR(D)

LET N=0 !繰り返した回数

DO !連分数展開する漸化式を計算する
   LET K=INT((K0+G0)/H0) !連分数展開の各桁の数　√94≒9[1,2,3,1,1,5,1,8,1,5,1,1,3,2,1,18,…]

   LET G=-G0+K*H0
   LET H=(D-G*G)/H0

   LET X=G0*Y1+H0*Y0 !n番目で打ち切ったときの部分和 X/Y
   LET Y=Y0+K*Y1

   LET X0=X
   LET Y0=Y1
   LET Y1=Y

   PRINT N;":"; G0;H0;K;Y0;X0 !途中経過を表示する

   !H=1となるnについて、p[n+1],q[n+1]がペル方程式の解となる
   IF G=G0 THEN !Moirの定理より
      PRINT X0;X; Y0;Y1;Y !debug
      PRINT "m=2n" !debug

      LET P=(X0^2+D*Y0^2)/H0 !a[2n]=a[n]^2/h[n]
      LET Q=2*X0*Y0/H0

      EXIT DO
   ELSEIF H=H0 THEN
      LET X=G*Y1+H*Y0

      PRINT X0;X; Y0;Y1;Y !debug
      PRINT "m=2n+1" !debug

      LET P=(X*X0+D*Y0*Y1)/H0 !a[n]*a[n+1]/h[n]
      LET Q=(X*Y0+Y1*X0)/H0

      EXIT DO
   END IF

   LET G0=G !次へ
   LET H0=H

   LET N=N+1
LOOP

PRINT P;"+";Q*DENOM(D0);"√";D0

PRINT "(";P;",";Q*DENOM(D0);")" !解を表示する


END



大きな(a,k)で、より早く大きな(n,m)を見つけると効率が上がる。

√B
A^2-K^2*B=±4の解(a,k)より、
漸化式
　p[1]=a、q[1]=k
　p[n+1]=p[n]^2-2、q[n+1]=p[n]q[n]
を求める。
n→∞として、√B≒p[n]/q[n]となる。


LET A=2702 !(a,k)
LET K=390
PRINT A^2-K^2*48; A/K; SQR(48)
FOR i=1 TO 3
   LET K=A*K !漸化式 p[n+1]=p[n]^2-2、q[n+1]=p[n]q[n]
   LET A=A^2-2
   PRINT i;":";A;K; A/K
NEXT i
END



> A,K,Bでプログラミング学習にトライ！（笑）

　倍数 A=K*B
　不定方程式 Ax+By=K
　合同式 A≡K (mod B)
など
 		 

Re: 有理数化

 投稿者：山中和義  投稿日：2012年 5月25日(金)16時47分27秒
  > No.1887[元記事へ]

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

平方根の連分数展開による分数近似ですね。

例 √48の場合
7/1
90/13
97/14
1254/181
1351/195
　：
　：


> DIM P(MAXLEVEL)

連分数
P(0) [P(1),P(2),P(3), … ,P(MAXLEVEL)]

例
√48≒ 6 [1,12,1,12,1,12,1,12, … ]

と認識しました。
 		 

Re: 不思議な関係

 投稿者：山中和義  投稿日：2012年 5月26日(土)10時31分15秒
  > No.1888[元記事へ]

GAIさんへのお返事です。

> S=(A+K√B)^E=N+M√B を計算する。

>次のプログラムで(a,k)を求めて、前出のプログラムでN,Mを求める。

平方根の連分数展開が根底にあるようですね。

M,Nを求める計算は、(A,K)から得られた1次分数関数でも可能です。
ニュートン法でも漸化式として、別の分数関数を使っています。


!1次分数関数を使って、√Bを求める

!ペル方程式 A^2-K^2*B=±1を満たすA,K,Bで、
!1次分数関数f(x)=(A*x+K*B)/(K*x+A)として、f*f*f* … *f(x)を求める。
!このとき、x[1],x[2],x[3],…,x[n]は分数近似となる。
!n→∞として、√B≒f^n(x)

!例　√7≒2.64575131106459 の場合
!f(x)=(8x+21)/(3x+8)　∴x[1]=21/8
!f*f(x)=f(f(x)=(127x+336)/(48x+127)　∴x[2]=336/127
!f*f*f(x)=f(f(f(x))=(2024x+5355)/(765x+2024)　∴x[3]=5355/2024
!　：
!f^n(x)=(A[n]*x+K[n]*B[n])/(K[n]*x+B[n])　∴x[n]=K[n]*B[n]/A[n]

DEF f(x)=(A*x+K*B)/(K*x+A) !1次分数関数

LET A=8 !a
LET K=3 !k
LET B=7 !√b

LET x=0
FOR n=1 TO 10 !合成関数を計算する
   LET x=f(x)
   PRINT n;":";x
NEXT n

!!PRINT SQR(B) !検算



!行列を使って、√Bを求める

!1次分数関数の合成関数は、行列の積（べき乗）で表現できる。
!M=┌ A K*B ┐として、M^nを求める。
!　└ K A   ┘
!(a,k)を1列目、近似分数(K*B)/Aが2列目に並ぶ。

DIM M(2,2) !変換を表す行列
LET M(1,1)=A
LET M(1,2)=K*B
LET M(2,1)=K
LET M(2,2)=A

DIM T(2,2) !M^n
MAT T=IDN
FOR i=1 TO 10 !べき乗
   MAT T=T*M
   MAT PRINT T;
NEXT i

END

 		 

(無題)

 投稿者：南澤  投稿日：2012年 5月28日(月)13時33分14秒
  ベーシックで星形を書き、中に色を塗りたいのですが…

REM 角度をDEGREE(度）に指定
OPTION ANGLE DEGREES

SET WINDOW 0,400,0,400
CLEAR

REM cx=中心X,cy=中心y,r=大きさ
LET cx=200
LET cy=200
LET r=200

LET px=cx+sin(0)*r
LET py=cy+cos(0)*r

PLOT LINES: px,py;

DO
   INPUT PROMPT "３以上の奇数を入力してください ":n
   LET n=INT(n)
LOOP WHILE n<3 OR INT(n/2)=(n/2)

FOR i=1 TO n
LET px=cx+SIN(360/n*i*2)*r
   LET py=cy+COS(360/n*i*2)*r

   PLOT px,py;
NEXT i

END
此れで星形は書いてみました。しかし、色を塗ることが出来ません…。
赤で塗るのならば
SET AREA COLOR "red"
paint 1,1
だと思うのですが、星形がわかれているため
paint 1,1を何処に挿入すれば良いのか分かりません。
最初の書き方では色は塗れないのでしょうか？ 		 

Re: (無題)

 投稿者：山中和義  投稿日：2012年 5月29日(火)10時08分23秒
  > No.1891[元記事へ]

南澤さんへのお返事です。

> ベーシックで星形を書き、中に色を塗りたいのですが…

> 赤で塗るのならば
> SET AREA COLOR "red"
> paint 1,1
> だと思うのですが、星形がわかれているため
> paint 1,1を何処に挿入すれば良いのか分かりません。

FULL BASIC仕様なら、paint文はありませんので、

!星型多角形

SET WINDOW 0,400,0,400

LET N=5 !星型n角形

LET CX=200 !中心
LET CY=200
LET R=200 !半径
LET R2=120 !0＜R2＜R

DIM PX(0 TO 2*N-1),PY(0 TO 2*N-1) !正n角形の頂点列　※正2n角形と考える
FOR i=0 TO N-1 !凸側
   LET K=2*i
   LET T=2*PI*K/(2*N)
   LET PX(K)=CX+SIN(T)*R !※X軸とY軸を入れ替える
   LET PY(K)=CY+COS(T)*R
NEXT i

FOR i=0 TO N-1 !凹側
   LET K=2*i+1
   LET T=2*PI*K/(2*N)
   LET PX(K)=CX+SIN(T)*R2
   LET PY(K)=CY+COS(T)*R2
NEXT i

SET AREA COLOR "RED"
MAT PLOT AREA, LIMIT 2*N: PX,PY

END

とするのが良いでしょう。簡易図形描画の手法です。

FULL BASIC仕様なら、塗り潰しは、閉領域を使って行います。

!星型多角形

!円をn等分し、その頂点からm進んだ頂点へ線分を引いていき、
!元の頂点に戻るまで繰り返したときにできる形を正(n/m)角形とする。
!ただし、2*m＜nの自然数とする。
!m≡1 (mod n)なら、通常の正n角形
!m≡2 (mod n)なら、星型正n角形（その1）
!m≡3 (mod n)なら、星型正n角形（その2）
!　：
!　：

SET WINDOW 0,400,0,400

LET N=5 !正(n/m)角形
LET M=2

LET CX=200 !中心
LET CY=200
LET R=200 !半径


DIM PX(0 TO N-1),PY(0 TO N-1) !正n角形の頂点列
LET S=0
FOR i=0 TO N-1
   LET T=2*PI*S/N
   LET PX(i)=CX+SIN(T)*R !※X軸とY軸を入れ替える
   LET PY(i)=CY+COS(T)*R
   LET S=MOD(S+M,N) !m間隔
NEXT i

SET AREA COLOR "RED"
MAT PLOT AREA, LIMIT N: PX,PY

END

となります。

内部の正n角形の大きさを計算するのは、簡単にはいかないようです。

ただ、FULL BASIC仕様以外なら、

SET LINE COLOR "RED"
SET AREA COLOR "RED"
paint CX,CY

を最後に追加すれば目的は達成できます。
 

Re: (無題)

 投稿者：しばっち  投稿日：2012年 5月29日(火)20時39分24秒
  > No.1892[元記事へ]

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

> 内部の正n角形の大きさを計算するのは、簡単にはいかないようです。

対象とする図から直線2本を選び出し
直線の方程式から交点を求める

LET N=7
LET X1=COS(PI/2) !'半径1とする 頂点1番
LET Y1=SIN(PI/2)
LET X2=COS(PI/2+2*PI/N) !'頂点2番
LET Y2=SIN(PI/2+2*PI/N)
LET X3=COS(PI/2+2*PI/N*2) !'頂点3番
LET Y3=SIN(PI/2+2*PI/N*2)
LET XN=COS(PI/2+2*PI/N*(N-1)) !'頂点N番
LET YN=SIN(PI/2+2*PI/N*(N-1))

!'頂点1と頂点3を結ぶ直線,頂点2と頂点Nを結ぶ直線との交点
CALL CROSS(X1,Y1,X3,Y3,X2,Y2,XN,YN,XX,YY)

LET RR=SQR(XX^2+YY^2) !'原点からの距離(比率)
SET WINDOW 0,400,0,400
LET CX=200 !中心
LET CY=200
LET R=200 !半径
LET R2=R*RR

DIM PX(0 TO 2*N-1),PY(0 TO 2*N-1) !正n角形の頂点列　※正2n角形と考える
FOR i=0 TO N-1 !凸側
   LET K=2*i
   LET T=2*PI*K/(2*N)
   LET PX(K)=CX+SIN(T)*R !※X軸とY軸を入れ替える
   LET PY(K)=CY+COS(T)*R
NEXT i

FOR i=0 TO N-1 !凹側
   LET K=2*i+1
   LET T=2*PI*K/(2*N)
   LET PX(K)=CX+SIN(T)*R2
   LET PY(K)=CY+COS(T)*R2
NEXT i

SET AREA COLOR "RED"
MAT PLOT AREA, LIMIT 2*N: PX,PY

END

EXTERNAL  SUB CROSS(X1,Y1,X2,Y2,X3,Y3,X4,Y4,X,Y)
!'点(X1,Y1)と点(X2,Y2)を結ぶ直線
!'点(X3,Y3)と点(X4,Y4)を結ぶ直線
!'との交点(X,Y)を求める
LET A=(Y2-Y1)/(X2-X1)
LET B=(Y4-Y3)/(X4-X3)
LET X=(Y3-Y1+A*X1-B*X3)/(A-B)
LET Y=A*X+Y1
END SUB
 		 

回転アニメーション

 投稿者：しばっち  投稿日：2012年 5月29日(火)20時41分12秒
  CALL GINIT(400,400)
LET CX=200
LET CY=200
LET R=200
LET C=2
LET K=2
SET LINE COLOR C
FOR N=5 TO 11 STEP 2
   FOR ST=25 TO 360 STEP 20
      FOR T=0 TO 360*5 STEP ST
         LET TT=T*PI/180
         SET DRAW MODE HIDDEN
         CLEAR
         PLOT LINES
         FOR I=0 TO N
            LET PX=CX+COS(PI/2+2*PI/N*I*K+TT)*R
            LET PY=CY-SIN(PI/2+2*PI/N*I*K+TT)*R
            PLOT LINES:PX,PY;
         NEXT I
         SET COLOR C
         PAINT CX,CY
         FOR I=1 TO N
            LET PX=CX+COS(PI/2+2*PI/N*I*K+TT)*R*.96
            LET PY=CY-SIN(PI/2+2*PI/N*I*K+TT)*R*.96
            PAINT PX,PY
         NEXT I
         SET DRAW MODE EXPLICIT
         WAIT DELAY .1
      NEXT T
   NEXT ST
NEXT N
END

EXTERNAL  SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW  0 , XSIZE-1 , 0,YSIZE-1
SET POINT STYLE  1
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
 		 

回転アニメーション2

 投稿者：しばっち  投稿日：2012年 5月29日(火)20時42分18秒
  CALL GINIT(400,400)
LET X=200
LET Y=200
LET R=200
SET AREA COLOR 2
FOR N=5 TO 13 STEP 2
   LET THETA=360/N
   FOR ST=25 TO 360 STEP 20
      FOR K=0 TO 360*5 STEP ST
         LET KK=K*PI/180
         SET DRAW MODE HIDDEN
         CLEAR
         FOR TT=0 TO 360 STEP 360/N
            LET T=TT*PI/180
            LET TH=THETA/4*PI/180
            LET X1=X+R*COS(PI/2+T+KK)
            LET Y1=Y-R*SIN(PI/2+T+KK)
            LET L=TAN(TH)*R
            LET X2=X+L*COS(PI+T+KK)
            LET Y2=Y-L*SIN(PI+T+KK)
            LET X3=X+L*COS(T+KK)
            LET Y3=Y-L*SIN(T+KK)
            PLOT AREA:X1,Y1;X2,Y2;X3,Y3;X1,Y1
         NEXT TT
         SET DRAW MODE EXPLICIT
         WAIT DELAY .1
      NEXT K
   NEXT ST
NEXT N
END

EXTERNAL  SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW  0 , XSIZE-1 , YSIZE-1, 0
SET POINT STYLE  1
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB

 		 

(無題)

 投稿者：南澤  投稿日：2012年 5月30日(水)10時54分0秒
  ありがとうございました。
星形と言っても書き方は色々あるんですね…まだまだ分からないことだらけなので色々試してみます。
今日も質問したいのですが、円周率を出す公式は色々あると読んだのですが、大きい桁を出すにはどの方法が一番適しているのでしょうか？
幾つか教えていただきたいのですが、よろしくお願いします。 		 

Re: (無題)

 投稿者：山中和義  投稿日：2012年 5月30日(水)11時49分59秒
  > No.1896[元記事へ]

南澤さんへのお返事です。

> 円周率を出す公式は色々あると読んだのですが、大きい桁を出すにはどの方法が一番適しているのでしょうか？

リンク集にまとめたサイトがあります。プログラムも掲載されています。
　KK62526のホームページ 内
　　十進BASICによる円周率　http://www14.ocn.ne.jp/~kk62526/pi/index.html


個人的には、
・PCのベンチマーク（性能評価）に使われている
　マチンの公式 π/4=4*ArcTan(1/5)-ArcTan(1/239)
・収束が速い
　ガウス-ルジャンドル公式
でしょうか。
 		 

Re: (無題)

 投稿者：南澤  投稿日：2012年 5月30日(水)14時46分40秒
  > No.1897[元記事へ]

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

いつもありがとうございます。
円周率と言っても、ほんとに沢山あるんですね…
マチンの公式
ガウス-ルジャンドル公式
両方試してみたいと思います。
 		 

Re:星型n角形

 投稿者：山中和義  投稿日：2012年 5月31日(木)11時11分11秒
  > No.1892[元記事へ]

南澤さんへのお返事です。

> ベーシックで星形を書き、中に色を塗りたいのですが…

二等辺三角形をいくつか回転させて重なっていると考えると、

!星型n角形

SET WINDOW 0,400,0,400

LET N=5 !星型n角形　※5以上

LET CX=200 !中心
LET CY=200
LET R=200 !半径

DIM PX(0 TO N-1),PY(0 TO N-1) !正n角形の頂点
FOR i=0 TO N-1
   LET T=2*PI*i/N
   LET PX(i)=CX+SIN(T)*R !※X軸とY軸を入れ替える
   LET PY(i)=CY+COS(T)*R
NEXT i

FOR i=0 TO N-1 !二等辺三角形を回転させてn個描く
   LET K=MOD(i+2,N)
   SET AREA COLOR "RED" !塗り潰す色
   PLOT AREA: CX,CY; PX(i),PY(i); PX(K),PY(K)
NEXT i

END



特に、nが偶数の場合は、正(n/2)角形ですので、

!星型n角形　※nが偶数

SET WINDOW 0,400,0,400

LET N=6 !星型n角形　※6以上の偶数

LET CX=200 !中心
LET CY=200
LET R=200 !半径

DIM PX(0 TO N/2-1),PY(0 TO N/2-1) !正n/2角形の頂点
FOR i=1 TO 2 !正n/2角形を回転させて2個描く
   FOR K=0 TO N/2-1
      LET T=2*PI*(2*K-i)/N
      LET PX(K)=CX+SIN(T)*R !※X軸とY軸を入れ替える
      LET PY(K)=CY+COS(T)*R
   NEXT K

   SET AREA COLOR "RED" !塗り潰す色
   MAT PLOT AREA, LIMIT N: PX,PY
NEXT i

END

 		 

Re: (無題)

 投稿者：南澤  投稿日：2012年 5月31日(木)13時50分18秒
  > No.1897[元記事へ]

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

ガウス-ルジャンドル公式が上手く行きません。
1000まで出そうとすると、エラーが出てしまいます。
どうしてなのでしょうか…？
 		 

Re: 円周率

 投稿者：山中和義  投稿日：2012年 5月31日(木)15時04分59秒
  > No.1900[元記事へ]

南澤さんへのお返事です。

> ガウス-ルジャンドル公式が上手く行きません。


!ガウス-ルジャンドル公式

OPTION ARITHMETIC DECIMAL_HIGH !1000桁モード

LET a=1 !初期値
LET b=SQR(2)/2
LET t=1
LET x=4
FOR i=1 TO 9 !繰り返し回数
   LET y=a
   LET a=(a+b)/2 !算術平均（相加平均）と幾何平均（相乗平均）
   LET b=SQR(y*b)
   LET t=t-x*(y-a)^2
   LET x=2*x
NEXT i

PRINT (a+b)^2/t


PRINT PI !検算

END
 		 

重複円順列、重複じゅず順列

 投稿者：山中和義  投稿日：2012年 6月 6日(水)15時44分47秒
  碁石（表裏が区別されない）とオセロの石（表裏が区別される）を使ったとき、R個選ぶことを考察する。

まず、碁石を使った場合

a.回転（輪全体を時計まわりに回転させる）
　表  1       表  6
　　6   2  →   5   1
　　5   3       4   2
　    4           3
　※表、裏は「目」の位置とする。
　「対象物の手前から対象物を見る」が表なら、「向う側から見る」が裏になる。


　R個に対して、a^0, a^1, a^2, a^3, …, a^(R-1) は、円順列を表す作用となる。
　ただし、a^3=a(a(a))、すなわち「3回連続して行う」の意味とする。

4個を並べる場合
　1: ○○○○
　2: ○○○●（○○●○、○●○○、●○○○）
　3: ○○●●（○●●○、●●○○、●○○●）
　4: ○●○●（●○●○）
　5: ○●●●（●●●○、●●○●、●○●●）
　6: ●●●●


!参考サイト　http://oeis.org/A000031　2色の円順列

LET N=2 !n種類の石
LET R=4 !重複を許してr個選ぶ

LET B=N^R !一列に並べたときの「場合の数」　※N進法R桁

DIM F(0 TO B-1) !篩い
MAT F=(-1)*CON

LET C=0 !個数
FOR i=0 TO B-1 !小さい順に篩いにかける
   IF F(i)<0 THEN

      LET W=i !円順列　※並びを回転させる
      FOR K=0 TO R-1
      !表  1       表  5
      !　5   2  →   4   1
      !　 4 3         3 2
         LET T=MOD(W,B)+INT(W/B) !左ローテイト
         IF T<>i THEN LET F(T)=i !自分自身（=最小値）は残す

         LET W=W*N !次へ
      NEXT K

      LET C=C+1 !結果を表示する
      PRINT STR$(C);":"; i; "(";
      FOR K=i+1 TO B-1 !同一視するもの
         IF F(K)=i THEN PRINT K;
      NEXT K
      PRINT ")"

   END IF
NEXT i

END

実行結果

1: 0 ()
2: 1 ( 2  4  8 )
3: 3 ( 6  9  12 )
4: 5 ( 10 )
5: 7 ( 11  13  14 )
6: 15 ()


b.鏡映変換、反転（輪全体として反転させる）
　表  1       表  1
　　6   2  →   2   6
　　5   3       3   5
　    4           4

　R個に対して、a^0,a^1,a^2,a^3,…,a^(R-1) と b(a^0),b(a^1),b(a^2),b(a^3),…,b(a^(R-1)) は、
　じゅず順列を表す作用となる。


!参考サイト　http://oeis.org/A000029　2色の数珠順列

LET N=2 !n種類の石
LET R=4 !重複を許してr個選ぶ

LET B=N^R !一列に並べたときの「場合の数」　※N進法R桁

DIM F(0 TO B-1) !篩い
MAT F=(-1)*CON

LET C=0 !個数
FOR i=0 TO B-1 !小さい順に篩いにかける
   IF F(i)<0 THEN

      LET W=i !円順列　※並びを回転させる
      FOR K=0 TO R-1
      !表  1       表  5
      !　5   2  →   4   1
      !　 4 3         3 2
         LET T=MOD(W,B)+INT(W/B) !左ローテイト
         IF T<>i THEN LET F(T)=i !自分自身（=最小値）は残す


         !表  1       表  1
         !　5   2  →   2   5
         !　 4 3         3 4
         LET V=T !数珠順列　※鏡映変換（対称軸のひとつ、(12345)→(15432) ）
         LET T=0
         FOR J=1 TO R-1 !N進法R桁
            LET T=T*N+MOD(V,N)
            LET V=INT(V/N)
         NEXT J
         LET T=T+V*N^(R-1) !最上位（MSB）
         IF T<>i THEN LET F(T)=i

         LET W=W*N !次へ
      NEXT K

      LET C=C+1 !結果を表示する
      PRINT STR$(C);":"; i; "(";
      FOR K=i+1 TO B-1 !同一視するもの
         IF F(K)=i THEN PRINT K;
      NEXT K
      PRINT ")"

   END IF
NEXT i

END



次に、オセロの石を使った場合
反転（裏返す）ことで色が変わるので、上記に加えて次のことにも注意が必要である。

c.桁の反転（石の位置を固定して個々に反転させる）
　表  1       表  [1]
　　6   2  →  [6]   [2]
　　5   3      [5]   [3]
　    4           [4]

　例
　碁石のような表裏が区別されない（色が同じ）場合、
　　表  ●       表  ●
　　　○  ●  →   ○  ●
　　　●  ○       ●  ○
　　    ○           ○
　　恒等変換である。

　オセロのような表裏が区別される（色が異なる）場合、
　　表  ●       表  ○
　　　○  ●  →   ●  ○
　　　●  ○       ○  ●
　　    ○           ●

円順列

!参考サイト　http://oeis.org/A000013

LET N=2 !n種類の色を着けた（オセロの）石
LET R=4 !重複を許してr個選ぶ

LET M=2*COMB(N,2) !m種類の石
LET B=M^R !一列に並べたときの「場合の数」　※M進法R桁

DIM F(0 TO B-1) !篩い
MAT F=(-1)*CON

LET C=0 !個数
FOR i=0 TO B-1 !小さい順に篩いにかける
   IF F(i)<0 THEN

      LET W=i !円順列　※並びを回転させる
      FOR K=0 TO R-1
         LET T=MOD(W,B)+INT(W/B) !左ローテイト
         IF T<>i THEN LET F(T)=i !自分自身（=最小値）は残す

         !表  1       表  (1)
         !　5   2  →  (5)   (2)
         !　 4 3        (4) (3)
         LET V=(B-1)-T !桁の反転　※2進法なら、ビットごとの反転（否定演算、1の補数）
         IF V<>i THEN LET F(V)=i

         LET W=W*M !次へ
      NEXT K

      LET C=C+1 !結果を表示する
      PRINT STR$(C);":"; i; "(";
      FOR K=i+1 TO B-1 !同一視するもの
         IF F(K)=i THEN PRINT K;
      NEXT K
      PRINT ")"

   END IF
NEXT i

END


じゅず順列

!参考サイト　http://oeis.org/A000011

LET N=2 !n種類の色を着けた（オセロの）石
LET R=4 !重複を許してr個選ぶ

LET M=2*COMB(N,2) !m種類の石
LET B=M^R !一列に並べたときの「場合の数」　※M進法R桁

DIM F(0 TO B-1) !篩い
MAT F=(-1)*CON

LET C=0 !個数
FOR i=0 TO B-1 !小さい順に篩いにかける
   IF F(i)<0 THEN

      LET W=i !円順列　※並びを回転させる
      FOR K=0 TO R-1
         LET T=MOD(W,B)+INT(W/B) !左ローテイト
         IF T<>i THEN LET F(T)=i !自分自身（=最小値）は残す

         LET V=(B-1)-T !桁の反転　※ビットごとの反転（否定演算、1の補数）
         IF V<>i THEN LET F(V)=i


         LET V=T !数珠順列　※鏡映変換（対称軸のひとつ、(12345)→(15432) ）
         LET T=0
         FOR J=1 TO R-1 !M進法R桁
            LET T=T*M+MOD(V,M)
            LET V=INT(V/M)
         NEXT J
         LET T=T+V*M^(R-1) !最上位（MSB）
         IF T<>i THEN LET F(T)=i

         LET V=(B-1)-T !桁の反転　※ビットごとの反転（否定演算、1の補数）
         IF V<>i THEN LET F(V)=i

         LET W=W*M !次へ
      NEXT K

      LET C=C+1 !結果を表示する
      PRINT STR$(C);":"; i; "(";
      FOR K=i+1 TO B-1 !同一視するもの
         IF F(K)=i THEN PRINT K;
      NEXT K
      PRINT ")"

   END IF
NEXT i

END



d.下から見る
　表  1       裏  [1]
　　6   2  →  [2]   [6]
　　5   3      [3]   [5]
　    4           [4]
　例
　碁石のような表裏が区別されない（色が同じ）場合、
　　表  ●       裏  ●
　　　○  ●  →   ●  ○
　　　●  ○       ○  ●
　　    ○           ○
　　鏡映変換である。

　オセロのような表裏が区別される（色が異なる）場合、
　　表  ●       裏  ○
　　　○  ●  →   ○  ●
　　　●  ○       ●  ○
　　    ○           ●
　　並びの順序（石の位置）は、鏡映変換である。
　　b(c)またはc(b)で可能である。

円順列

!参考サイト　http://oeis.org/A053656

LET N=2 !n種類の色を着けた（オセロの）石
LET R=4 !重複を許してr個選ぶ

LET M=2*COMB(N,2) !m種類の石
LET B=M^R !一列に並べたときの「場合の数」　※M進法R桁

DIM F(0 TO B-1) !篩い
MAT F=(-1)*CON

LET C=0 !個数
FOR i=0 TO B-1 !小さい順に篩いにかける
   IF F(i)<0 THEN

      LET W=i !円順列　※並びを回転させる
      FOR K=0 TO R-1
         LET T=MOD(W,B)+INT(W/B) !左ローテイト
         IF T<>i THEN LET F(T)=i !自分自身（=最小値）は残す


         !表  1       裏  [1]
         !　5   2  →  [2]   [5]
         !　 4 3        [3] [4]
         LET V=T !下から見る、輪全体として反転する　(12345)→([1][5][4][3][2])
         LET T=0
         FOR J=1 TO R-1 !M進法(R-1)桁
            LET T=T*M+( (M-1)-MOD(V,M) ) !※桁の反転
            LET V=INT(V/M)
         NEXT J
         LET T=T+( (M-1)-V )*M^(R-1) !最上位(MSB)　※桁の反転
         IF T<>i THEN LET F(T)=i

         LET W=W*M !次へ
      NEXT K

      LET C=C+1 !結果を表示する
      PRINT STR$(C);":"; i; "(";
      FOR K=i+1 TO B-1 !同一視するもの
         IF F(K)=i THEN PRINT K;
      NEXT K
      PRINT ")"

   END IF
NEXT i

END

 		 

(無題)

 投稿者：南澤  投稿日：2012年 6月 7日(木)11時37分43秒
  自分でもまだ問題の意味から模索している状態なのですが…
三角関数のプログラミングで質問なのですが、
与えられたd∈[-1,1]に大してsin^-1d(=arcsin d)を計算するプログラムで、
sin^-1(1/2)を計算する…と言うのは、どう言った意味なのでしょうか？
 		 

Re: (無題)

 投稿者：山中和義  投稿日：2012年 6月 7日(木)12時41分15秒
  > No.1903[元記事へ]

南澤さんへのお返事です。

> sin^-1(1/2)を計算する…と言うのは、どう言った意味なのでしょうか？

sinθ=1/2となるθを求めるということです。（逆三角関数）


ちなみに、これを使って円周率を求めると、

ArcSin(x)のマクローリン展開にx=1/2を代入する方法
　sin30°=sinπ/6=1/2なので、π/6=ArcSin(1/2)となる。
　右辺をマクローリン展開して、π=6 Σ[n=0,∞](2n)!/(2^(4n+1)(n!)^2(2n+1))


OPTION ARITHMETIC DECIMAL_HIGH !1000桁

LET A=0.5
LET S=0
LET N=0
DO WHILE A>=1E-1000 !誤差が十分小さいなら、終了する
   LET S=S+A !n項目を加算する

   LET N=N+1 !次へ
   LET A=A*(2*N-1)*(2*N-1)
   LET A=A/(8*N*(2*N+1))
LOOP

PRINT N; S*6

END
 		 

Re: (無題)

 投稿者：南澤  投稿日：2012年 6月 8日(金)13時53分54秒
  > No.1904[元記事へ]

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

ありがとうございます。
sinθ=1/2となるθを求めるということです。（逆三角関数）
……此れを、逆三角関数を用いずに計算したいのですが、
此の場合はどうしたらいいのでしょうか？
 		 

Re: (無題)

 投稿者：山中和義  投稿日：2012年 6月 8日(金)14時34分26秒
  > No.1905[元記事へ]

南澤さんへのお返事です。

> sinθ=1/2となるθを求めるということです。（逆三角関数）
> ……此れを、逆三角関数を用いずに計算したいのですが、
> 此の場合はどうしたらいいのでしょうか？

!ArcSin(x)のテイラー展開

! ArcSin(x)
!=Σ[n=0,∞](2n)!/{(n!)^2(4^n)(2n+1)}x^(2n+1)
!=Σ[n=0,∞]{(-1)^nC(-1/2,n)/(2n+1)}x^(2n+1)

FOR x=-1 TO 1 STEP 0.1

   LET S=0
   FOR n=0 TO 200
      LET S=S+(-1)^n*COMB(-1/2,n)*x^(2*n+1)/(2*n+1)
   NEXT n

   PRINT STR$(x);": "; S; ASIN(x)

NEXT x

END
 		 

(無題)

 投稿者：奈央  投稿日：2012年 6月 8日(金)15時57分8秒
  質問なんですが、x^2-a=0のaをだす方法が知りたいです。1000桁で出したいんですがどうしたらいいですか？  

Re: (無題)

 投稿者：山中和義  投稿日：2012年 6月 8日(金)18時45分28秒
  > No.1907[元記事へ]

奈央さんへのお返事です。

> 質問なんですが、x^2-a=0のaをだす方法が知りたいです。1000桁で出したいんですがどうしたらいいですか？

サンプルプログラム（Mathフォルダ内NEWTON.BAS）を1000桁モードで実行してください。
 		 

Re: (無題)

 投稿者：奈央  投稿日：2012年 6月 8日(金)19時21分56秒
  > No.1908[元記事へ]

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

ありがとうございます！
サンプルプログラム（Mathフォルダ内NEWTON.BAS）ってパソコンに入ってるんですか？ 		 

Re: (無題)

 投稿者：山中和義  投稿日：2012年 6月 8日(金)19時39分52秒
  > No.1909[元記事へ]

奈央さんへのお返事です。

> サンプルプログラム（Mathフォルダ内NEWTON.BAS）ってパソコンに入ってるんですか？

十進BASICをインストールすると、通常、CドライブのBASICw32フォルダに入ります。
その中にMathフォルダもあります。

見つからなかった場合のために、、、

! ニュートン法によって平方根を求める。
DEF f(x)=x^2-a
DEF g(x)=2*x    ! g(x)=f'(x)
INPUT a
LET x=a
LET E=EPS(1)*10
DO
   LET x1=x-f(x)/g(x)
   PRINT x1
   IF ABS((x1-x)/x)<E THEN EXIT DO
   LET x=x1
LOOP
END
 		 

Re: (無題)

 投稿者：しばっち  投稿日：2012年 6月10日(日)17時45分31秒
  南澤さんへのお返事です。

> ……此れを、逆三角関数を用いずに計算したいのですが、
> 此の場合はどうしたらいいのでしょうか？

f(x)=sin(x)-t としてニュートン法などで求めることができます。
下記ではbailey法(halley法)を用いています。ニュートン法よりも速く、3次収束します。

http://www.geocities.jp/java_sample_program/BaileyHou.pdf
http://poset.jp/orfm/node3.html

PUBLIC NUMERIC T
INPUT  PROMPT "ASIN(X) 0<X<1 X=":T
LET XX=T
DO
   LET X=XX
   LET XX=X-F(X)/(DIFF1(X)-.5*DIFF2(X)*F(X)/DIFF1(X))
LOOP UNTIL X=XX
PRINT X,ASIN(T)
END

EXTERNAL  FUNCTION F(X)
LET F=SIN(X)-T
END FUNCTION

EXTERNAL  FUNCTION DIFF1(X)
LET DIFF1=COS(X)
END FUNCTION

EXTERNAL  FUNCTION DIFF2(X)
LET DIFF2=-SIN(X)
END FUNCTION


また∫1/√(1-x*x)dx=Arcsin(x)より数値積分でも求められます。

INPUT  PROMPT "ASIN(X) 0<X<1 X=":X
PRINT INTEGRAL4(0,X,100),ASIN(X)
END

EXTERNAL  FUNCTION INTEGRAL4(A,B,N)
LET N=N*3
LET H=(B-A)/N
FOR K=0 TO N/3-1
   LET S=S+3/8*H*F(A+H*3*K)+9/8*H*F(A+H*(3*K+1))+9/8*H*F(A+H*(3*K+2))+3/8*H*F(A+H*(3*K+3))
NEXT K
LET INTEGRAL4=S
END FUNCTION

EXTERNAL  FUNCTION F(X)
LET F=1/SQR(1-X*X)
END FUNCTION

更に下記の方法でも求めることができます。

INPUT  PROMPT "ASIN(X) 0<X<1 X=":X
LET  S = X
LET  C = SQR(1 - S * S)
DO WHILE ABS(1 - C) > 1E-10
   LET  C = SQR((1 + C) / 2)
   LET  S = S / C
LOOP
PRINT S, ATN(X / SQR(1 - X * X))
END
 		 

日常に潜む問題

 投稿者：SECOND  投稿日：2012年 6月13日(水)00時46分40秒
  !日常に潜む問題。

!加法・減法混色の、色見本を作るとき、
!半径１の原色円３個、互いの距離を、２重部分が最大面積になるようにしたい。
!
SET WINDOW 0,6,0,3
!
FOR mr=0 TO 2 STEP .01                   !半径１の円３個、中心間距離は、mr
   LET w=calc(mr)
   PRINT USING "mr=#.## ２重部面積=#.##### ３重部面積=#.#####": mr,w,s33
   IF bak< w THEN
      LET bak=w
      LET bak3=s33
      LET peak=mr
   END IF
   CALL disp3
   DO
      WAIT DELAY 0
      mouse poll mx,my,mlb,mrb
      IF mrb=1 THEN STOP
      IF s33<=1e-4 THEN EXIT FOR
   LOOP UNTIL mlb=0
NEXT mr
PRINT "３重部 消失 停止。"
PRINT "２重部 最大値"
LET mr=peak
PRINT USING "mr=#.## ２重部面積=#.##### ３重部面積=#.#####": mr,bak,bak3
CALL disp3

FUNCTION calc(mr)
   LET s1= PI                   !円１個、面積
   LET a2= ACOS(mr/2)           !円２個、重なる範囲の扇形、頂角の半角
   LET s2= a2/PI*s1             !円２個、重なる範囲の扇形、面積
   LET s22= 2*s2-mr*SIN(a2)     !円２個、２重範囲の面積
   LET s3= (a2+PI/6)/PI*s1               !円３個、重なる範囲の扇形、１個の面積
   LET s6= mr^2*SQR(3)/4+3*mr*SIN(a2)/2  !円中心３個と外側交点３個での６角形面積
   LET s33=3*s22-(3*s3-s6)               !円３個、３重範囲の面積
   LET calc=3*(s22-s33)         !円３個、２重範囲３個の面積
END FUNCTION

SUB disp3
   SET DRAW mode hidden
   !-----加法混色
   SET VIEWPORT 0,1,0/2,1/2              !下側半分
   CALL BG_color(1)                      !黒地
   !---
   SET DRAW MODE MERGE                   !加法混色
   CALL ctest
   !-----減法混色
   SET VIEWPORT 0,1,1/2,2/2              !上側半分
   CALL BG_color(0)                      !白地
   !---
   SET DRAW MODE MASK                    !減法混色
   CALL ctest
   SET DRAW mode explicit
END SUB

SUB BG_color(c)
   SET DRAW MODE OVERWRITE
   SET AREA COLOR c
   PLOT AREA:0,0; 6,0; 6,3; 0,3
END SUB

SUB ctest
   SET AREA COLOR 2                          !blue    B
   DRAW disk WITH SHIFT(1,1)
   SET AREA COLOR 3                          !green   G
   DRAW disk WITH SHIFT(1+mr,1)
   SET AREA COLOR 4                          !red     R
   DRAW disk WITH SHIFT(1+mr/2,1+mr*SQR(3)/2)
   !---
   SET AREA COLOR 5                          !cyan    W-R
   DRAW disk WITH SHIFT(4,1)
   SET AREA COLOR 6                          !yellow  W-B
   DRAW disk WITH SHIFT(4+mr,1)
   SET AREA COLOR 7                          !magenta W-G
   DRAW disk WITH SHIFT(4+mr/2,1+mr*SQR(3)/2)
END SUB

END
 

「shutdown」コマンド増設を

 投稿者：しばっち  投稿日：2012年 6月23日(土)20時01分30秒
  白石先生にぜひお願いがあるのですが、計算終了までに少々時間(数時間程度)のかかるプログラム(探索プログラムや多倍長計算など)がございまして、
そういった場合に就寝中、又は外出中などに実行しておき、実行終了後(ファイルなどに計算結果を書き出した後に)OSを「安全」にシャットダウンできれば大変都合がよくなるのですが、
ぜひ「shutdown」コマンド(又はオプションメニューなどによる)みたいな機能の増設はできないでしょうか。
(batファイルにそういったフリーソフトなどと組み合わせれば現行でもできるのですが...)

それに加えて、テキスト出力ウインドに対する「GSAVE」のようなコマンド(又はオプションメニューで自動保存など)も設けて欲しいと思っているのですが、いかがでしょうか。
(ファイルメニューから手動で保存できるのですが、プログラム上からそれを行いたい為。basソースファイルをファイルに書き出しするように書き換えれば済むことではあるのですが...)

JIS規格については全然分かりません。まこと勝手なお願いですが、よろしくお願いします。

P.S.
また、特定キー入力によるキー割り込み命令(「ON KEY GOSUB」みたいな割り込み処理)があれば
(多重ループ中に(経過出力(デバッグ中を除く)のための)PRINT文を置きたくないなどの理由による)
キー割り込みで計算途中までの確認や出力(又は計算処理の打ち切り、その計算過程までの結果出力など)できるなど利便性が上がり、
こちらとして使い勝手がよくなるのですが(以上規格との兼合いなどもあり難しいとは思いますが)ご検討お願いします。

(もちろん無理なら仕方ないのですが...)
 		 

Re: 「shutdown」コマンド増設を

 投稿者：白石和夫  投稿日：2012年 6月24日(日)18時06分50秒
  > No.1913[元記事へ]

いずれも技術的にはおそらく実現可能な提案だと思います。
いずれも，将来的には検討課題になります。
ただし，On KEY GOSUBは，Full BASIC規格と矛盾しない形で実現するかどうかの検討が必要です。
（少なくとも，ON KEY GOSUB と書くのは無理。KEYは変数名と解釈しなければ規格無視になってしまう）

Windows版のテキスト出力はWindowsのRicheditコントロールなので，Win32APIを利用すればその内容をファイルに落とすことは現状でも可能な気がします。


 		 

未完成数

 投稿者：永野護  投稿日：2012年 6月26日(火)15時55分45秒
  以下はプライム　ナンバーズ（DAVID　　WELLS著）という本からの抜粋です。
------------------------------------------------------------------------
10進数の各桁の和をm回繰り返してとることを考えます。
このとき最終結果に絶対に現れない数mがあります。
ジョン.コンウェイはこのような数mを未完成数と呼びました。
10進数の未完成数の例は次のとおりです。

62,63,65,75,84,95,161,173,195,216,261,.............
---------------------------------------------------------------
これらの数はどのようにして求めるのでしょうか。
お忙しい中、まことに恐縮ですがどなたかお願いできないでしょうか。
 		 

Re: 未完成数

 投稿者：山中和義  投稿日：2012年 6月28日(木)20時37分41秒
  > No.1915[元記事へ]

永野護さんへのお返事です。

> 以下はプライム　ナンバーズ（DAVID　　WELLS著）という本からの抜粋です。
> ------------------------------------------------------------------------
> 10進数の各桁の和をm回繰り返してとることを考えます。
> このとき最終結果に絶対に現れない数mがあります。
> ジョン.コンウェイはこのような数mを未完成数と呼びました。
> 10進数の未完成数の例は次のとおりです。
>
> 62,63,65,75,84,95,161,173,195,216,261,.............
> ---------------------------------------------------------------
> これらの数はどのようにして求めるのでしょうか。

定義があいまいなような？



!未完成数（Inconsummate numbers）

!参考サイト　http://oeis.org/A003635

LET P=10 !p進法
LET M=250 !250n　※MATHEMATICA

FOR n=1 TO 1000 !1～1000
   LET k=n

   !!PRINT " n  k  s   s*n" !debug
   DO WHILE IntegerDigits(k,p)*n<>k AND k<M*n
   !!PRINT n;k; " ";STR$(IntegerDigits(k,p));"*";STR$(n);"="; IntegerDigits(k,p)*n !debug
      LET k=k+n
   LOOP
   !!PRINT n;k; " ";STR$(IntegerDigits(k,p));"*";STR$(n);"="; IntegerDigits(k,p)*n !debug
   IF k=M*n THEN PRINT n

NEXT n

END

EXTERNAL FUNCTION IntegerDigits(k,p) !p進法表記での各桁の和
LET t=k
LET s=0 !各桁の和
DO WHILE t>0 !p進法変換
   LET s=s+MOD(t,P)
   LET t=INT(t/P) !次の桁へ
LOOP
LET IntegerDigits=s
END FUNCTION

 		 

未完成数

 投稿者：永野護  投稿日：2012年 6月29日(金)10時30分5秒
  お忙しい中、回答ありがとうございました。
いつもこのサイトではお世話になっています。
これから夏本番を迎えます。皆様方のご健康
をお祈りいたします。
敬具 		 

n乗根の計算

 投稿者：しばっち  投稿日：2012年 7月 7日(土)21時37分18秒
  OPTION ARITHMETIC NATIVE !'二進モード
PUBLIC NUMERIC BIAS, KETA, SIGN, EPS
LET  EPS = 16 !'打ち切りによる収束誤差分(末尾 EPS*4桁分)
LET  NN=2^15-EPS !' (※ NN=2^18-EPSで100万桁オーバー)
LET  BIAS = 2 !'10000^(BIAS+1)まで
LET  KETA =-BIAS+NN+EPS !'10000^(-KETA) (KETA*4桁)
LET  SIGN = -BIAS - 1 !'多倍長数の符号
DIM Y(-BIAS-1 TO KETA),X(-BIAS-1 TO KETA)
INPUT  PROMPT "K^(1/N) K=":K
DO
   INPUT  PROMPT "K^(1/N) N=":N
   LET N=INT(ABS(N))
LOOP UNTIL N>=2
CALL LLET(Y,STR$(K))
CALL LLET(X,USING$("#.################",K^(-(N-1)/N))) !'ニュートン法の初期値
PRINT (KETA-EPS)*4;"桁の計算開始 ";TIME$
LET T=TIME
CALL LROOT(Y,N,X)
PRINT "計算終了 ";TIME$;TIME-T;"秒"
PRINT "ファイルへ書き出し中"
CALL DISPLAY(Y,"OUT.txt") !'ファイルへ書き出し
END

EXTERNAL  SUB LROOT(T(),N,X()) !'ニュートン法
OPTION ARITHMETIC NATIVE
DIM TT(-BIAS-1 TO KETA),XX(-BIAS-1 TO KETA),Y(-BIAS-1 TO KETA)
CALL LCOPY(TT,T)
FOR I=1 TO N-2
   CALL LMUL2(TT,T)
NEXT I
DO
   CALL LCOPY(Y,X)
   CALL LCOPY(XX,X)
   CALL SMUL(XX,N+1)
   FOR I=1 TO N
      CALL LMUL2(X,Y)
   NEXT I
   CALL LMUL2(X,TT)
   CALL LSUB2(XX,X)
   CALL SDIV(XX,N)
   CALL LCOPY(X,XX)
LOOP UNTIL EQUAL(Y,X)<>0
CALL LMUL2(T,X)
END SUB

EXTERNAL  SUB DISPLAY(X(),N$)
OPTION ARITHMETIC NATIVE
IF N$="" THEN
   OPEN #1: TEXTWINDOW1
ELSE
   OPEN #1:NAME N$
END IF
ERASE #1
FOR K=-BIAS TO 0
   IF X(K)<>0 THEN EXIT FOR
NEXT K
IF X(SIGN) = -1 THEN PRINT #1:"- ";
IF K>=0 THEN
   LET K=0
   PRINT #1:STR$(X(0));"."
ELSE
   PRINT #1:STR$(X(K));
   FOR I=K+1 TO 0
      LET A$=A$ & RIGHT$("000" & STR$(X(I)),4)
      IF LEN(A$)=100 THEN
         PRINT #1:A$
         LET A$=""
      END IF
   NEXT I
   IF LEN(A$)>0 THEN
      PRINT #1: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 #1:LEFT$(A$,10);" ";
         IF J=5 THEN PRINT #1:"   ";
         LET A$=RIGHT$(A$,LEN(A$)-10)
      NEXT J
      PRINT #1:":";S
      LET A$=""
      IF MOD(S,1000)=0 THEN PRINT #1
   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 #1:RTRIM$(LEFT$(A$,10));" ";
      IF J=5 THEN PRINT #1:"   ";
      LET A$=RIGHT$(A$,LEN(A$)-10)
      IF RTRIM$(A$)="" THEN EXIT FOR
   NEXT J
   !'  PRINT #1:":";S
END IF
CLOSE #1
END SUB

EXTERNAL  FUNCTION EQUAL(A(), B())
OPTION ARITHMETIC NATIVE
FOR I=-BIAS-1 TO KETA-EPS
   IF A(I)<>B(I) THEN
      FOR J=0 TO 3
         IF INT(A(I)/10^(3-J))<>INT(B(I)/10^(3-J)) THEN EXIT FOR
      NEXT  J
      PRINT (I-1)*4+J;"桁まで計算終了 ";TIME$
      LET  EQUAL = 0
      EXIT FUNCTION
   END IF
NEXT I
PRINT (I-1)*4;"桁まで計算終了 ";TIME$
LET EQUAL=-1
END FUNCTION

EXTERNAL  FUNCTION GREAT(A(), B())
OPTION ARITHMETIC NATIVE
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
LET  GREAT = 0
END FUNCTION

EXTERNAL  SUB LCLR(A())
OPTION ARITHMETIC NATIVE
MAT A=ZER
LET  A(SIGN) = 1
END SUB

EXTERNAL  SUB LCOPY(A(), B())
OPTION ARITHMETIC NATIVE
MAT A=B
END SUB

EXTERNAL  SUB LLET(A(), X$)
OPTION ARITHMETIC NATIVE
CALL LCLR(A)
LET  X$ = LTRIM$(RTRIM$(X$))
FOR I = 1 TO LEN(X$)
   IF POS("0123456789.-", MID$(X$, I, 1)) = 0 THEN
      PRINT "ERROR in LLET"
      STOP
   END IF
NEXT I
IF LEFT$(X$, 1) = "-" THEN
   LET  A(SIGN) = -1
   LET X$ = RIGHT$(X$, LEN(X$)-1)
ELSE
   LET  A(SIGN) = 1
END IF
LET  K1 = POS(X$, ".")
LET  X$ = "000" & X$
IF K1 = 0 THEN LET  X$ = X$ & "."
LET  KK = POS(X$, ".")
IF KK - 4 > BIAS * 4 + 4 THEN
   PRINT "OVER FLOW in LLET"
   STOP
END IF
FOR J = 0 TO INT((KK - 1) / 4) - 1
   LET  A(-J) = VAL(MID$(X$, KK - 4 * J - 4, 4))
NEXT J
LET  X$ = X$ & "000"
FOR J = 1 TO(LEN(X$) - KK) / 4
   LET  A(J) = VAL(MID$(X$, KK + 4 * J - 3, 4))
NEXT J
END SUB

EXTERNAL  SUB SDIV(A(), XA)
OPTION ARITHMETIC NATIVE
LET  SIGNA = A(SIGN)
LET  SG = SGN(XA)
LET  XA = ABS(XA)
FOR I = -BIAS TO KETA - 1
   LET  R = A(I) - INT(A(I) / XA) * XA
   LET  A(I) = INT(A(I) / XA)
   LET  A(I + 1) = A(I + 1) + R * 10000
NEXT I
LET  A(KETA) = INT(A(KETA) / XA)
LET A(SIGN)=SIGNA * SG
END SUB

EXTERNAL  SUB SMUL(A(), XA)
OPTION ARITHMETIC NATIVE
LET  SIGNA = A(SIGN)
LET  SG = SGN(XA)
LET  XA = ABS(XA)
MAT A = XA * A
FOR I = KETA TO -BIAS + 1 STEP -1
   IF A(I) >= 10000 THEN
      LET  R = INT(A(I) / 10000)
      LET  A(I) = MOD(A(I),10000)
      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

EXTERNAL  SUB LADD2(A(), B())
OPTION ARITHMETIC NATIVE
DIM C(-BIAS - 1 TO KETA)
CALL LADD(A,B,C)
CALL LCOPY(A,C)
END SUB

EXTERNAL  SUB LSUB2(A(), B())
OPTION ARITHMETIC NATIVE
DIM C(-BIAS - 1 TO KETA)
CALL LSUB(A,B,C)
CALL LCOPY(A,C)
END SUB

EXTERNAL  SUB LADD(A(), B(), C())
OPTION ARITHMETIC NATIVE
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 LSUB(A(), B(), C())
OPTION ARITHMETIC NATIVE
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 LMUL(A(),B(),C())
OPTION ARITHMETIC NATIVE
LET N=(KETA+BIAS)*2
IF INT(LOG2(N))<>LOG2(N) THEN
   PRINT "ERROR in LMUL"
   STOP
END IF
OPTION BASE 0
DIM AA(2*N),BB(2*N),CC(2*N),IP(2+2^(INT(LOG(N+0.5)/LOG(2))/2)),W(N/2-1)
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, 1, AA, IP, W)
CALL CDFT(2*N, 1, BB, IP, W)
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, -1,CC, IP, W)
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
   ELSE
      DO WHILE C(I)<0
         LET C(I)=C(I)+10000
         LET C(I-1)=C(I-1)-1
      LOOP
   END IF
NEXT I
LET C(SIGN)=A(SIGN)*B(SIGN)
END SUB

EXTERNAL  SUB LMUL2(A(),B())
OPTION ARITHMETIC NATIVE
DIM C(-BIAS - 1 TO KETA)
CALL LMUL(A,B,C)
CALL LCOPY(A,C)
END SUB

! これより以下のFFTルーチンは下記サイトより入手したものを移植した
! http://www.kurims.kyoto-u.ac.jp/~ooura/index-j.html
!
! -------- Complex DFT (Discrete Fourier Transform) --------
!     [definition]
!         <case1>
!             X(k) = sum_j=0^n-1 x(j)*exp(2*pi*i*j*k/n), 0<=k<n
!         <case2>
!             X(k) = sum_j=0^n-1 x(j)*exp(-2*pi*i*j*k/n), 0<=k<n
!         (notes: sum_j=0^n-1 is a summation from j=0 to n-1)
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call cdft(2*n, 1, a, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call cdft(2*n, -1, a, ip, w)
!     [parameters]
!         2*n          :data length (integer)
!                       n >= 1, n = power of 2
!         a(0:2*n-1)   :input/output data (real*8)
!                       input data
!                           a(2*j) = Re(x(j)),
!                           a(2*j+1) = Im(x(j)), 0<=j<n
!                       output data
!                           a(2*k) = Re(X(k)),
!                           a(2*k+1) = Im(X(k)), 0<=k<n
!         ip(0:*)      :work area for bit reversal (integer)
!                       length of ip >= 2+sqrt(n)
!                       strictly,
!                       length of ip >=
!                           2+2**(int(log(n+0.5)/log(2.0))/2).
!                       ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:n/2-1)   :cos/sin table (real*8)
!                       w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call cdft(2*n, -1, a, ip, w)
!         is
!             call cdft(2*n, 1, a, ip, w)
!             do j = 0, 2 * n - 1
!                 a(j) = a(j) / n
!             end do

EXTERNAL  SUB CDFT(N, ISGN, A(), IP(), W())
OPTION ARITHMETIC NATIVE
IF N > 4 * IP(0) THEN
   CALL MAKEWT(N / 4, IP, W)
END IF
IF N > 4 THEN
   IF ISGN >= 0 THEN
      CALL BITRV2(N, IP, A)
      CALL CFTFSUB(N, A, W)
   ELSE
      CALL BITRV2CONJ(N, IP, A)
      CALL CFTBSUB(N, A, W)
   END IF
ELSEIF N = 4 THEN
   CALL CFTFSUB(N, A, W)
END IF
END SUB

EXTERNAL  SUB MAKEWT(NW, IP(), W())
OPTION ARITHMETIC NATIVE
LET  IP(0) = NW
LET  IP(1) = 1
IF NW > 2 THEN
   LET  NWH = NW / 2
   LET  DELTA = ATN(1.0) / NWH
   LET  W(0) = 1
   LET  W(1) = 0
   LET  W(NWH) = COS(DELTA * NWH)
   LET  W(NWH + 1) = W(NWH)
   IF NWH > 2 THEN
      FOR J = 2 TO NWH - 2 STEP 2
         LET  X = COS(DELTA * J)
         LET  Y = SIN(DELTA * J)
         LET  W(J) = X
         LET  W(J + 1) = Y
         LET  W(NW - J) = Y
         LET  W(NW - J + 1) = X
      NEXT J
      CALL BITRV2(NW, IP, W)
   END IF
END IF
END SUB

EXTERNAL  SUB CFTFSUB(N, A(), W())
OPTION ARITHMETIC NATIVE
LET  L = 2
IF N > 8 THEN
   CALL CFT1ST(N, A, W)
   LET  L = 8
   DO WHILE 4 * L < N
      CALL CFTMDL(N, L, A, W)
      LET  L = 4 * L
   LOOP
END IF
IF 4 * L = N THEN
   FOR J = 0 TO L - 2 STEP 2
      LET  J1 = J + L
      LET  J2 = J1 + L
      LET  J3 = J2 + L
      LET  X0R = A(J) + A(J1)
      LET  X0I = A(J + 1) + A(J1 + 1)
      LET  X1R = A(J) - A(J1)
      LET  X1I = A(J + 1) - A(J1 + 1)
      LET  X2R = A(J2) + A(J3)
      LET  X2I = A(J2 + 1) + A(J3 + 1)
      LET  X3R = A(J2) - A(J3)
      LET  X3I = A(J2 + 1) - A(J3 + 1)
      LET  A(J) = X0R + X2R
      LET  A(J + 1) = X0I + X2I
      LET  A(J2) = X0R - X2R
      LET  A(J2 + 1) = X0I - X2I
      LET  A(J1) = X1R - X3I
      LET  A(J1 + 1) = X1I + X3R
      LET  A(J3) = X1R + X3I
      LET  A(J3 + 1) = X1I - X3R
   NEXT J
ELSE
   FOR J = 0 TO L - 2 STEP 2
      LET  J1 = J + L
      LET  X0R = A(J) - A(J1)
      LET  X0I = A(J + 1) - A(J1 + 1)
      LET  A(J) = A(J) + A(J1)
      LET  A(J + 1) = A(J + 1) + A(J1 + 1)
      LET  A(J1) = X0R
      LET  A(J1 + 1) = X0I
   NEXT J
END IF
END SUB
 		 

Re: n乗根の計算

 投稿者：しばっち  投稿日：2012年 7月 7日(土)21時38分6秒
  > No.1918[元記事へ]

続き

EXTERNAL  SUB BITRV2(N, IP(), A())
OPTION ARITHMETIC NATIVE
LET  IP(0) = 0
LET  L = N
LET  M = 1
DO WHILE 8 * M < L
   LET  L = L / 2
   FOR J = 0 TO M - 1
      LET  IP(M + J) = IP(J) + L
   NEXT J
   LET  M = M * 2
LOOP
LET  M2 = 2 * M
IF 8 * M = L THEN
   FOR K = 0 TO M - 1
      FOR J = 0 TO K - 1
         LET  J1 = 2 * J + IP(K)
         LET  K1 = 2 * K + IP(J)
         LET  XR = A(J1)
         LET  XI = A(J1 + 1)
         LET  YR = A(K1)
         LET  YI = A(K1 + 1)
         LET  A(J1) = YR
         LET  A(J1 + 1) = YI
         LET  A(K1) = XR
         LET  A(K1 + 1) = XI
         LET  J1 = J1 + M2
         LET  K1 = K1 + 2 * M2
         LET  XR = A(J1)
         LET  XI = A(J1 + 1)
         LET  YR = A(K1)
         LET  YI = A(K1 + 1)
         LET  A(J1) = YR
         LET  A(J1 + 1) = YI
         LET  A(K1) = XR
         LET  A(K1 + 1) = XI
         LET  J1 = J1 + M2
         LET  K1 = K1 - M2
         LET  XR = A(J1)
         LET  XI = A(J1 + 1)
         LET  YR = A(K1)
         LET  YI = A(K1 + 1)
         LET  A(J1) = YR
         LET  A(J1 + 1) = YI
         LET  A(K1) = XR
         LET  A(K1 + 1) = XI
         LET  J1 = J1 + M2
         LET  K1 = K1 + 2 * M2
         LET  XR = A(J1)
         LET  XI = A(J1 + 1)
         LET  YR = A(K1)
         LET  YI = A(K1 + 1)
         LET  A(J1) = YR
         LET  A(J1 + 1) = YI
         LET  A(K1) = XR
         LET  A(K1 + 1) = XI
      NEXT J
      LET  J1 = 2 * K + M2 + IP(K)
      LET  K1 = J1 + M2
      LET  XR = A(J1)
      LET  XI = A(J1 + 1)
      LET  YR = A(K1)
      LET  YI = A(K1 + 1)
      LET  A(J1) = YR
      LET  A(J1 + 1) = YI
      LET  A(K1) = XR
      LET  A(K1 + 1) = XI
   NEXT K
ELSE
   FOR K = 1 TO M - 1
      FOR J = 0 TO K - 1
         LET  J1 = 2 * J + IP(K)
         LET  K1 = 2 * K + IP(J)
         LET  XR = A(J1)
         LET  XI = A(J1 + 1)
         LET  YR = A(K1)
         LET  YI = A(K1 + 1)
         LET  A(J1) = YR
         LET  A(J1 + 1) = YI
         LET  A(K1) = XR
         LET  A(K1 + 1) = XI
         LET  J1 = J1 + M2
         LET  K1 = K1 + M2
         LET  XR = A(J1)
         LET  XI = A(J1 + 1)
         LET  YR = A(K1)
         LET  YI = A(K1 + 1)
         LET  A(J1) = YR
         LET  A(J1 + 1) = YI
         LET  A(K1) = XR
         LET  A(K1 + 1) = XI
      NEXT J
   NEXT K
END IF
END SUB

EXTERNAL  SUB BITRV2CONJ(N, IP(), A())
OPTION ARITHMETIC NATIVE
LET  IP(0) = 0
LET  L = N
LET  M = 1
DO WHILE 8 * M < L
   LET  L = L / 2
   FOR J = 0 TO M - 1
      LET  IP(M + J) = IP(J) + L
   NEXT J
   LET  M = M * 2
LOOP
LET  M2 = 2 * M
IF 8 * M = L THEN
   FOR K = 0 TO M - 1
      FOR J = 0 TO K - 1
         LET  J1 = 2 * J + IP(K)
         LET  K1 = 2 * K + IP(J)
         LET  XR = A(J1)
         LET  XI = -A(J1 + 1)
         LET  YR = A(K1)
         LET  YI = -A(K1 + 1)
         LET  A(J1) = YR
         LET  A(J1 + 1) = YI
         LET  A(K1) = XR
         LET  A(K1 + 1) = XI
         LET  J1 = J1 + M2
         LET  K1 = K1 + 2 * M2
         LET  XR = A(J1)
         LET  XI = -A(J1 + 1)
         LET  YR = A(K1)
         LET  YI = -A(K1 + 1)
         LET  A(J1) = YR
         LET  A(J1 + 1) = YI
         LET  A(K1) = XR
         LET  A(K1 + 1) = XI
         LET  J1 = J1 + M2
         LET  K1 = K1 - M2
         LET  XR = A(J1)
         LET  XI = -A(J1 + 1)
         LET  YR = A(K1)
         LET  YI = -A(K1 + 1)
         LET  A(J1) = YR
         LET  A(J1 + 1) = YI
         LET  A(K1) = XR
         LET  A(K1 + 1) = XI
         LET  J1 = J1 + M2
         LET  K1 = K1 + 2 * M2
         LET  XR = A(J1)
         LET  XI = -A(J1 + 1)
         LET  YR = A(K1)
         LET  YI = -A(K1 + 1)
         LET  A(J1) = YR
         LET  A(J1 + 1) = YI
         LET  A(K1) = XR
         LET  A(K1 + 1) = XI
      NEXT J
      LET  K1 = 2 * K + IP(K)
      LET  A(K1 + 1) = -A(K1 + 1)
      LET  J1 = K1 + M2
      LET  K1 = J1 + M2
      LET  XR = A(J1)
      LET  XI = -A(J1 + 1)
      LET  YR = A(K1)
      LET  YI = -A(K1 + 1)
      LET  A(J1) = YR
      LET  A(J1 + 1) = YI
      LET  A(K1) = XR
      LET  A(K1 + 1) = XI
      LET  K1 = K1 + M2
      LET  A(K1 + 1) = -A(K1 + 1)
   NEXT K
ELSE
   LET  A(1) = -A(1)
   LET  A(M2 + 1) = -A(M2 + 1)
   FOR K = 1 TO M - 1
      FOR J = 0 TO K - 1
         LET  J1 = 2 * J + IP(K)
         LET  K1 = 2 * K + IP(J)
         LET  XR = A(J1)
         LET  XI = -A(J1 + 1)
         LET  YR = A(K1)
         LET  YI = -A(K1 + 1)
         LET  A(J1) = YR
         LET  A(J1 + 1) = YI
         LET  A(K1) = XR
         LET  A(K1 + 1) = XI
         LET  J1 = J1 + M2
         LET  K1 = K1 + M2
         LET  XR = A(J1)
         LET  XI = -A(J1 + 1)
         LET  YR = A(K1)
         LET  YI = -A(K1 + 1)
         LET  A(J1) = YR
         LET  A(J1 + 1) = YI
         LET  A(K1) = XR
         LET  A(K1 + 1) = XI
      NEXT J
      LET  K1 = 2 * K + IP(K)
      LET  A(K1 + 1) = -A(K1 + 1)
      LET  A(K1 + M2 + 1) = -A(K1 + M2 + 1)
   NEXT K
END IF
END SUB

EXTERNAL  SUB CFTBSUB(N, A(), W())
OPTION ARITHMETIC NATIVE
LET  L = 2
IF N > 8 THEN
   CALL CFT1ST(N, A, W)
   LET  L = 8
   DO WHILE 4 * L < N
      CALL CFTMDL(N, L, A, W)
      LET  L = 4 * L
   LOOP
END IF
IF 4 * L = N THEN
   FOR J = 0 TO L - 2 STEP 2
      LET  J1 = J + L
      LET  J2 = J1 + L
      LET  J3 = J2 + L
      LET  X0R = A(J) + A(J1)
      LET  X0I = -A(J + 1) - A(J1 + 1)
      LET  X1R = A(J) - A(J1)
      LET  X1I = -A(J + 1) + A(J1 + 1)
      LET  X2R = A(J2) + A(J3)
      LET  X2I = A(J2 + 1) + A(J3 + 1)
      LET  X3R = A(J2) - A(J3)
      LET  X3I = A(J2 + 1) - A(J3 + 1)
      LET  A(J) = X0R + X2R
      LET  A(J + 1) = X0I - X2I
      LET  A(J2) = X0R - X2R
      LET  A(J2 + 1) = X0I + X2I
      LET  A(J1) = X1R - X3I
      LET  A(J1 + 1) = X1I - X3R
      LET  A(J3) = X1R + X3I
      LET  A(J3 + 1) = X1I + X3R
   NEXT J
ELSE
   FOR J = 0 TO L - 2 STEP 2
      LET  J1 = J + L
      LET  X0R = A(J) - A(J1)
      LET  X0I = -A(J + 1) + A(J1 + 1)
      LET  A(J) = A(J) + A(J1)
      LET  A(J + 1) = -A(J + 1) - A(J1 + 1)
      LET  A(J1) = X0R
      LET  A(J1 + 1) = X0I
   NEXT J
END IF
END SUB

EXTERNAL  SUB CFT1ST(N, A(), W())
OPTION ARITHMETIC NATIVE
LET  X0R = A(0) + A(2)
LET  X0I = A(1) + A(3)
LET  X1R = A(0) - A(2)
LET  X1I = A(1) - A(3)
LET  X2R = A(4) + A(6)
LET  X2I = A(5) + A(7)
LET  X3R = A(4) - A(6)
LET  X3I = A(5) - A(7)
LET  A(0) = X0R + X2R
LET  A(1) = X0I + X2I
LET  A(4) = X0R - X2R
LET  A(5) = X0I - X2I
LET  A(2) = X1R - X3I
LET  A(3) = X1I + X3R
LET  A(6) = X1R + X3I
LET  A(7) = X1I - X3R
LET  WK1R = W(2)
LET  X0R = A(8) + A(10)
LET  X0I = A(9) + A(11)
LET  X1R = A(8) - A(10)
LET  X1I = A(9) - A(11)
LET  X2R = A(12) + A(14)
LET  X2I = A(13) + A(15)
LET  X3R = A(12) - A(14)
LET  X3I = A(13) - A(15)
LET  A(8) = X0R + X2R
LET  A(9) = X0I + X2I
LET  A(12) = X2I - X0I
LET  A(13) = X0R - X2R
LET  X0R = X1R - X3I
LET  X0I = X1I + X3R
LET  A(10) = WK1R * (X0R - X0I)
LET  A(11) = WK1R * (X0R + X0I)
LET  X0R = X3I + X1R
LET  X0I = X3R - X1I
LET  A(14) = WK1R * (X0I - X0R)
LET  A(15) = WK1R * (X0I + X0R)
LET  K1 = 0
FOR J = 16 TO N - 16 STEP 16
   LET  K1 = K1 + 2
   LET  K2 = 2 * K1
   LET  WK2R = W(K1)
   LET  WK2I = W(K1 + 1)
   LET  WK1R = W(K2)
   LET  WK1I = W(K2 + 1)
   LET  WK3R = WK1R - 2 * WK2I * WK1I
   LET  WK3I = 2 * WK2I * WK1R - WK1I
   LET  X0R = A(J) + A(J + 2)
   LET  X0I = A(J + 1) + A(J + 3)
   LET  X1R = A(J) - A(J + 2)
   LET  X1I = A(J + 1) - A(J + 3)
   LET  X2R = A(J + 4) + A(J + 6)
   LET  X2I = A(J + 5) + A(J + 7)
   LET  X3R = A(J + 4) - A(J + 6)
   LET  X3I = A(J + 5) - A(J + 7)
   LET  A(J) = X0R + X2R
   LET  A(J + 1) = X0I + X2I
   LET  X0R = X0R - X2R
   LET  X0I = X0I - X2I
   LET  A(J + 4) = WK2R * X0R - WK2I * X0I
   LET  A(J + 5) = WK2R * X0I + WK2I * X0R
   LET  X0R = X1R - X3I
   LET  X0I = X1I + X3R
   LET  A(J + 2) = WK1R * X0R - WK1I * X0I
   LET  A(J + 3) = WK1R * X0I + WK1I * X0R
   LET  X0R = X1R + X3I
   LET  X0I = X1I - X3R
   LET  A(J + 6) = WK3R * X0R - WK3I * X0I
   LET  A(J + 7) = WK3R * X0I + WK3I * X0R
   LET  WK1R = W(K2 + 2)
   LET  WK1I = W(K2 + 3)
   LET  WK3R = WK1R - 2 * WK2R * WK1I
   LET  WK3I = 2 * WK2R * WK1R - WK1I
   LET  X0R = A(J + 8) + A(J + 10)
   LET  X0I = A(J + 9) + A(J + 11)
   LET  X1R = A(J + 8) - A(J + 10)
   LET  X1I = A(J + 9) - A(J + 11)
   LET  X2R = A(J + 12) + A(J + 14)
   LET  X2I = A(J + 13) + A(J + 15)
   LET  X3R = A(J + 12) - A(J + 14)
   LET  X3I = A(J + 13) - A(J + 15)
   LET  A(J + 8) = X0R + X2R
   LET  A(J + 9) = X0I + X2I
   LET  X0R = X0R - X2R
   LET  X0I = X0I - X2I
   LET  A(J + 12) = -WK2I * X0R - WK2R * X0I
   LET  A(J + 13) = -WK2I * X0I + WK2R * X0R
   LET  X0R = X1R - X3I
   LET  X0I = X1I + X3R
   LET  A(J + 10) = WK1R * X0R - WK1I * X0I
   LET  A(J + 11) = WK1R * X0I + WK1I * X0R
   LET  X0R = X1R + X3I
   LET  X0I = X1I - X3R
   LET  A(J + 14) = WK3R * X0R - WK3I * X0I
   LET  A(J + 15) = WK3R * X0I + WK3I * X0R
NEXT J
END SUB

EXTERNAL  SUB CFTMDL(N, L, A(), W())
OPTION ARITHMETIC NATIVE
LET  M = 4 * L
FOR J = 0 TO L - 2 STEP 2
   LET  J1 = J + L
   LET  J2 = J1 + L
   LET  J3 = J2 + L
   LET  X0R = A(J) + A(J1)
   LET  X0I = A(J + 1) + A(J1 + 1)
   LET  X1R = A(J) - A(J1)
   LET  X1I = A(J + 1) - A(J1 + 1)
   LET  X2R = A(J2) + A(J3)
   LET  X2I = A(J2 + 1) + A(J3 + 1)
   LET  X3R = A(J2) - A(J3)
   LET  X3I = A(J2 + 1) - A(J3 + 1)
   LET  A(J) = X0R + X2R
   LET  A(J + 1) = X0I + X2I
   LET  A(J2) = X0R - X2R
   LET  A(J2 + 1) = X0I - X2I
   LET  A(J1) = X1R - X3I
   LET  A(J1 + 1) = X1I + X3R
   LET  A(J3) = X1R + X3I
   LET  A(J3 + 1) = X1I - X3R
NEXT J
LET  WK1R = W(2)
FOR J = M TO L + M - 2 STEP 2
   LET  J1 = J + L
   LET  J2 = J1 + L
   LET  J3 = J2 + L
   LET  X0R = A(J) + A(J1)
   LET  X0I = A(J + 1) + A(J1 + 1)
   LET  X1R = A(J) - A(J1)
   LET  X1I = A(J + 1) - A(J1 + 1)
   LET  X2R = A(J2) + A(J3)
   LET  X2I = A(J2 + 1) + A(J3 + 1)
   LET  X3R = A(J2) - A(J3)
   LET  X3I = A(J2 + 1) - A(J3 + 1)
   LET  A(J) = X0R + X2R
   LET  A(J + 1) = X0I + X2I
   LET  A(J2) = X2I - X0I
   LET  A(J2 + 1) = X0R - X2R
   LET  X0R = X1R - X3I
   LET  X0I = X1I + X3R
   LET  A(J1) = WK1R * (X0R - X0I)
   LET  A(J1 + 1) = WK1R * (X0R + X0I)
   LET  X0R = X3I + X1R
   LET  X0I = X3R - X1I
   LET  A(J3) = WK1R * (X0I - X0R)
   LET  A(J3 + 1) = WK1R * (X0I + X0R)
NEXT J
LET  K1 = 0
LET  M2 = 2 * M
FOR K = M2 TO N - M2 STEP M2
   LET  K1 = K1 + 2
   LET  K2 = 2 * K1
   LET  WK2R = W(K1)
   LET  WK2I = W(K1 + 1)
   LET  WK1R = W(K2)
   LET  WK1I = W(K2 + 1)
   LET  WK3R = WK1R - 2 * WK2I * WK1I
   LET  WK3I = 2 * WK2I * WK1R - WK1I
   FOR J = K TO L + K - 2 STEP 2
      LET  J1 = J + L
      LET  J2 = J1 + L
      LET  J3 = J2 + L
      LET  X0R = A(J) + A(J1)
      LET  X0I = A(J + 1) + A(J1 + 1)
      LET  X1R = A(J) - A(J1)
      LET  X1I = A(J + 1) - A(J1 + 1)
      LET  X2R = A(J2) + A(J3)
      LET  X2I = A(J2 + 1) + A(J3 + 1)
      LET  X3R = A(J2) - A(J3)
      LET  X3I = A(J2 + 1) - A(J3 + 1)
      LET  A(J) = X0R + X2R
      LET  A(J + 1) = X0I + X2I
      LET  X0R = X0R - X2R
      LET  X0I = X0I - X2I
      LET  A(J2) = WK2R * X0R - WK2I * X0I
      LET  A(J2 + 1) = WK2R * X0I + WK2I * X0R
      LET  X0R = X1R - X3I
      LET  X0I = X1I + X3R
      LET  A(J1) = WK1R * X0R - WK1I * X0I
      LET  A(J1 + 1) = WK1R * X0I + WK1I * X0R
      LET  X0R = X1R + X3I
      LET  X0I = X1I - X3R
      LET  A(J3) = WK3R * X0R - WK3I * X0I
      LET  A(J3 + 1) = WK3R * X0I + WK3I * X0R
   NEXT J
   LET  WK1R = W(K2 + 2)
   LET  WK1I = W(K2 + 3)
   LET  WK3R = WK1R - 2 * WK2R * WK1I
   LET  WK3I = 2 * WK2R * WK1R - WK1I
   FOR J = K + M TO L + (K + M) - 2 STEP 2
      LET  J1 = J + L
      LET  J2 = J1 + L
      LET  J3 = J2 + L
      LET  X0R = A(J) + A(J1)
      LET  X0I = A(J + 1) + A(J1 + 1)
      LET  X1R = A(J) - A(J1)
      LET  X1I = A(J + 1) - A(J1 + 1)
      LET  X2R = A(J2) + A(J3)
      LET  X2I = A(J2 + 1) + A(J3 + 1)
      LET  X3R = A(J2) - A(J3)
      LET  X3I = A(J2 + 1) - A(J3 + 1)
      LET  A(J) = X0R + X2R
      LET  A(J + 1) = X0I + X2I
      LET  X0R = X0R - X2R
      LET  X0I = X0I - X2I
      LET  A(J2) = -WK2I * X0R - WK2R * X0I
      LET  A(J2 + 1) = -WK2I * X0I + WK2R * X0R
      LET  X0R = X1R - X3I
      LET  X0I = X1I + X3R
      LET  A(J1) = WK1R * X0R - WK1I * X0I
      LET  A(J1 + 1) = WK1R * X0I + WK1I * X0R
      LET  X0R = X1R + X3I
      LET  X0I = X1I - X3R
      LET  A(J3) = WK3R * X0R - WK3I * X0I
      LET  A(J3 + 1) = WK3R * X0I + WK3I * X0R
   NEXT J
NEXT K
END SUB
 		 

円周率の計算

 投稿者：しばっち  投稿日：2012年 7月11日(水)21時32分6秒
  OPTION ARITHMETIC NATIVE
PUBLIC NUMERIC BIAS, KETA, SIGN, EPS
LET  EPS = 15
LET  NN=2^13-EPS
LET  BIAS = 0
LET  KETA =-BIAS+NN+EPS
LET  SIGN = -BIAS - 1
DIM A(-BIAS - 1 TO KETA), B(-BIAS - 1 TO KETA), T(-BIAS - 1 TO KETA), D(-BIAS - 1 TO KETA)
DIM Y(-BIAS - 1 TO KETA)
PRINT (KETA-EPS)*4;"桁の計算"
PRINT "初期値計算開始 ";TIME$
LET TT=TIME
LET B(1)=5000
LET B(SIGN)=1
CALL LLET(A,"1.41421356237309504880168872420969807856967187537694807317667973799073247846210703885038753432764157273501384623091229702492483605585073721264412149709993583141322266592750559275579995050115278206057147010955997160597027453459686201472851741864088919860955232923048430871432145083976260362799525140798968725339654633180882964062061525835239505474575028775996172983557522033753185701135437460340849884716038689997069900481503054402779031645424782306849293691862158057846311159666871301301561856898723723528850926486124949771542183342042856860601468247207714358548741556570696776537202264854470158588016207584749226572260020855844665214583988939443709265918003113882464681570826301005948587040031864803421948972782906410450726368813137398552561173220402450912277002269411275736272804957381089675040183698683684507257993647290607629969413804756548237289971803268024744206292691248590521810044598421505911202494413417285314781058036033710773091828693147101711116839165817268894197587165821521282295184884720896946")
CALL LROOT(B,2,A)
CALL LCLR(A)
LET A(0)=1
LET A(SIGN)=1
LET T(0)=1
LET T(SIGN)=1
PRINT "本計算開始 ";TIME$
LET N=INT(LOG2((KETA-EPS)*4))
PRINT N;"回のループ"
FOR I=1 TO N
   PRINT I; "回目ループ開始 ";TIME$
   CALL LCOPY(Y, A) !'Y=A
   CALL LADD2(A, B) !'A=A+B
   CALL SDIV(A, 2) !'A=(A+B)/2
   CALL LMUL2(B, Y) !'B=B*Y
   CALL LLET(D,"1.1803405990160962260453379405584885872337166348814472995158643994043041807207157949784586161958079542094501011740292391558983114363307772537179901431278907198180022631848551446228568968727290914938763567035131526302916966294160360929620596994708114931694510735455482288368551127932729308542681350952930150721252050562501929985875965308823634425612598226755198069995211240731261603162039175693541218683276929413095721235428538964841422109753898357049667178621838238977087340954876250984589313456259797012783650441595738187089403712449669273254118014112496048274590183868547091977755666227180131335726631660131266131004593333344606488043269036157940955769174454232077882420546288372747664608765565451867337191134341713055280848497823085519339914098700300563588272756017194524101464447383612115436206799071109638039056449850030469593376362703990715387837080990494695017569187571119930919000206494006335605678681262111333568785739621375941779126327769125705948757162148053434214663157870501672695252082809896437")
   CALL LROOT(B,2,D)  !'B=SQR(B)
   CALL LSUB(Y, A, D) !'D=Y-A
   CALL LMUL2(D,D)  !'D=(Y-A)^2
   CALL SMUL(D,2^(I+1)) !'D=(Y-A)^2*2^(I+1)
   CALL LSUB2(T, D) !'T=T-D
NEXT I
PRINT "本計算終了 ";TIME$
CALL LADD2(A, B) !'A=A+B
CALL LMUL2(A,A) !'A=(A+B)^2
CALL LLET(D,"1.09421980761323831941838497035223227162968636141278336105964310528972596922296647388551657483878043159010324264134932996553974460016759121846133050698996332288555287910236240242455177433717867102689074846117652736155807179216436398690608159709925338697120024700336549551674314126512619334904422167530426298919613374763698493815324524156559140599889382645126987244457105603196228753398324115087573478288902030415549530952126504651807549640134536466732889257628998153939987431623998315595746787310366295077371569110455025751324445372136919929577952495837146837832273056504149196082794537931421338179675190631479791945279819574381912180875059411423540455151542190868866660269903546477431500319054432488573938743984765851668467635521405993224813414120248734750833760132048057438717569869091694761936201474148039365220149010688572137927945794255839641679283999821834698109484233041245570229569281484483555944122238475703510331242049350614542146739175784519109295251742429195053833668410032388383123379673265018793")
PRINT "割り算計算開始 ";TIME$
CALL REC(T,D) !'逆数
CALL LMUL2(A,T)
PRINT "計算終了 ";TIME$;TIME-TT;"秒"
CALL DISPLAY(A,"PI.TXT")
END

EXTERNAL  SUB REC(Y(),X()) !'逆数
OPTION ARITHMETIC NATIVE
DIM YY(-BIAS - 1 TO KETA)
DIM XX(-BIAS - 1 TO KETA),A(-BIAS - 1 TO KETA)
LET A(0)=2
LET A(SIGN)=1
CALL LCOPY(YY,Y)
DO
   CALL LCOPY(XX,X)
   CALL LCOPY(Y,YY)
   LET Y(SIGN)=-1
   CALL LMUL2(Y,X) !'Y=Y*X
   CALL LADD2(Y,A) !'Y=Y+2
   CALL LMUL2(Y,X) !'Y=Y*X
   CALL LCOPY(X,Y)
LOOP UNTIL EQUAL(X,XX)=-1
END SUB

EXTERNAL  SUB DISPLAY(X(),N$)
OPTION ARITHMETIC NATIVE
IF N$="" THEN
   OPEN #1: TEXTWINDOW1
ELSE
   OPEN #1:NAME N$
END IF
ERASE #1
FOR K=-BIAS TO 0
   IF X(K)<>0 THEN EXIT FOR
NEXT K
IF X(SIGN) = -1 THEN PRINT #1:"- ";
IF K>=0 THEN
   LET K=0
   PRINT #1:STR$(X(0));"."
ELSE
   PRINT #1:STR$(X(K));
   FOR I=K+1 TO 0
      LET A$=A$ & RIGHT$("000" & STR$(X(I)),4)
      IF LEN(A$)=100 THEN
         PRINT #1:A$
         LET A$=""
      END IF
   NEXT I
   IF LEN(A$)>0 THEN
      PRINT #1: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 #1:LEFT$(A$,10);" ";
         IF J=5 THEN PRINT #1:"   ";
         LET A$=RIGHT$(A$,LEN(A$)-10)
      NEXT J
      PRINT #1:":";S
      LET A$=""
      IF MOD(S,1000)=0 THEN PRINT #1
   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 #1:RTRIM$(LEFT$(A$,10));" ";
      IF J=5 THEN PRINT #1:"   ";
      LET A$=RIGHT$(A$,LEN(A$)-10)
      IF RTRIM$(A$)="" THEN EXIT FOR
   NEXT J
   IF A$<>"" THEN PRINT #1:A$ !' <--追加訂正
END IF
CLOSE #1
END SUB

EXTERNAL  FUNCTION EQUAL(A(), B())
OPTION ARITHMETIC NATIVE
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

以下省略

※「n乗根の計算」から必要なサブルーチンをコピペしてください
 		 

円周率の計算(検算用)

 投稿者：しばっち  投稿日：2012年 7月11日(水)21時33分43秒
  OPTION ARITHMETIC NATIVE
PUBLIC NUMERIC BIAS, KETA, SIGN, EPS
LET  BIAS = 0
LET  KETA = 10000
LET  SIGN = -BIAS - 1
LET  EPS = 0
LET  KETA = KETA + EPS
DIM X(-BIAS - 1 TO KETA),S(-BIAS-1 TO KETA)
!'π/4=2805*ATN(1/5257)-398*ATN(1/9466)+1950*ATN(1/12943)+1850*ATN(1/34208)+2021*ATN(1/44179)+2097*ATN(1/85353)+1484*ATN(1/114669)+1389*ATN(1/330182)+808*ATN(1/485298)
PRINT (KETA-EPS)*4;"桁の計算開始 ";TIME$
LET T=TIME
PRINT "4*2805*ATN(1/5257)の計算 ";TIME$
CALL SATN(X,5257)
CALL SMUL(X,2805*4)
CALL LCOPY(S,X)
PRINT "4*398*ATN(1/9466)の計算 ";TIME$
CALL SATN(X,9466)
CALL SMUL(X,398*4)
CALL LSUB2(S,X)
PRINT "4*1950*ATN(1/12943)の計算 ";TIME$
CALL SATN(X,12943)
CALL SMUL(X,1950*4)
CALL LADD2(S,X)
PRINT "4*1850*ATN(1/34208)の計算 ";TIME$
CALL SATN(X,34208)
CALL SMUL(X,1850*4)
CALL LADD2(S,X)
PRINT "4*2021*ATN(1/44179)の計算 ";TIME$
CALL SATN(X,44179)
CALL SMUL(X,2021*4)
CALL LADD2(S,X)
PRINT "4*2097*ATN(1/85353)の計算 ";TIME$
CALL SATN(X,85353)
CALL SMUL(X,2097*4)
CALL LADD2(S,X)
PRINT "4*1484*ATN(1/114669)の計算 ";TIME$
CALL SATN(X,114669)
CALL SMUL(X,1484*4)
CALL LADD2(S,X)
PRINT "4*1389*ATN(1/330182)の計算 ";TIME$
CALL SATN(X,330182)
CALL SMUL(X,1389*4)
CALL LADD2(S,X)
PRINT "4*808*ATN(1/485298)の計算 ";TIME$
CALL SATN(X,485298)
CALL SMUL(X,808*4)
CALL LADD2(S,X)
PRINT "計算終了 ";TIME$;TIME-T;"秒"
CALL DISPLAY(S,"PI_検算.TXT")
END

EXTERNAL  SUB SATN(S(),XX) !'ATN(1/X)
!'ATN(1/X)=X/(X^2+1)*(1+(2)/(3)*1/(X^2+1)+(2*4)/(3*5)*(1/(X^2+1)^2+(2*4*6)/(3*5*7)*(1/(X^2+1))^3+...
OPTION ARITHMETIC NATIVE
DIM SS(-BIAS-1 TO KETA),Y(-BIAS-1 TO KETA)
LET Y(0)=1
LET Y(SIGN)=1
CALL SDIV(Y,XX*XX+1)
CALL SMUL(Y,XX)
CALL LCOPY(S,Y)
DO
   LET N=N+1
   CALL LCOPY(SS,S)
   CALL SMUL(Y,2*N)
   CALL SDIV(Y,2*N+1)
   CALL SDIV(Y,XX*XX+1)
   CALL LADD2(S,Y)
LOOP UNTIL EQUAL(SS,S)<>0
END SUB

以下省略
「n乗根の計算」から必要サブルーチンをコピペしてください
 		 

どこがおかしいのか？

 投稿者：ＧＡＩ  投稿日：2012年 7月15日(日)14時56分5秒
  趣味で数論の本に書かれている内容を、コンピュータを用いて確認していますが
このほど次のことで行き詰まっています。

ラマヌジャンの発見での確認作業

Δ=Π(n=1～∞)x*(1-x^n)^24
   =Σ(n=1～∞)τ(n)*x^n
（Δを重さ１２の保型形式というらしい。）
で決定するｘ＾ｎの係数τ(n)がオンライン整数列大辞典
http://oeis.org/A000594に載っている。
以下τ(n)をa(n)で表記します。（タイプの便利上）


n a(n)
1 1
2 -24
3 252
4 -1472
5 4830
6 -6048
7 -16744
8 84480
9 -113643
10 -115920
11 534612
12 -370944
13 -577738
14 401856
15 1217160
16 987136
17 -6905934
18 2727432
19 10661420
20 -7109760
21 -4219488
22 -12830688
23 18643272
24 21288960
25 -25499225
26 13865712
27 -73279080
28 24647168
29 128406630
30 -29211840
31 -52843168
32 -196706304
33 134722224
34 165742416
35 -80873520
36 167282496
37 -182213314
38 -255874080
39 -145589976
40 408038400

この数列には次の性質があると解説されており

（性質１）
自然数m,nが共通の素因数をもたないなら
a(m*n)=a(m)*a(n)　の乗法的法則が成立。

（性質２）
pが素数のとき、k=1,2,3,・・・
漸化式
a(p^(k+1))=a(p)*a(p^k)-p^11*a(p^(k-1))
が成立する。

（性質３）
Δを用いたゼータ関数として
L(s,Δ)=Σ(n=1～∞)a(n)/n^s
を定義すると
L(s,Δ)=Π(p:素数のすべて)(1-a(p)/p^s+p^(11-2*s))^(-1)

これを数値的に確認していくと、驚くべきことに成立していることが納得できていきました。

問題は次の性質４で、
（性質４）
a(n)=Σ((a,b,c,d,e)∈Ｚ^5 |a+b+c+d+e=0,a^2+b^2+c^2+d^2+e^2=10*n)
         (a-b)(a-c)(a-d)(a-e)(b-c)(b-d)(b-e)(c-d)(c-e)(d-e)/(1!*2!*3!*4!)********(S)

これはラマヌジャンのタウ係数a(n)を物理学者のダイソンがこの表示を学生の頃みつけたいう。
これを確認するために次の調査結果を得ていった。



a(1)　　a b c d e S
　　　　-2 -1 0 1 2 1
　　　　　　　　　　　　　　　　　　　　　　　　　　合計1　　　  1（一致）



a(2)   a b c d e S
　　　　-4 1 1 1 1 0
　　　　-3 -1 0 1 3 24
　　　　-1 -1 -1 -1 4 0
　　　　　　　　　　　　　　　　　　　　　　　　　　合計24       -24（一致）




a(3)   a b c d e S
　　　　-4 -1 0 2 3 126
　　　　-3 -3 2 2 2 0
　　　　-3 -2 0 1 4 126
　　　　-2 -2 -2 3 3 0
　　　　　　　　　　　　　　　　　　　　　　　　　　合計252       252（一致）


a(4)   a b c d e S
　　　　-5 -1 1 2 3 224
　　　　-4 -2 0 2 4 1024
　　　　-3 -2 -1 1 5 224
　　　　　　　　　　　　　　　　　　　　　　　　　　合計1472      -1472（一致）



a(5)   a b c d e S
　　　　-6 0 1 2 3 126
　　　　-5 -2 1 2 4 1701
　　　　-5 0 0 0 5 0
　　　　-4 -3 0 3 4 1176
　　　　-4 -2 -1 2 5 1701
　　　　-3 -2 -1 0 6 126
　　　　　　　　　　　　　　　　　　　　　　　　　　合計4830      4830 （一致）


a(6)   a b c d e S
　　　　-5 -3 1 3 4 3024
　　　　-4 -3 -1 3 5 3024
　　　　　　　　　　　　　　　　　　　　　　　　　　合計6048      -6048（一致）


a(7)   a b c d e S
　　　　-7 0 1 2 4 924
　　　　-6 -2 1 2 5 8624
　　　　-6 -1 -1 4 4 0
　　　　-5 -4 2 3 4 1176
　　　　-5 -2 -1 2 6 8624
　　　　-4 -4 1 1 6 0
　　　　-4 -3 -2 4 5 1176
　　　　-4 -2 -1 0 7 924
　　　　　　　　　　　　　　　　　　　　　　　　　　合計21448    -16744（不一致）


a(8)   a b c d e S
　　　　-8 2 2 2 2 0
　　　　-7 -2 3 3 3 0
　　　　-7 -1 1 2 5 7776
　　　　-6 -3 1 3 5 22176
　　　　-6 -2 0 2 6 24576
　　　　-5 -3 -1 3 6 22176
　　　　-5 -2 -1 1 7 7776
　　　　-3 -3 -3 2 7 0
　　　　-2 -2 -2 -2 8 0
　　　　　　　　　　　　　　　　　　　　　　　　　　　合計84480    84480（一致）


a(9)   a b c d e S
　　　　-8 0 1 3 4 2376
　　　　-7 -1 0 2 6 17199
　　　　-6 -4 2 3 5 12474
　　　　-6 -3 0 3 6 59049
　　　　-6 -2 0 1 7 17199
　　　　-5 -3 -2 4 6 12474
　　　　-4 -3 -1 0 8 2376
　　　　　　　　　　　　　　　　　　　　　　　　　　　合計123147　　-113643（不一致）


a(10)   a b c d e S
　　　　-8 -1 1 3 5 24024
　　　　-7 -3 1 4 5 39424
　　　　-7 -1 0 1 7 10976
　　　　-5 -5 0 5 5 0
　　　　-5 -4 -1 3 7 39424
　　　　-5 -3 -1 1 8 24024
　　　　　　　　　　　　　　　　　　　　　　　　　　　合計137872　　-115920（不一致）


n=1,2,3,4,5,6,8 はまさにダイソンの公式と一致するのだが、n=7,9,10では一致しないのです。
後n=50まで調べたのですが、n=22の時一致するだけで他はすべて合いませんでした。
どこかプログラムがおかしいのかな？
数値的にずれる部分を指摘してもらいたい。










 		 

Re: どこがおかしいのか？

 投稿者：山中和義  投稿日：2012年 7月15日(日)21時42分58秒
  > No.1922[元記事へ]

ＧＡＩさんへのお返事です。

> 問題は次の性質４で、
> （性質４）
> a(n)=Σ((a,b,c,d,e)∈Ｚ^5 |a+b+c+d+e=0,a^2+b^2+c^2+d^2+e^2=10*n)
>          (a-b)(a-c)(a-d)(a-e)(b-c)(b-d)(b-e)(c-d)(c-e)(d-e)/(1!*2!*3!*4!)********(S)

参考サイト　http://www.geocities.jp/ikuro_kotaro/koramu/teisuko.htm


!ダイソンによるラマヌジャンのτ係数

DEF F(x)=-INT(x/5)*5 !x≧0として、(-x)以上の5の倍数
!!DEF F(x)=INT((x+(5-1))/5)*5 !x≧0として、x以上の5の倍数

FOR n=1 TO 50
   LET m=10*n

   LET k=INT(SQR(m)) !a^2+0^2+0^2+0^2+0^2=10nより、[√(10n)]
   LET t=0
   FOR a=F(k)-4 TO k STEP 5 !(a,b,c,d,e)=(1,2,3,4,0) mod 5
      FOR b=F(k)-3 TO k STEP 5
         FOR c=F(k)-2 TO k STEP 5
            FOR d=F(k)-1 TO k STEP 5
               FOR e=F(k)+0 TO k STEP 5

                  IF a+b+c+d+e=0 THEN
                     IF a^2+b^2+c^2+d^2+e^2=m THEN

                        LET s=(a-b)*(a-c)*(a-d)*(a-e)*(b-c)*(b-d)*(b-e)*(c-d)*(c-e)*(d-e)/FACT(4)/FACT(3)/FACT(2)
                        PRINT a;b;c;d;e;"   "; s

                        LET t=t+s !Σ

                     END IF
                  END IF

               NEXT e
            NEXT d
         NEXT c
      NEXT b
   NEXT a

   PRINT "a(";STR$(n);")=";t
NEXT n

END

 		 

Re: どこがおかしいのか？

 投稿者：ＧＡＩ  投稿日：2012年 7月16日(月)11時42分27秒
  山中和義さんへのお返事です。

そういう意味で解釈すべきだったのですね。（mod 5 の解釈が不十分でした。）
これで、スッキリです。
いつも適切なアドバイスありがとうございます。
数論に便利なＰＡＲＩ/ＧＰという計算ソフトで確認作業を行うことが多いんですが、このソフトで
参考にさせてもらいプログラムを組んでみましても、まさにダイソンの公式通りの結果を確認できました。
差積ではVandermondの行列式を利用できるのですね。（私的には新発見でした。）


それにしても、ダイソンという人の才能（学生で、大学のハーディ（ラマヌジャンと共同研究していた。）の数学の授業に出席していて、趣味でこの公式を導き出したという。）
には恐れ入ります。
さらに紹介して頂いた、佐藤氏のサイトにはこれが素粒子の理論と繋がっていくという（素粒子と素数には深いところで繋がっている構造を感じる。）壮大な世界が広がっていそうです。

ダイソンのように、数学の世界と物理の世界を行き来できる人はどのような世界観を持つのでしょうか？
彼が書いた本を片っ端から読んでみたくなりました。
 		 

ゼータ関数の組合せ的公式のプログラムの依頼

 投稿者：GAI  投稿日：2012年 7月25日(水)11時25分15秒
  ゼータ関数ζ(n)=1+2^(-n)+3^(-n)+4^(-n)+5^(-n)+…
のn:偶数での値は
フーリエ展開などを利用して、ベルヌーイ数Ｂ(n)等を用いて
ζ(2)=π^2/6
ζ(4)=π^4/90
ζ(6)=π^6/945
ζ(8)=π^8/9450
…
一般に
ζ(2n)=(2*π)^(2n)*|B(2n)|/(2*(2n)!)  ＜B(n):n番目のベルヌーイ数＞
という式で表されることが公式集で紹介されています。

ここで、この値を組合せ的手法を用いて算出する方法が存在するのを知り、この
アルゴリズムをプログラミングして頂きたいのです。

その公式が

ζ(2k)={π^(2k)*k}Σ(n1+n2+n3+…+nm=2k :n1,n2,…,nmは偶数)(-1)^(k+m)/[{(n1+1)!*(n2+1)!*(n3+1)!*…*(nm+1)!}*m]

というものです。

<具体例>
ζ(6)
なら６を偶数で分けてΣの中の項が
   　　6=6　・・・・・・・→1/(7!*1)=1/5040
                          及び(-1)^(k+m)=(-1)^(3+1)=1

       =4+2,2+4・・・・・→1/(5!*3!*2),1/(3!*5!*2)から1/1440+1/1440=1/720
                          及び(-1)^(k+m)=(-1)^(3+2)=-1

       =2+2+2・・・・・・→1/(3!*3!*3!*3)=1/648
                          及び(-1)^(k+m)=(-1)^(3+3)=1
から
ζ(6)=π^6*3*(1/5040-1/720+1/648)
     =π^6*3*(1/2835)
     =π^6/945
と算出される。

一般的にζ(2n)を計算させるプログラムがほしいのですが、よろしくお願いいたします。


     		 

Re: ゼータ関数の組合せ的公式のプログラムの依頼

 投稿者：山中和義  投稿日：2012年 7月25日(水)13時50分37秒
  > No.1925[元記事へ]

GAIさんへのお返事です。

> ゼータ関数ζ(n)=1+2^(-n)+3^(-n)+4^(-n)+5^(-n)+…
> のn:偶数での値は

> ζ(2k)={π^(2k)*k}Σ(n1+n2+n3+…+nm=2k :n1,n2,…,nmは偶数)(-1)^(k+m)/[{(n1+1)!*(n2+1)!*(n3+1)!*…*(nm+1)!}*m]
>
> というものです。

自然数Kを自然数の和に分割するプログラムを考えればよいかと思います。



!ゼータ関数
!ζ(2K)=π^(2K)*K*Σ[n[1]+n[2]+ … +n[p]=2K、n[p]:偶数](-1)^(K+p)/( (n[1]+1)!*(n[2]+1)!* … *(n[p]+1)!*p )

OPTION ARITHMETIC RATIONAL !有理数モード

!----- ↓↓↓ -----
LET K=3 !K=1,2,3,4,…

PUBLIC NUMERIC T !Σ部分
LET T=0

DIM M(K) !Σn[p]=2K
MAT M=ZER
!----- ↑↑↑ -----

PUBLIC NUMERIC C !解の数
LET C=0
CALL search(1,0,M,K)


!----- ↓↓↓ -----
PRINT "ζ(";STR$(2*K);")=π^";STR$(2*K);" * ";
PRINT "(";K*T;")"
!----- ↑↑↑ -----

END


!自然数Nを分割する（並びの順序は区別する）
EXTERNAL SUB search(p,s,M(),N) !バックトラック法で検索する
OPTION ARITHMETIC RATIONAL !有理数モード

FOR i=1 TO N-s !※sは、0から(p-1)番目までの和
   LET M(p)=i !p番目を設定する

   IF s+i=N THEN !条件を満たせば
      LET C=C+1 !結果を表示する
      PRINT "No.";C
      MAT PRINT M; !debug

      !----- ↓↓↓ -----
      LET W=p !Σ部分の計算
      FOR j=1 TO p
         LET W=W*FACT(2*M(j)+1)
      NEXT j
      LET W=(-1)^(N+p)/W
      PRINT W !debug

      LET T=T+W
      !----- ↑↑↑ -----
   ELSE
      CALL search(p+1,s+i,M,N) !次へ
   END IF

   LET M(p)=0 !元に戻す
NEXT i
END SUB

 		 

図形に色を塗りたいのですが

 投稿者：きくりん  投稿日：2012年 7月25日(水)20時53分43秒
  正十二角形を敷き詰めるように書いて、四種類の色が四つの十二角形に一種類ずつ塗られるような感じで、それが敷き詰められていくようにしたいのですがどうしたらよいでしょうか？（例えば、田という字の線で囲まれたスペースに四種類の色を塗っていったものを敷き詰めるような感じを十二角形の敷き詰めでやりたいのです。分かりづらい説明で申し訳ありません…。）
そもそもこのプログラムでできますでしょうか？以下、十二角形を書いたものです。
SET WINDOW -100,100,-100,100
SET LINE width 3
LET a=10
LET n=12
LET m=SQR(3)
PICTURE dodecagon
   FOR t=0 TO n-1
      LET h=2*PI/n*t
      PLOT LINES : a*COS(h),a*sin(h);
   NEXT t
   PLOT LINES : a,0
END PICTURE
FOR i=-10 TO 10
   FOR j=-10 TO 10
      DRAW dodecagon WITH SHIFT (3*a*i/2,-m*a*i/2+m*a*j)
   NEXT j
NEXT i
END
 		 

Re: 図形に色を塗りたいのですが

 投稿者：山中和義  投稿日：2012年 7月25日(水)22時22分47秒
  > No.1927[元記事へ]

きくりんさんへのお返事です。

> 正十二角形を敷き詰めるように書いて、四種類の色が四つの十二角形に一種類ずつ塗られるような感じで、それが敷き詰められていくようにしたいのですがどうしたらよいでしょうか？

こんな感じでしょうか？


SET WINDOW -100,100,-100,100
LET a=10
LET n=6
LET m=SQR(3)
DIM x(0 TO n),Y(0 TO n)
PICTURE dodecagon
   FOR t=0 TO n-1
      LET h=2*PI/n*t
      LET x(t)=a*COS(h)
      LET y(t)=a*SIN(h)
   NEXT t
   MAT PLOT AREA, LIMIT n: x,y
END PICTURE
FOR i=-10 TO 10
   FOR j=-10 TO 10
      SET AREA COLOR MOD(i+j,4)+1
      DRAW dodecagon WITH SHIFT (3*a*i/2,-m*a*i/2+m*a*j)
   NEXT j
NEXT i
END
 

Re: 図形に色を塗りたいのですが

 投稿者：きくりん  投稿日：2012年 7月25日(水)22時34分39秒
  > No.1928[元記事へ]

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

助かりました！正六角形の敷き詰めを参考にしていたので、さすがに十二角形だとブサイクな敷き詰めですね(^_^;)
でも三角形とか綺麗でした。
ありがとうございました。 		 

円周率の計算

 投稿者：山中和義  投稿日：2012年 7月26日(木)10時49分54秒
  円周率の近似値の日　7月22日に思う、、、

方眼紙に図形を書くと、おおむね重なる図形の面積なので、

!π≒22/7

!616/(14*14)=22/7

SET WINDOW -1,15,-1,15 !第1象限
DRAW grid

FOR i=0 TO 360 !半径14の円
   LET th=2*PI*i/360 !ラジアン
   PLOT LINES: 14*COS(th),14*SIN(th); !折れ線で近似する
NEXT i
PLOT LINES !閉じる

SET LINE COLOR "RED"
PLOT LINES: 14,0; 13,6; 10,10; 6,13; 0,14 !16角形
LET S=( (0+6)*1/2 + (6+10)*3/2 + (10+13)*4/2 + (13+14)*6/2 )*4 !16角形の面積　※台形公式による
PRINT S; S/(14*14)

END



ちなみに、π≒22/7より、
π≒22*720/(7*720)
π≒(2*11)*(10*9*8)/(7*6!)
π/2≒11*10*9*8/(7*6*5*4*3*2*1)

1から11までの自然数で表されます。
 		 

Re: 円周率の計算

 投稿者：山中和義  投稿日：2012年 7月27日(金)11時29分55秒
  > No.1930[元記事へ]

> π≒22/7

連分数展開
3.14=3+14/100=3+7/50=3+1/(50/7)=3+1/(7+1/7)より、1/7を削除して、π≒3+1/7=22/7

3.1416=3+1/(7+1/(16+1/11))より、1/11を削除して、π≒355/113


OPTION ARITHMETIC RATIONAL !有理数モード
PRINT USING "#.#######": 3+1/(7+1/7)
PRINT 3+1/7

PRINT USING "#.#######": 3+1/(7+1/(16+1/11))
PRINT 3+1/(7+1/16)
END
 		 

ゴールドシュミット法

 投稿者：しばっち  投稿日：2012年 7月28日(土)14時08分53秒
  !'ゴールドシュミット法(Gold schmidt)
OPTION ARITHMETIC DECIMAL_HIGH
INPUT  PROMPT "A=":A !'(※ここでは A=3072は収束しない。A=5120以上では発散する)
LET X=A/32/32
LET Y=A/32/32
DO
   LET Z=(3-X)/2
   LET X=X*Z*Z
   LET Y=Y*Z
   PRINT Y*32
LOOP UNTIL ABS(X-1)<1E-990
PRINT
PRINT SQR(A)
END

----------------------------------------------

OPTION ARITHMETIC DECIMAL_HIGH
LET A=PI
LET X=A
LET Y=A
LET Z=.564189583547756  !'Z=SQR(1/PI) 初期値を与える
DO
   LET X=X*Z*Z
   LET Y=Y*Z
   LET Z=(3-X)/2 !'上のプログラムと計算順序を入れ替えている
   PRINT Y
LOOP UNTIL ABS(X-1)<1E-990
PRINT
PRINT SQR(PI)
END

----------------------------------------------

INPUT  PROMPT "A=":A
INPUT  PROMPT "n乗根=":N
LET X=A
LET Y=A
LET K=2^N
LET X=X/K^N
LET Y=Y/K^N
DO
   LET Z=(N+1-X)/N
   LET X=X*Z^N
   LET Y=Y*Z^(N-1)
   PRINT Y*K
LOOP UNTIL ABS(X-1)<=1E-13
PRINT Y*K;A^(1/N)
END
 		 

円周率

 投稿者：南澤  投稿日：2012年 7月31日(火)10時13分59秒
  シャープの級数によって円周率を求めたいです。
例えば小数点以下200までとしたとき、
テイラー級数をどの程度求めれば良いのでしょうか？ 		 

Re: 円周率

 投稿者：山中和義  投稿日：2012年 7月31日(火)10時59分37秒
  > No.1933[元記事へ]

南澤さんへのお返事です。

> シャープの級数によって円周率を求めたいです。
> 例えば小数点以下200までとしたとき、
> テイラー級数をどの程度求めれば良いのでしょうか？

参考サイト　http://www.math.meiji.ac.jp/~mk/syori2/jouhousyori2-2012-06/node7.html

!シャープの級数 π=6*ArcTan(1/√3)
OPTION ARITHMETIC DECIMAL_HIGH !1000桁モード
LET X=SQR(3)/3 !1/√3
LET N=414 !第n項まで
LET S=ArcTan(X,N)
PRINT "ArcTan(X)≒";S
PRINT "その6倍";6*S
PRINT USING "πとの差=-%.###^^^^^^":6*S-PI
END

EXTERNAL FUNCTION ArcTan(X,N) !ArcTan(x)の級数を第n項まで計算する
OPTION ARITHMETIC DECIMAL_HIGH !1000桁モード
LET F=-X*X
LET T=X
LET S=0
FOR J=1 TO N
   LET S=S+T/(2*J-1)
   LET T=F*T
NEXT J
LET ArcTan=S
END FUNCTION
 		 

多項式の値

 投稿者：山中和義  投稿日：2012年 8月11日(土)19時33分45秒
  問題
x=-1+√(-3)のとき、f(x)=x^4+x^3+5x^2+2x+20 の値を求めよ。

●近似解

OPTION ARITHMETIC COMPLEX !複素数モード
LET x=-1+SQR(-3)
PRINT x^4+x^3+5*x^2+2*x+20
END

実行結果
( 8 -8.88178419700125E-16)


●厳密解

解法１　f(-1+√(-3))を計算する。
　x=-1+√(-3)より、x^2={-1+√(-3)}^2=(-1)^2+2*(-1)*√(-3)+{√(-3)}^2=-2-2√(-3)
　x^3=x*x^2= …、x^4=(x^2)^2= … とするのは、計算量が多くなる。

そこで、

その１　直接計算する、f(α)の値


DATA 4 !最高次数
DATA 1,1,5,2,20 !f(x)=x^4+x^3+5x^2+2x+20

LET A=-1 !x=A+K√Bのとき
LET K=1
LET B=-3

READ N
DIM P(N+1)
MAT READ P
MAT PRINT P; !debug


!補題　{A+K√B}^E=N+M√B を計算する。
!答え
!　漸化式で表すことを考える。
!　べき乗がEまでの値をA[E]+K[E]√Bとすると、
!　A[E+1]+K[E+1]√B={A+K√B}{A[E]+K[E]√B}=(A*A[E]+K*B*K[E])+(K*A[E]+A*K[E])√B
!　したがって、
!　　A[E+1]=A*A[E]+K*B*K[E]
!　　K[E+1]=K*A[E]+A*K[E]
!　の連立漸化式を得る。

LET S=0 !s+t√B
LET T=0
FOR i=1 TO N+1 !ホーナー法　f(x)=((((0+P[1])x+P[2])x+P[3])x+P[4])x+P[5]
   LET W=A*S+K*B*T + P(i) !{ … }x+P[i]
   LET T=K*S+A*T
   LET S=W
   PRINT S;"+ ";T;"√";STR$(B)
NEXT i

END



その２　組立除法による、f(x)をx-αで割ったときの商と余り


DATA 4 !最高次数
DATA 1,1,5,2,20 !f(x)=x^4+x^3+5x^2+2x+20

LET A=-1 !x=A+K√Bのとき
LET K=1
LET B=-3

READ N
DIM P(N+1)
MAT READ P
MAT PRINT P; !debug


! 1   1       5  2  20  │ -1+√-3　　← A+K√B
!    -1+√-3  … … …  └─────
!─────────────
! 1  √-3     … … …　　← s+t√B

LET S=P(1) !s+t√B
LET T=0
FOR i=2 TO N+1 !組立除法
   LET W=P(i) + A*S+K*B*T !{s+t√B}{A+K√B}=As+At√B+Ks√B-KBt
   LET T=K*S+A*T
   LET S=W
   PRINT S;"+ ";T;"√";STR$(B)
NEXT i

END



よくみると、同じ算出方法である。
 		 

カードマジックの創作への数理調査依頼

 投稿者：ＧＡＩ  投稿日：2012年 8月12日(日)07時25分20秒
  トランプの枚数がｎ枚のパケットがあり
これを上から一枚ずつテーブルに左右に裏向きで配っていき２つの山を作っていく。
２つの山で、一方の山はテーブルから外す。
残った山で同様にカードを配り再び２つの山を作る。
これを繰り返して一枚のカードを残す。
このとき
最後にカードを配った方の山を除く場合を０、残す場合を１と表し
元のパケットのボトムからｋ番目のカードを最後まで残す為には
いかなる戦略をとればよいかを調べたい。

（例）１５枚のパケットで実験
下からｋ枚目のカードが最後まで残る。
ｋ枚目：１回目　２回目　３回目　４回目
１　　：１　　　０　　　１　　　０
２　　：０　　　１　　　１　　　０
３　　：１　　　１　　　１　　　０
４　　：０　　　０　　　１　　　０
５　　：１　　　０　　　０　　　０
６　　：０　　　１　　　０　　　０
７　　：１　　　１　　　０　　　０
８　　：０　　　０　　　０　　（決着済み）
９　　：１　　　０　　　１　　　１
１０　：０　　　１　　　１　　　１
１１　：１　　　１　　　１　　　１
１２　：０　　　０　　　１　　　１
１３　：１　　　０　　　０　　　１
１４　：０　　　１　　　０　　　１
１５　：１　　　１　　　０　　　１

の様な結果を得た。（これだけだと規則性が何となく判明する。）
しかし今度はパケットの枚数を１６枚と変化させると
微妙に変化して
１５枚の時の下から１４枚目を残す戦略０，１，０，１
を行うと１６枚目のカードが残ることになりずれる。

いろいろな枚数のパケットでの結果が知りたい。
（１５枚で実験するだけでかなり時間を要した。）

これをプログラム的にお願いしたいんですが・・・


 		 

Re: カードマジックの創作への数理調査依頼

 投稿者：山中和義  投稿日：2012年 8月12日(日)12時43分45秒
  > No.1936[元記事へ]

ＧＡＩさんへのお返事です。

> トランプの枚数がｎ枚のパケットがあり
> これを上から一枚ずつテーブルに左右に裏向きで配っていき２つの山を作っていく。
> ２つの山で、一方の山はテーブルから外す。
> 残った山で同様にカードを配り再び２つの山を作る。
> これを繰り返して一枚のカードを残す。
> このとき
> 最後にカードを配った方の山を除く場合を０、残す場合を１と表し
> 元のパケットのボトムからｋ番目のカードを最後まで残す為には
> いかなる戦略をとればよいかを調べたい。


LET N=15 !N枚のカード
LET K=2 !残すカードの位置（下からK枚目）

DIM P(N) !N枚のカードによるパケット　※P(1):上
FOR i=1 TO N !初期化
   LET P(i)=N+1-i
NEXT i

LET C=0 !回数

LET NN=N
DO WHILE NN>1 !1枚になるまで
   LET C=C+1
   MAT PRINT P; !debug

   DIM L(N),R(N) !2つに分ける
   MAT L=ZER !並び
   MAT R=ZER
   LET LL=0 !枚数
   LET RR=0
   FOR i=1 TO NN
      IF P(i)=K THEN LET KK=i !残すカードを確認する
      IF MOD(i,2)=1 THEN !左の山へ
         LET LL=LL+1
         LET L(LL)=P(i)
      ELSE !右の山へ
         LET RR=RR+1
         LET R(RR)=P(i)
      END IF
   NEXT i
   CALL Reverse(L,LL) !実際の並び（上から）に合わせる
   CALL Reverse(R,RR)
   MAT PRINT L; !debug
   MAT PRINT R;

   !!PRINT NN;KK !debug
   IF MOD(NN,2)=MOD(KK,2) THEN !最後のカードと同じ山にある場合
      PRINT STR$(C);"回目の戦略=1" !残す！
      IF MOD(NN,2)=1 THEN !左の山なら
         LET NN=LL
         MAT P=L
      ELSE !右の山なら
         LET NN=RR
         MAT P=R
      END IF
   ELSE
      PRINT STR$(C);"回目の戦略=0" !捨てる！
      IF MOD(NN,2)=1 THEN
         LET NN=RR
         MAT P=R
      ELSE
         LET NN=LL
         MAT P=L
      END IF
   END IF

   PRINT
LOOP

END


EXTERNAL SUB Reverse(P(),N) !カードの位置を反転させる
!!MAT PRINT P; !debug
FOR i=1 TO INT(N/2) !半分を対象とする
   LET t=P(i) !交換する
   LET P(i)=P(N+1-i)
   LET P(N+1-i)=t
NEXT i
!!MAT PRINT P; !debug
END SUB


実行結果　N=15,K=2の場合

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

1  3  5  7  9  11  13  15  0  0  0  0  0  0  0

2  4  6  8  10  12  14  0  0  0  0  0  0  0  0

1回目の戦略=0

2  4  6  8  10  12  14  0  0  0  0  0  0  0  0

14  10  6  2  0  0  0  0  0  0  0  0  0  0  0

12  8  4  0  0  0  0  0  0  0  0  0  0  0  0

2回目の戦略=1

14  10  6  2  0  0  0  0  0  0  0  0  0  0  0

6  14  0  0  0  0  0  0  0  0  0  0  0  0  0

2  10  0  0  0  0  0  0  0  0  0  0  0  0  0

3回目の戦略=1

2  10  0  0  0  0  0  0  0  0  0  0  0  0  0

2  0  0  0  0  0  0  0  0  0  0  0  0  0  0

10  0  0  0  0  0  0  0  0  0  0  0  0  0  0

4回目の戦略=0

 		 

Re: カードマジックの創作への数理調査依頼

 投稿者：山中和義  投稿日：2012年 8月12日(日)13時03分2秒
  > No.1937[元記事へ]

ＧＡＩさんへのお返事です。

> いかなる戦略をとればよいかを調べたい。

一覧表はこちらになります。


FOR N=1 TO 52 !N枚のカード
   PRINT STR$(N);"枚"
   FOR K=1 TO N !残すカードの位置（下からK枚目）
      PRINT USING "   ##枚目: ":K;

      DIM P(52) !N枚のカードによるパケット　※P(1):上
      FOR i=1 TO N !初期化
         LET P(i)=N+1-i
      NEXT i

      LET C=0 !回数

      LET NN=N
      DO WHILE NN>1 !1枚になるまで
         LET C=C+1
         !!MAT PRINT P; !debug

         DIM L(52),R(52) !2つに分ける
         MAT L=ZER !並び
         MAT R=ZER
         LET LL=0 !枚数
         LET RR=0
         FOR i=1 TO NN
            IF P(i)=K THEN LET KK=i !残すカードを確認する
            IF MOD(i,2)=1 THEN !左の山へ
               LET LL=LL+1
               LET L(LL)=P(i)
            ELSE !右の山へ
               LET RR=RR+1
               LET R(RR)=P(i)
            END IF
         NEXT i
         CALL Reverse(L,LL) !実際の並び（上から）に合わせる
         CALL Reverse(R,RR)
         !!MAT PRINT L; !debug
         !!MAT PRINT R;

         !!PRINT NN;KK !debug
         IF MOD(NN,2)=MOD(KK,2) THEN !最後のカードと同じ山にある場合
            PRINT "1"; !残す！
            IF MOD(NN,2)=1 THEN !左の山なら
               LET NN=LL
               MAT P=L
            ELSE !右の山なら
               LET NN=RR
               MAT P=R
            END IF
         ELSE
            PRINT "0"; !捨てる！
            IF MOD(NN,2)=1 THEN
               LET NN=RR
               MAT P=R
            ELSE
               LET NN=LL
               MAT P=L
            END IF
         END IF

      LOOP
      PRINT

   NEXT K
NEXT N

END


EXTERNAL SUB Reverse(P(),N) !カードの位置を反転させる
!!MAT PRINT P; !debug
FOR i=1 TO INT(N/2) !半分を対象とする
   LET t=P(i) !交換する
   LET P(i)=P(N+1-i)
   LET P(N+1-i)=t
NEXT i
!!MAT PRINT P; !debug
END SUB


実行結果

　　　：
　　　：
15枚
    1枚目: 1010
    2枚目: 0110
    3枚目: 1110
    4枚目: 0010
    5枚目: 1000
    6枚目: 0100
    7枚目: 1100
    8枚目: 000
    9枚目: 1011
   10枚目: 0111
   11枚目: 1111
   12枚目: 0011
   13枚目: 1001
   14枚目: 0101
   15枚目: 1101
16枚
    1枚目: 1010
    2枚目: 0010
    3枚目: 1110
    4枚目: 0110
    5枚目: 1000
    6枚目: 0000
    7枚目: 1100
    8枚目: 0100
    9枚目: 1011
   10枚目: 0011
   11枚目: 1111
   12枚目: 0111
   13枚目: 1001
   14枚目: 0001
   15枚目: 1101
   16枚目: 0101
17枚
　　　：
　　　：

 		 

プログラムを活用して

 投稿者：ＧＡＩ  投稿日：2012年 8月12日(日)17時44分48秒
  １：５２枚のトランプを客に十分シャッフルしてもらい、大体三等分するように３つのパケットに分けてもらう。（パケットＡ、Ｂ，Ｃ）

２：客にＡ，もう一人の客にＣパケットを渡し、再びシャッフルさせる。
　　演者はＢパケットを取り上げ、シャッフルしている形でＢパケットの枚数を数える。
　　（枚数は１５～２５枚位に収まる。この枚数をｋとしておく。）

３：枚数を把握したら、Ｂパケットを客に渡し、それも十分にシャッフルさせる。

４：客にＡパケットの任意の場所からカードを持ち上げてもらい（上パケットと呼ぶ。）
　　そのボトムにあるカードを見て覚えてもらい、この上パケットをＢパケットの上に
　　載せてもらう。
　　更に、残りの下パケットもさらにその上に重ねる。

５：Ｃパケットも、任意位置でカットしたパケットをこれに重ね、更に残りのパケットも
　　上に載せてもらう。

６：一つに重なったデックを取り上げ、表面を上にして右手に持ち、先ほど数えたｋに対し
　　ｋ－１５の枚数のカードを左手にランしてこの枚数のカードを右手デックの下へ移動させる。
　　引き続きフォールス・カット（カットするが、カードの順番は元と変わらぬ。）
　（これにより、客が覚えたカードはボトムから１６枚目に位置することになる。）

７：客にデックを大体二つに分けてもらう。

８：下パケットの方に客のカードはあるので、上パケットの方はテーブルから退ける。
　　（手を翳して、イメージを読み取る演技で取り除こう。）

９：残ったパケットで一枚ずつテーブルへカードを左右に配っていき、二つの山を作る。
　　（このとき、密かにこのパケットの枚数をカウントしておく。この枚数をｎとする。）
　　二山の一方をテーブルから除き（この戦略は下の１０：で解説）、残った山で同様に繰り返す。

１０：ｎの数が
　　　mod(n,4)≡0,1→グループＡ
　　　mod(n,4)≡2,3→グループＢ
　　　の違いにより、次の戦略をとる。
　　　二つの山を作り一方を除ける時、最後にカードを配った方の山を取り除くを０
　　　同じく、最後のカードを配った方の山を残すのを１
　　　で表記しておくと
　　　グループＡは２回目だけが戦略１で他は戦略０で進む。
　　　グループＢはすべて戦略０で進む。
　　　ただし残りのカードが２枚になったら、（下にある方が客のカード）
　　　１枚ずつ客の左右の手にのせて、いずれか一方のカードを受け取る。
　　　（これを最後のカードとするか、客の手に残ったのを最後のカードとするかはその時の判断で
　　　　処理する。マジシャンズ・チョイスの技で）
　　　また残りが３枚なら客のカードは真ん中に位置するので、これもマジシャンズ・チョイスで
　　　処理しても面白い。（任意の２枚を選ばせる。）

１１：覚えたカードの名を発表してもらい、最後のカードを確認する。



＊客がデックを二分するとき、枚数にばらつきが生じる（１６～３１枚まで通用）にも関わらず、広範に対応できる点が面白いと思う。

作って頂いた一覧表は、いろいろとこれから利用価値がありそうです。
いつもありがとうございます。





　　　　　　　 		 

m次式の組立除法

 投稿者：山中和義  投稿日：2012年 8月14日(火)11時22分58秒
  問題
Q上既約な多項式x^3-2x-2において、x^3-2x-2=0の根をαとする。
次の式をαの整式として表せ。

(1) (55+α＋2α^2+3α^3+4α^4+5α^5+6α^6+7α^7) / (194+α+8α^2+27α^3+64α^4+125α^5)

(2) (194+4α+16α^2+32α^3+44α^4+52α^5+60α^6+69α^7+46α^8-13α^9-48α^10-23α^11+6α^12+7α^13)
　 / (117-2α-258α^2-4630α^3-37141α^4-188890α^5-154063α^6+16384α^7+78125α^8)

答え
(1)
分子 (55+α＋2α^2+3α^3+4α^4+5α^5+6α^6+7α^7) の次数を下げると、


!補題
!多項式の除法F(x)÷G(x)、商と余り
!f[0]x^n+f[1]x^(n-1)+ … +f[n-1]x+f[n] ÷ g[0]x^m+g[1]x^(m-1)+ … +g[m-1]x+g[m]

!答え
!m次因子の組立除法による

DATA 7
DATA 7,6,5,4,3,2,1,55
DATA 3
DATA 1,0,-2,-2

READ N
DIM F(0 TO N)
MAT READ F
PRINT N
MAT PRINT F;

READ M
DIM G(0 TO M)
MAT READ G
PRINT M
MAT PRINT G;


!　        t列
!　        ↓
!　7   6   5   4   3   2   1  55     i列／j行
!　    0   0   0   0   0          │0    1
!　       14  12  38  60 106      │2    2
!　           14  12  38  60 106  │2    3
!-----------------------------------
!　7   6  19  30  53 100 167 161
!　    ↑
!　    W

DIM QR(0 TO N) !商と余り
MAT QR=F

LET G0=G(0)

FOR i=1 TO N-M+1
   LET W=QR(i-1)
   FOR J=1 TO M !x^(M-J)
      LET t=i+J-1
      !!PRINT i; J;t; W*(-G(J))/G0 !debug
      LET QR(t)=QR(t) + W*(-G(J))/G0
   NEXT J

   LET QR(i-1)=QR(i-1)/G0 !g[0]≠1のとき
NEXT i

MAT PRINT QR; !結果を表示する

END


実行結果

7
7  6  5  4  3  2  1  55

3
1  0 -2 -2

7  6  19  30  53  100  167  161



同様に、分母の次数を下げると、

DATA 5
DATA 125,64,27,8,1,194
DATA 3
DATA 1,0,-2,-2

として、

実行結果

5
125  64  27  8  1  194

3
1  0 -2 -2

125  64  277  386  683  748


よって、(161+167α+100α^2) / (748+683α+386α^2)


次に、分母の有理化を行う。

F(x)=P+Qx+Rx^2、G(x)=A+Bx+Cx^2 とすると、
F(x)/G(x)=a+bx+cx^2より、F(x)=G(x)(a+bx+cx^2)なので、右辺は分母を払って整理すると、
(A+Bx+Cx^2)(a+bx+cx^2)
=A(a+bx+cx^2)+Bx(a+bx+cx^2)+Cx^2(a+bx+cx^2)
=(Aa) +(Ba+Ab)x +(Ac+Bb+Ca)x^2 +(Bc+Cb)x^3 +(Cc)x^4

よって、3次式の組立除法より、
　Cc   Bc+Cb   Ac+Bb+Ca        Ba+Ab                 Aa
       0       0                                                 │0
               2Cc             2(Bc+Cb)                          │2
                               2Cc                   2(Bc+Cb)    │2
------------------------------------------------------------------
　Cc   Cb+Bc   Ca+Bb+(A+2C)c   Ba+(A+2C)b+(2B+2C)c   Aa+2Cb+2Bc

したがって、恒等式
　{Aa+2Cb+2Bc} + {Ba+(A+2C)b+(2B+2C)c}x + {Ca+Bb+(A+2C)c}x^2 = P+Qx+Rx^2
を満たすa,b,cを求めればよい。


OPTION ARITHMETIC RATIONAL !有理数モード

DIM M(3,3),x(3),n(3) !連立方程式Mx=n

LET A=748 !1
LET B=683 !x
LET C=386 !x^2

LET M(1,1)=A
LET M(1,2)=2*C
LET M(1,3)=2*B
LET M(2,1)=B
LET M(2,2)=A+2*C
LET M(2,3)=2*B+2*C
LET M(3,1)=C
LET M(3,2)=B
LET M(3,3)=A+2*C

LET n(1)=161 !P  1
LET n(2)=167 !Q  x
LET n(3)=100 !R  x^2

DIM iM(3,3) !連立方程式を解く
MAT iM=INV(M)
MAT x=iM*n

MAT PRINT x; !a,b,c

END


実行結果

3007664/17073391  152836/51220173  2019415/102440346


よって、(18045984 + 305672α + 2019415α^2)/102440346



(2)
こちらの方が簡単である。

DATA 13
DATA 7,6,-23,-48,-13,46,69,60,52,44,32,16,4,194
DATA 3
DATA 1,0,-2,-2

と

DATA 8
DATA 78125,16384,-154063,-188890,-37141,-4630,-258,-2,117
DATA 3
DATA 1,0,-2,-2

として、分子や分母の次数を下げたとき、194/117を得る。
 		 

教えて下さい。

 投稿者：ＧＡＩ  投稿日：2012年 8月16日(木)14時18分12秒
  先日カードマジックの原理を掴むため教えてもらったプログラムを使って
今度は３山に配っていき、客が覚えたカードを最後に残すことを調べようと下記のプログラムを作ってみました。
ただし戦略"０"を行う時には、余った２つの山は左にある方のパケットを上段になるように
２つを重ねて、そのパケットで再び３山に配っていきます。

これで全パターンの一覧表を作成しようとしましたが、
プログラムの７行目の

LET P(j)=N+1-j

において、添え字が範囲外です。
の警告が出て上手く動作しません。
やむなく、個別にN,Kを指定していき調査しましたが、このどこに問題があるのか未だわかりません。
どうぞ解析のほどをお願いします。



FOR N=1 TO 52 !N枚のカード
   PRINT STR$(N);"枚"
   FOR K=1 TO N !残すカードの位置（下からK枚目）
      PRINT USING "   ##枚目: ":K;

     DIM P(52) !N枚のカードによるパケット　※P(1):上
     　FOR j=1 TO N  !初期化
         LET P(j)=N+1-j
      NEXT j

      LET C=0 !回数

      LET NN=N
      DO WHILE NN>1 !1枚になるまで
         LET C=C+1
         !PRINT "パケットのカード"
         !MAT PRINT P; !debug

         DIM L(N),R(N),M(N) !3つに分ける
         MAT L=ZER      !左パケット
         MAT R=ZER      !真ん中のパケット
         MAT M=ZER      !右パケット
         LET LL=0       !枚数
         LET RR=0
         LET MM=0
         FOR i=1 TO NN
            IF P(i)=K THEN LET KK=i !残すカードを確認する
            IF MOD(i,3)=1 THEN !左の山へ
               LET LL=LL+1
               LET L(LL)=P(i)
            ELSEIF  MOD(i,3)=2 THEN !真中の山へ
               LET RR=RR+1
               LET R(RR)=P(i)
            ELSEIF MOD(i,3)=0 THEN !右の山へ
               LET MM=MM+1
               LET M(MM)=P(i)
            END IF
         NEXT i

         CALL Reverse(L,LL) !実際の並び（上から）に合わせる
         CALL Reverse(R,RR)
         CALL reverse(M,MM)
         !PRINT "左の山";
         !MAT PRINT L;
         !PRINT "真中の山";
         !MAT PRINT R;
         !PRINT "右の山";
         !MAT PRINT M;

         !PRINT "カードの総数と残すカードのトップからの位置:";NN;KK
         IF MOD(NN,3)=MOD(KK,3) THEN !最後のカードと同じ山にある場合
            PRINT "1";     !!!STR$(C);"回目の戦略=1" !残す！
            IF MOD(NN,3)=1 THEN !左の山なら
               LET NN=LL
               MAT P=L
            ELSEIF MOD(NN,3)=2 THEN !真中の山なら
               LET NN=RR
               MAT P=R
            ELSEIF MOD(NN,3)=0 THEN !右の山なら
               LET NN=MM
               MAT P=M
            END IF

         ELSE

            PRINT "0";     !!!STR$(C);"回目の戦略=0" !捨てる
            IF MOD(NN,3)=1 THEN
               LET NN=RR+MM
               DIM P1(NN)
               FOR i=1 TO RR
                  LET  P1(i)=R(i)
                  MAT P=P1
               NEXT i
               FOR i=1 TO MM
            LET  P1(RR+i)=M(i)!残ったパケットは左方が上方になるように２つを重ねる。
                  MAT P=P1
               NEXT i


            ELSEIF MOD(NN,3)=2  THEN
               LET NN=LL+MM
               DIM P2(NN)
               FOR i=1 TO LL
                  LET  P2(i)=L(i)
                  MAT P=P2
               NEXT i
               FOR i=1 TO MM
            LET  P2(LL+i)=M(i)!残ったパケットは左方が上方になるように２つを重ねる。
                  MAT P=P2
               NEXT i


            ELSEIF  MOD(NN,3)=0 THEN
               LET NN=RR+LL
               DIM P3(NN)
               FOR i=1 TO LL
                  LET  P3(i)=L(i)
                  MAT P=P3
               NEXT i
               FOR i=1 TO RR
            LET  P3(LL+i)=R(i)!残ったパケットは左方が上方になるように２つを重ねる。
                  MAT P=P3
               NEXT i

            END IF
         END IF
      LOOP
      PRINT

   NEXT k
NEXT n

END


EXTERNAL SUB Reverse(P(),N) !カードの位置を反転させる
FOR i=1 TO INT(N/2)  !半分を対象とする
   LET t=P(i) !交換する
   LET P(i)=P(N+1-i)
   LET P(N+1-i)=t
NEXT i
END SUB


 		 

Re: 教えて下さい。

 投稿者：白石和夫  投稿日：2012年 8月16日(木)16時08分10秒
  > No.1941[元記事へ]

                MAT P=R
を実行した時点でPの上限がRの上限と同じになります。（P，Rの下限が同じ場合）

ついでに指摘しておくと，
FOR N=2 TO 52
   DIM R(N)
NEXT N
のように最初に確保した大きさから拡大するような使い方はできません。
配列の大きさを変えたいときは，
DIM R(52)
FOR N=2 TO 52
   MAT R=ZER(N)
NEXT N
のように，初めに最大の大きさで宣言しておいてください。
 		 

Re: 教えて下さい。

 投稿者：山中和義  投稿日：2012年 8月17日(金)09時32分13秒
  > No.1941[元記事へ]

ＧＡＩさんへのお返事です。

> 先日カードマジックの原理を掴むため教えてもらったプログラムを使って
> 今度は３山に配っていき、客が覚えたカードを最後に残すことを調べようと下記のプログラムを作ってみました。
> ただし戦略"０"を行う時には、余った２つの山は左にある方のパケットを上段になるように
> ２つを重ねて、そのパケットで再び３山に配っていきます。

山の個数は、変更できるようにしました。
山への分配は、左、中、右、左、中、右、… の順です。


LET D=3 !山の数　※D≧2

DIM P(52) !N枚のカードによるパケット　※P(1):上

FOR N=1 TO 52 !N枚のカード
   PRINT STR$(N);"枚"
   FOR K=1 TO N !残すカードの位置（下からK枚目）
      PRINT USING "   ##枚目: ":K;

      FOR i=1 TO N !初期化
         LET P(i)=N+1-i
      NEXT i
      !!!MAT PRINT P; !debug

      LET NN=N
      DO WHILE NN>1 !1枚になるまで

         DIM Q(52) !次のパケット
         MAT Q=ZER
         LET C=0 !その枚数

         FOR KK=1 TO NN !（上から）残すカードの位置を確認する
            IF P(KK)=K THEN EXIT FOR
         NEXT KK
         IF KK>NN THEN !存在しない場合
            PRINT "論理エラー"; NN
            MAT PRINT P;
            STOP
         END IF

         LET T=MOD(NN,D) !最後のカードが入る山の番号（左からT番目）
         IF T=0 THEN LET T=D !T=[1,D]

         IF MOD(KK,D)=MOD(NN,D) THEN !最後のカードと同じ山にある場合
            PRINT "1"; !残す！

            FOR J=T TO NN STEP D !山に分ける
               LET C=C+1
               LET Q(C)=P(J)
            NEXT J

         ELSE
            PRINT "0"; !捨てる！

            FOR i=D TO 1 STEP -1 !左にある方を上に重ねる
               IF i<>T THEN !同じ山を除く
                  FOR J=i TO NN STEP D !山に分ける
                     LET C=C+1
                     LET Q(C)=P(J)
                  NEXT J
               END IF
            NEXT i

         END IF
         CALL Reverse(Q,C) !実際の並び（上から）に合わせる
         !!!PRINT C !debug
         !!!MAT PRINT Q; !debug

         MAT P=Q !次へ
         LET NN=C
      LOOP

      PRINT
   NEXT K
NEXT N

END


EXTERNAL SUB Reverse(P(),N) !カードの位置を反転させる
!!MAT PRINT P; !debug
FOR i=1 TO INT(N/2) !半分を対象とする
   LET t=P(i) !交換する
   LET P(i)=P(N+1-i)
   LET P(N+1-i)=t
NEXT i
!!MAT PRINT P; !debug
END SUB

 		 

起動引数へのお願い

 投稿者：SECOND  投稿日：2012年 8月17日(金)12時31分51秒
  !EXECUTE program$ WITH( file1$, file2$, switch$ )

!起動引数を渡す場合、switch にまで、"/a" のように、ダブルクォーテーションが、
!両サイドに付いてくるため、スイッチとして認識されない場合が、多いです。
!以下の例で、３番目をエラーにしないで頂けると、助かります。

!------------------------------------------------------------------------
!EXECUTE "\masm\dump 80h.exe" WITH( "file 1", "file 2", "/a")
!
!0080 17 20 22 66 69 6C 65 20  31 22 20 22 66 69 6C 65   . "file 1" "file
!0090 20 32 22 20 22 2F 61 22  0D 00 00 00 00 00 00 00    2" "/a"........　・・・ＮＧ

!------------------------------------------------------------------------
!EXECUTE "\masm\dump 80h.exe" WITH( "file 1", "file 2", 123)
!
!0080 17 20 22 66 69 6C 65 20  31 22 20 22 66 69 6C 65   . "file 1" "file
!0090 20 32 22 20 20 31 32 33  0D 00 00 00 00 00 00 00    2"  123........　・・・ＯＫ

!------------------------------------------------------------------------
!EXECUTE "\masm\dump 80h.exe" WITH( "file 1", "file 2", /a)　　　　　　　　・・・エラー
!

!************************************************************************
!※以下で、対処しています。その代りスペースを含むファイル名、Literal が使用できず。
!------------------------------------------------------------------------
!EXECUTE "command.com" WITH( "/C \masm\dump80h.exe file1 file2 /a")
!
!0080 10 20 66 69 6C 65 31 20  66 69 6C 65 32 20 2F 61   . file1 file2 /a
!0090 22 0D 00 00 00 00 00 00  00 00 00 00 00 00 00 00   "...............　・・・末尾に残る

!------------------------------------------------------------------------
!EXECUTE "command.com" WITH( "/C \masm\dump80h.exe file1 file2 /a"& CHR$(0))
!
!0080 0F 20 66 69 6C 65 31 20  66 69 6C 65 32 20 2F 61   . file1 file2 /a
!0090 0D 00 00 00 00 00 00 00  00 00 00 00 00 00 00 00   ................　・・・ＯＫ

END
 		 

新作発表

 投稿者：ＧＡＩ  投稿日：2012年 8月17日(金)16時30分11秒
  > No.1943[元記事へ]

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

山の個数を自由に変更できるプログラムを拝見しました。
山を処理する方法がとてもアイデアに富み、すごく参考になりました。
（こちらは頭が硬直しており、前のやり方に固執してしまいます。）
このプログラムを使っていろいろ実験を繰り返し結果のデータを観察していたら次の法則があることにハタと気づきました。（これは数学的には当然と一言で済まされるかもしれませんが、このプログラムで始めて見えてきました。）
これの数理を活用したマジックを構成できました。


１：まずよくシャッフルされたデックから１２枚のカードをランして、演者はパケットを作る。

２：残りのパケットを客の前に置き、演者が持つパケットを使ってパケットを途中で上、下の部分に分け、上パケットのボトムのカードを見て覚え、そのパケットをこちらのパケットに重ねることを示す。

３：客は指示通り自分のパケットでカードを見て覚え、そのパケットを演者のパケットに重ねる。
残りの下パケットはテーブル脇にのける。

４：フォールスシャッフルをしてから、テーブルにパケットの上から一枚ずつカードを配っていく。
　このとき客のカードがつぎの位置に存在することになる。
１２グループに分けたとき：最後にカードを配る山の上から２枚目（つまり最後のカードの下）
６グループに分けたとき　：最後にカードを配る山の上から３枚目（１２／６＝２枚を除いた下）
４グループに分けたとき　：最後にカードを配る山の上から４枚目（１２／４＝３枚を除いた下）
３グループに分けたとき　：最後にカードを配る山の上から５枚目（１２／３＝４枚を除いた下）
２グループに分けたとき　：最後にカードを配る山の上から７枚目（１２／２＝６枚を除いた下）

５：客のカードの位置が特定出来るので、山を回収して一つに重ねるとき（それぞれの山を混ぜながら集めていく。）客のカードをボトムにコントロールして、密かに裏返し中程でカットしておけば、客のカードが一枚表向きでデックの中程に存在することができる。

６：客に覚えたカードの名前を発表してもらった後、デックをテーブルにリボンスプレッドする。


家族にやってみたらとても驚いてくれました。


＊演者が最初手にするカードが何枚かは客には分からず、説明のための準備として見てくれる。
＊１２枚ならグループに分ける方法が何通りもあり、ここもサイコロ等で偶然選ぶことも可能。
＊客が持ち上げる枚数がいろいろなので、まさか上記の法則にコントロールされるとは思わない。
　（ボトムのカードを覚えさせるのが錯覚を起こさせるポイントであろう。）
＊最初に手にしておく、カードの枚数でカードを配るグループをその都度変更できるので応用範囲が広い。
＊長くカードマジックに興味がありいろいろな本で作品を読んできましたが、上記の法則を利用した作品には未だ出会わなかったので、目から鱗で新鮮でした。


新しい創作マジックが作れたのも、このプログラムがあればこそです。
重ね重ねありがとうございました。




 		 

Re: 起動引数へのお願い

 投稿者：白石和夫  投稿日：2012年 8月17日(金)18時22分59秒
  EXECUTE "\masm\dump 80h.exe" WITH( "file 1", "file 2", /a)
は文法的に無理です。
EXECUTE文に引数を引用符でくくらずに渡すオプションを追加することは可能かもしれません。
たとえば，
EXECUTE "\masm\dump 80h.exe" WITH( """file 1""", """file 2""", "/a"), NoQuotes
みたいに。
 		 

Re: 起動引数へのお願い

 投稿者：SECOND  投稿日：2012年 8月17日(金)20時38分13秒
  > No.1946[元記事へ]

ぜひ､お願いします。切実です。
 		 

Re: 起動引数へのお願い

 投稿者：白石和夫  投稿日：2012年 8月18日(土)09時32分48秒
  > No.1947[元記事へ]

空白文字を含まないときは，引用符でくくらないことにするのはどうでしょうか？
（旧版との互換性が気になりますが）
 		 

Re: 起動引数へのお願い

 投稿者：SECOND  投稿日：2012年 8月18日(土)10時41分8秒
  > No.1948[元記事へ]

EXECUTE "\masm\dump 80h.exe" WITH( "-i", "file 1", "-o", "file2", "/a")

＞"\masm\dump 80h.exe" -i "file 1" -o file2 /a になるのですね。

EXECUTE "\masm\dump 80h.exe" WITH( """file 1""", """file 2""", "/a"), NoQuotes
の方が、自分としては好みですが、翻訳プログラムとの対話で、より簡単にできる方を優先して下さい。

＜追記＞
スイッチの中には、スペース無しにファイル名を後続要求するタイプが有ったように思い出され、
例　/O"file 2"　この場合は、 EXECUTE program$ WITH( "/O""file 2""" ), NoQuotes
この形式でないと、出来ないケースが有りそうです。
やはり、最初のご提案を、お願いします。 		 

Re: 起動引数へのお願い

 投稿者：白石和夫  投稿日：2012年 8月18日(土)18時14分33秒
  > No.1949[元記事へ]

NoQuotesオプションを追加するほうが旧版との互換性の問題が起こらないのでそちらを採用します。
（ver. 7.6.1になります） 		 

Re: 起動引数へのお願い

 投稿者：SECOND  投稿日：2012年 8月18日(土)19時07分42秒
  > No.1950[元記事へ]

全てのケースに対応できて便利です、ありがとうございました。

ついでに、command.com /c を使う場合も、今まで、"/c ～ になっていたためと思いますが、

「指定された COMMAND 検索ディレクトリが違います.」
のメッセージが、出なくなって、きれいなシーケンスになりました。
 		 

3ﾊﾞﾈ結合振り子.bas

 投稿者：村上元佑  投稿日：2012年 8月19日(日)12時22分24秒
  こんな、実験してみました

'  3ﾊﾞﾈ結合振り子.bas  MicroSoft BASIC互換ﾓｰﾄﾞ
'
'　　ﾗｸﾞﾗﾝｼﾞｪ法
'　　数式処理ｼｽﾃﾑＭｕＰａｄを使っての、式の整理仮定
'    reset();
'    /*  各ﾊﾞﾈの長さ  */
'    l1:=( (x1-x)^2+(y1-y)^2 )^1/2;
'    l2:=( (x2-x)^2+(y2-y)^2 )^1/2;
'    l3:=( (x3-x)^2+(y3-y)^2 )^1/2;
'
'    T:=1/2*m*(xd1^2+yd1^2);     /* 　運動エネルギー　*/
'    U:=m*g*y+1/2*k1*(lk1-l1)^2+1/2*k2*(lk2-l2)^2+1/2*k3*(lk3-l3)^2;    /*  位置エネルギー  */
'    L:=T-U;   /*   ラグラジアン */
'
'    Lxd1:=diff(L,xd1);    /*    x'による偏微分dL/x'    */
'    Lyd1:=diff(L,yd1);    /*    y'による偏微分dL/y'    */
'
'    Lx:=diff(L,x);        /*    xによる偏微分dL/x     */
'    Ly:=diff(L,y);        /*    yによる偏微分dL/y     */
'
'    xd2:=Lx/m;            /*    x''     */
'    yd2:=Ly/m;            /*    y''     */
'
'    下記はMuPadで求めたxd2(x''),yd2(y'')を、ﾌﾟﾛｸﾞﾗﾑ記述したもの
'    Lx_1=-k1*(x1-x)*( lk1-(x1-x)^2/2-(y1-y)^2/2 )
'    Lx_2=-k2*(x2-x)*( lk2-(x2-x)^2/2-(y2-y)^2/2 )
'    Lx_3=-k3*(x2-x)*( lk3-(x3-x)^2/2-(y3-y)^2/2 )
'    Lx=lx_1+lx_2+lx_3
'    xd2=Lx/m
'
'    Ly_1=-k1*(y1-y)*( lk1-(x1-x)^2/2-(y1-y)^2/2 )-g*m
'    Ly_2=-k2*(y2-y)*( lk2-(x2-x)^2/2-(y2-y)^2/2 )
'    Ly_3=-k3*(y3-y)*( lk3-(x3-x)^2/2-(y3-y)^2/2 )
'    Ly=Ly_1+Ly_2+Ly_3
'    yd2=Ly/m
'
'
'--------------------------------------------------------

  width=1260*2*2
  height=640
  SET BITMAP SIZE width, height

  reft=0
  right=width
  bottom=0
  top=height
  dx=0
  dy=0

  '左端，右端，下端，上端
  set window  left+dx,right,bottom+dy,top

  '描画エリアの背景色着色範囲設定
  set area color 1 !'黒
  plot area : left+dx,bottom+dy;left+dx,top;right,top;right,bottom+dy
  DRAW AXES (100,100)  '(right/k,top/k)

xbase=200
ybase=100
'--------------------------------------------------------
flag=1                 '質点ｍの軌跡表示する場合は１
x1=0:y1=500            'ﾊﾞﾈl1の支持点座標
x2=500+200:y2=500      'ﾊﾞﾈl2の支持点座標
x3=250:y3=0            'ﾊﾞﾈl3の支持点座標
x=300:y=250            '3つのﾊﾞﾈに接続した質点の初期座標
g=9.8                  '重力定数
m=6                    '質点質量
l1=( (x1-x)^2+(y1-y)^2 )^1/2   'ﾊﾞﾈ1の初期長さ
l2=( (x2-x)^2+(y2-y)^2 )^1/2   'ﾊﾞﾈ2の初期長さ
l3=( (x3-x)^2+(y3-y)^2 )^1/2   'ﾊﾞﾈ3の初期長さ


lk1=l1/2               'ﾊﾞﾈ1の、無張力時の長さ
lk2=l2/3               'ﾊﾞﾈ2の、無張力時の長さ
lk3=l3/4               'ﾊﾞﾈ3の、無張力時の長さ

k1=0.6                  'ﾊﾞﾈ1の、ﾊﾞﾈ定数
k2=0.8                  'ﾊﾞﾈ2の、ﾊﾞﾈ定数
k3=0.9                  'ﾊﾞﾈ3の、ﾊﾞﾈ定数

dt=0.0002               '時間刻幅

call draw               '描画ﾙｰﾁﾝ
input aa$
'--------------------------------------------------------
do while zz=0

   Lx_1=-k1*(x1-x)*( lk1-(x1-x)^2/2-(y1-y)^2/2 )
   Lx_2=-k2*(x2-x)*( lk2-(x2-x)^2/2-(y2-y)^2/2 )
   Lx_3=-k3*(x3-x)*( lk3-(x3-x)^2/2-(y3-y)^2/2 )
   Lx=Lx_1+Lx_2+Lx_3
   xd2=Lx/m               '   x''

   Ly_1=-k1*(y1-y)*( lk1-(x1-x)^2/2-(y1-y)^2/2 )-g*m
   Ly_2=-k2*(y2-y)*( lk2-(x2-x)^2/2-(y2-y)^2/2 )
   Ly_3=-k3*(y3-y)*( lk3-(x3-x)^2/2-(y3-y)^2/2 )
   Ly=Ly_1+Ly_2+Ly_3
   yd2=Ly/m               '   y''

   xd1=xd1+xd2*dt         '質点mの、x成分速度
   x=x+xd1*dt             '質点mの、x成分位置
   yd1=yd1+yd2*dt         '質点mの、y成分速度
   y=y+yd1*dt             '質点mの、y成分位置

   call draw              '描画ﾙｰﾁﾝ

loop
'------------------------------------
sub draw
  '描画ﾙｰﾁﾝ
  local r

  r=10
  set draw mode hidden

  '表示消去
  line(xbase+x1,ybase+y1)-(xbase+xo,ybase+yo),1    'l1の表示
  line(xbase+x2,ybase+y2)-(xbase+xo,ybase+yo),1    'l2の表示
  line(xbase+x3,ybase+y3)-(xbase+xo,ybase+yo),1    'l3の表示
  circle(xbase+xo,ybase+yo),r,1    ',,,,f

  '表示更新
  line(xbase-100,ybase)-(1000,ybase),6           '下の線
  line(xbase-100,ybase+500)-(1000,ybase+500),6   '上の線

  line(xbase+x1,ybase+y1)-(xbase+x,ybase+y),5    'l1の表示
  line(xbase+x2,ybase+y2)-(xbase+x,ybase+y),5    'l2の表示
  line(xbase+x3,ybase+y3)-(xbase+x,ybase+y),5    'l3の表示
  circle(xbase+x,ybase+y),r,4     ',,,,f

  if flag=1 then
     circle(xbase+x,ybase+y),2,4     '質点mの、軌跡表示
  end if

  set draw mode explicit

  xo=x:yo=y


end sub
'------------------------------------

 		 

イメージが混乱する

 投稿者：ＧＡＩ  投稿日：2012年 8月20日(月)18時23分15秒
  原点を中心に半径r1の円周上を反時計回りに回転する動点Pがある。
さらに、動点Pを中心として半径r2の円周上を半時計回りにPのa倍の速さで回転する動点Q
同じく、動点Qを中心として半径r3の円周上を時計回りにPのb倍の速さで回転する動点Rとする。
最初P(r1,0),Q(r1+r2,0),R(r1+r2+r3,0)でスタートしたとき、点Rの軌跡を見てみたい。
r1,r2,r3,a,bの値をいろいろ変化させて観察できるようにして頂きたい。

 		 

Re: イメージが混乱する

 投稿者：山中和義  投稿日：2012年 8月20日(月)21時58分44秒
  > No.1953[元記事へ]

ＧＡＩさんへのお返事です。

> 原点を中心に半径r1の円周上を反時計回りに回転する動点Pがある。
> さらに、動点Pを中心として半径r2の円周上を半時計回りにPのa倍の速さで回転する動点Q
> 同じく、動点Qを中心として半径r3の円周上を時計回りにPのb倍の速さで回転する動点Rとする。
> 最初P(r1,0),Q(r1+r2,0),R(r1+r2+r3,0)でスタートしたとき、点Rの軌跡を見てみたい。


LET R1=5 !半径
LET R2=2
LET R3=1
LET A=5 !速度
LET B=12

LET R=R1+R2+R3+1 !表示領域
SET WINDOW -R,R,-R,R

DIM PX(0 TO 360),PY(0 TO 360) !点P
DIM QX(0 TO 360),QY(0 TO 360) !点Q
DIM RX(0 TO 360),RY(0 TO 360) !点R
FOR i=0 TO 360
   SET DRAW mode hidden !ちらつき防止開始
   CLEAR
   DRAW grid !座標を描く

   LET PX(i)=R1*COS(RAD(i)) !反時計まわり
   LET PY(i)=R1*SIN(RAD(i))
   LET QX(i)=R2*COS(RAD(A*i))+PX(i) !反時計まわり
   LET QY(i)=R2*SIN(RAD(A*i))+PY(i)
   LET RX(i)=R3*COS(RAD(-B*i))+QX(i) !時計まわり
   LET RY(i)=R3*SIN(RAD(-B*i))+QY(i)

   SET LINE COLOR "GREEN" !円
   DRAW CIRCLE(R1) WITH SHIFT(0,0)
   DRAW CIRCLE(R2) WITH SHIFT(PX(i),PY(i))
   DRAW CIRCLE(R3) WITH SHIFT(QX(i),QY(i))

   SET LINE COLOR "BLACK"
   MAT PLOT LINES, LIMIT i+1:PX,PY !点P
   SET AREA COLOR "BLACK"
   DRAW DISK(0.2) WITH SHIFT(PX(i),PY(i))

   SET LINE COLOR "BLUE"
   MAT PLOT LINES, LIMIT i+1:QX,QY !点Q
   SET AREA COLOR "BLUE"
   DRAW DISK(0.2) WITH SHIFT(QX(i),QY(i))

   SET LINE COLOR "RED"
   MAT PLOT LINES, LIMIT i+1:RX,RY !点R
   SET AREA COLOR "RED"
   DRAW DISK(0.2) WITH SHIFT(RX(i),RY(i))

   SET DRAW mode explicit !ちらつき防止終了

   WAIT DELAY 0.1 !!!!!
NEXT i
PLOT LINES

END

EXTERNAL PICTURE CIRCLE(R) !円を描く
FOR i=0 TO 360
   PLOT LINES: R*COS(RAD(i)),R*SIN(RAD(i));
NEXT i
PLOT LINES
END PICTURE

EXTERNAL PICTURE DISK(R) !円板を描く
DIM X(0 TO 360),Y(0 TO 360)
FOR i=0 TO 360
   LET X(i)=R*COS(RAD(i))
   LET Y(i)=R*SIN(RAD(i))
NEXT i
MAT PLOT AREA, LIMIT 361: X,Y
END PICTURE
 

再帰図形

 投稿者：しばっち  投稿日：2012年10月21日(日)16時21分25秒
  PUBLIC NUMERIC THETA,X,Y
PUBLIC STRING F$
LET XSIZE=600
LET YSIZE=600
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW  0 , XSIZE-1 , YSIZE-1,0
SET POINT STYLE  1
SET COLOR MODE "REGULAR"
LET N=8
!'INPUT  PROMPT "LEVEL=": N
LET  L=100
LET THETA=90
LET X=XSIZE/2+L/2
LET Y=YSIZE-L
!'LET F$="樹木.svg"
IF F$<>"" THEN
   OPEN #1:NAME F$
   ERASE #1
   PRINT #1:"<?xml version=";CHR$(34);"1.0";CHR$(34);" encoding=";CHR$(34);"utf-8";CHR$(34);"?>"
   PRINT #1:"<!DOCTYPE svg PUBLIC ";CHR$(34);"-//W3C//DTD SVG 1.1//EN";CHR$(34);" ";CHR$(34);"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd";CHR$(34);" ["
   PRINT #1:" <!ENTITY ns_svg ";CHR$(34);"http://www.w3.org/2000/svg";CHR$(34);">"
   PRINT #1:" <!ENTITY ns_xlink ";CHR$(34);"http://www.w3.org/1999/xlink";CHR$(34);">"
   PRINT #1:"]>"
   PRINT #1:"<svg  version=";CHR$(34);"1.1";CHR$(34);" xmlns=";CHR$(34);"&ns_svg;";CHR$(34);" width=";CHR$(34);STR$(XSIZE);CHR$(34);" height=";CHR$(34);STR$(YSIZE);CHR$(34);" viewBox=";CHR$(34);"0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34)
   PRINT #1:" overflow=";CHR$(34);"visible";CHR$(34);" enable-background=";CHR$(34);"new 0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34);" xml:space=";CHR$(34);"preserve";CHR$(34);">"
END IF
CALL RECURSIVE(N,X,Y,L,#1)
IF F$<>"" THEN
   PRINT #1:"</svg>"
   CLOSE #1
END IF
END

EXTERNAL  SUB RECURSIVE(LEV,X,Y,L,#1)
IF LEV>0 THEN
   CALL BOX(X,Y,L,#1)
   LET THETA=THETA-45
   LET XX=X+L/SQR(2)*COS(THETA*PI/180)
   LET YY=Y-L/SQR(2)*SIN(THETA*PI/180)
   CALL RECURSIVE(LEV-1,XX,YY,L/SQR(2),#1)
   LET THETA=THETA+90
   LET XX=X+L*SQR(2)*COS(THETA*PI/180)
   LET YY=Y-L*SQR(2)*SIN(THETA*PI/180)
   CALL RECURSIVE(LEV-1,XX,YY,L/SQR(2),#1)
   LET THETA=THETA-45
END IF
END SUB

EXTERNAL  SUB BOX(X,Y,L,#1)
FOR I=1 TO 4
   LET THETA=THETA+90
   LET  XX=X+L*COS(THETA*PI/180)
   LET  YY=Y-L*SIN(THETA*PI/180)
   PLOT LINES: X,Y;XX,YY
   IF F$<>"" THEN PRINT #1:"<line x1=";CHR$(34);STR$(INT(X));CHR$(34);" y1=";CHR$(34);STR$(INT(Y));CHR$(34);" x2=";CHR$(34);STR$(INT(XX));CHR$(34);" y2=";CHR$(34);STR$(INT(YY));CHR$(34);" stroke=";CHR$(34);"black";CHR$(34);" stroke-width=";CHR$(34);"1";CHR$(34);"/>"
   LET X=XX
   LET Y=YY
NEXT I
PLOT LINES
END SUB
 		 

再帰図形

 投稿者：しばっち  投稿日：2012年10月21日(日)16時22分3秒
  PUBLIC NUMERIC AR, AI, BR, BI, CR, CI, DR, DI,XMIN,XMAX,YMIN,YMAX,XSIZE,YSIZE
PUBLIC STRING F$
LET XMAX=-1E10
LET YMAX=-1E10
LET XMIN=1E10
LET YMIN=1E10
LET XSIZE=600
LET YSIZE=600
SET BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE  1
SET COLOR MODE "REGULAR"
LET N=15
!'INPUT  PROMPT "LEVEL=": N
READ AR, AI, BR, BI, CR, CI, DR, DI
DATA 0,0,.5,.2887,0,0,.5,-.2887
!'DATA .5,.5,0,0,.5,-.5,0,0
!'DATA 0,0,.4,.5,0,0,.4,-.5
!'DATA 0,0,.5,.28867,0,0,.6667,0
!'DATA 0,.707,0,0,.5,0,0,0
!'DATA 0,0,.4614,.4614,.622,-.196,0,0
!'DATA .4614,.4614,0,0,0,0,.622,-.196
!'DATA .4614,.4614,0,0,0,0,.2896,-.585
!'DATA .4614,.4614,0,0,.622,-.196,0,0
!'DATA 0,0,0,.6667,0,0,.6667,0
CALL RECURSIVE(10,0,0,#1)
SET BITMAP SIZE XSIZE,YSIZE*(YMAX-YMIN)/(XMAX-XMIN)
SET WINDOW XMIN,XMAX,YMIN,YMAX
CLEAR
!'LET F$="再帰図形.svg"
IF F$<>"" THEN
   OPEN #1:NAME F$
   ERASE #1
   PRINT #1:"<?xml version=";CHR$(34);"1.0";CHR$(34);" encoding=";CHR$(34);"utf-8";CHR$(34);"?>"
   PRINT #1:"<!DOCTYPE svg PUBLIC ";CHR$(34);"-//W3C//DTD SVG 1.1//EN";CHR$(34);" ";CHR$(34);"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd";CHR$(34);" ["
   PRINT #1:" <!ENTITY ns_svg ";CHR$(34);"http://www.w3.org/2000/svg";CHR$(34);">"
   PRINT #1:" <!ENTITY ns_xlink ";CHR$(34);"http://www.w3.org/1999/xlink";CHR$(34);">"
   PRINT #1:"]>"
   PRINT #1:"<svg  version=";CHR$(34);"1.1";CHR$(34);" xmlns=";CHR$(34);"&ns_svg;";CHR$(34);" width=";CHR$(34);STR$(XSIZE);CHR$(34);" height=";CHR$(34);STR$(YSIZE);CHR$(34);" viewBox=";CHR$(34);"0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34)
   PRINT #1:" overflow=";CHR$(34);"visible";CHR$(34);" enable-background=";CHR$(34);"new 0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34);" xml:space=";CHR$(34);"preserve";CHR$(34);">"
END IF
CALL RECURSIVE(N,0,0,#1)
IF F$<>"" THEN
   PRINT #1:"</svg>"
   CLOSE #1
END IF
END

EXTERNAL  SUB RECURSIVE(N,X,Y,#1)
IF N>0 THEN
   PLOT POINTS: X , Y
   IF F$<>"" THEN PRINT #1:"<circle cx=";CHR$(34);STR$(PIXELX(X));CHR$(34);" cy=";CHR$(34);STR$(YSIZE-PIXELY(Y));CHR$(34);" r=";CHR$(34);"1";CHR$(34);" fill=";CHR$(34);"black";CHR$(34);" stroke=";CHR$(34);"black";CHR$(34);" stroke-width=";CHR$(34);"1";CHR$(34);" />"
   LET XMIN=MIN(XMIN,X)
   LET XMAX=MAX(XMAX,X)
   LET YMIN=MIN(YMIN,Y)
   LET YMAX=MAX(YMAX,Y)
   CALL RECURSIVE(N-1,X * (AR + BR) - Y * (AI - BI), X * (AI + BI) + Y * (AR - BR),#1)
   CALL RECURSIVE(N-1,X * (CR + DR) - Y * (CI - DI) - CR - DR + 1, X * (CI + DI) + Y * (CR - DR) - CI - DI,#1)
END IF
END SUB
 		 

再帰図形

 投稿者：しばっち  投稿日：2012年10月21日(日)16時22分55秒
  PUBLIC STRING F$
LET XSIZE=640
LET YSIZE=400
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW  0 , XSIZE-1 , YSIZE-1,0
SET POINT STYLE  1
SET COLOR MODE "REGULAR"
CLEAR
LET N=8
!'INPUT  PROMPT "LEVEL=": N
!'LET F$="再帰図形.svg"
IF F$<>"" THEN
   OPEN #1:NAME F$
   ERASE #1
   PRINT #1:"<?xml version=";CHR$(34);"1.0";CHR$(34);" encoding=";CHR$(34);"utf-8";CHR$(34);"?>"
   PRINT #1:"<!DOCTYPE svg PUBLIC ";CHR$(34);"-//W3C//DTD SVG 1.1//EN";CHR$(34);" ";CHR$(34);"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd";CHR$(34);" ["
   PRINT #1:" <!ENTITY ns_svg ";CHR$(34);"http://www.w3.org/2000/svg";CHR$(34);">"
   PRINT #1:" <!ENTITY ns_xlink ";CHR$(34);"http://www.w3.org/1999/xlink";CHR$(34);">"
   PRINT #1:"]>"
   PRINT #1:"<svg  version=";CHR$(34);"1.1";CHR$(34);" xmlns=";CHR$(34);"&ns_svg;";CHR$(34);" width=";CHR$(34);STR$(XSIZE);CHR$(34);" height=";CHR$(34);STR$(YSIZE);CHR$(34);" viewBox=";CHR$(34);"0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34)
   PRINT #1:" overflow=";CHR$(34);"visible";CHR$(34);" enable-background=";CHR$(34);"new 0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34);" xml:space=";CHR$(34);"preserve";CHR$(34);">"
END IF
CALL RECURSIVE(N,0,350,640,350,#1)
IF F$<>"" THEN
   PRINT #1:"</svg>"
   CLOSE #1
END IF
END

EXTERNAL  SUB RECURSIVE(N,X1,Y1,X2,Y2,#1)
LET XX=(X1+X2)/2
LET YY=(Y1+Y2)/2
LET TH=PI-ATN(5/4)*2
LET L=SQR((XX-X2)^2+(YY-Y2)^2)
LET THETA=-ANGLE((X2-XX),(Y2-YY))
LET X3=XX+L*COS(THETA+TH)
LET Y3=YY-L*SIN(THETA+TH)
LET X4=XX+L*COS(PI+THETA-TH)
LET Y4=YY-L*SIN(PI+THETA-TH)
IF N=0 THEN
   PLOT AREA:XX,YY;X2,Y2;X3,Y3
   IF F$<>"" THEN PRINT #1:"<polygon fill=";CHR$(34);"black";CHR$(34);" stroke=";CHR$(34);"black";CHR$(34);" stork-width=";CHR$(34);"1";CHR$(34);" points=";CHR$(34);STR$(INT(XX));",";STR$(INT(YY));" ";STR$(INT(X2));",";STR$(INT(Y2));" ";STR$(INT(X3));",";STR$(INT(Y3));" ";STR$(INT(XX));",";STR$(INT(YY));CHR$(34);"/>"
   PLOT AREA:XX,YY;X1,Y1;X4,Y4
   IF F$<>"" THEN  PRINT #1:"<polygon fill=";CHR$(34);"black";CHR$(34);" stroke=";CHR$(34);"black";CHR$(34);" stork-width=";CHR$(34);"1";CHR$(34);" points=";CHR$(34);STR$(INT(XX));",";STR$(INT(YY));" ";STR$(INT(X1));",";STR$(INT(Y1));" ";STR$(INT(X4));",";STR$(INT(Y4));" ";STR$(INT(XX));",";STR$(INT(YY));CHR$(34);"/>"
ELSE
   CALL RECURSIVE(N-1,X2,Y2,X3,Y3,#1)
   CALL RECURSIVE(N-1,X4,Y4,X1,Y1,#1)
END IF
END SUB
 

再帰図形

 投稿者：しばっち  投稿日：2012年10月21日(日)16時23分35秒
  PUBLIC NUMERIC XSIZE,YSIZE
PUBLIC STRING F$
LET XSIZE=600
LET YSIZE=600
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,1,-.5,.5
SET POINT STYLE  1
SET COLOR MODE "REGULAR"
LET N=12
!'INPUT  PROMPT "LEVEL=": N
!'LET F$="葉脈.svg"
IF F$<>"" THEN
   OPEN #1:NAME F$
   ERASE #1
   PRINT #1:"<?xml version=";CHR$(34);"1.0";CHR$(34);" encoding=";CHR$(34);"utf-8";CHR$(34);"?>"
   PRINT #1:"<!DOCTYPE svg PUBLIC ";CHR$(34);"-//W3C//DTD SVG 1.1//EN";CHR$(34);" ";CHR$(34);"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd";CHR$(34);" ["
   PRINT #1:" <!ENTITY ns_svg ";CHR$(34);"http://www.w3.org/2000/svg";CHR$(34);">"
   PRINT #1:" <!ENTITY ns_xlink ";CHR$(34);"http://www.w3.org/1999/xlink";CHR$(34);">"
   PRINT #1:"]>"
   PRINT #1:"<svg  version=";CHR$(34);"1.1";CHR$(34);" xmlns=";CHR$(34);"&ns_svg;";CHR$(34);" width=";CHR$(34);STR$(XSIZE);CHR$(34);" height=";CHR$(34);STR$(YSIZE);CHR$(34);" viewBox=";CHR$(34);"0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34)
   PRINT #1:" overflow=";CHR$(34);"visible";CHR$(34);" enable-background=";CHR$(34);"new 0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34);" xml:space=";CHR$(34);"preserve";CHR$(34);">"
END IF
LET X1=0
LET Y1=0
LET X2=1
LET Y2=0
LET X3=.5
LET Y3=SQR(3)/6
CALL RECURSIVE(N,X1,Y1,X2,Y2,X3,Y3,#1)
IF F$<>"" THEN
   PRINT #1:"</svg>"
   CLOSE #1
END IF
END

EXTERNAL  SUB RECURSIVE(N,X1, Y1, X2, Y2, X3, Y3,#1)
LET X4 = (2*X1        +   X2) / 3
LET Y4 = (2*Y1        +   Y2) / 3
LET X5 = (4*X1 - 3*X3 + 5*X2) / 6
LET Y5 = (4*Y1 - 3*Y3 + 5*Y2) / 6
IF N = 0  THEN
   PLOT LINES: X1,Y1;X3,Y3
   IF F$<>"" THEN PRINT #1:"<line x1=";CHR$(34);STR$(PIXELX(X1));CHR$(34);" y1=";CHR$(34);STR$(YSIZE-PIXELY(Y1));CHR$(34);" x2=";CHR$(34);STR$(PIXELX(X3));CHR$(34);" y2=";CHR$(34);STR$(YSIZE-PIXELY(Y3));CHR$(34);" stroke=";CHR$(34);"black";CHR$(34);" stroke-width=";CHR$(34);"1";CHR$(34);"/>"
   PLOT LINES: X4,Y4;X2,Y2
   IF F$<>"" THEN PRINT #1:"<line x1=";CHR$(34);STR$(PIXELX(X4));CHR$(34);" y1=";CHR$(34);STR$(YSIZE-PIXELY(Y4));CHR$(34);" x2=";CHR$(34);STR$(PIXELX(X2));CHR$(34);" y2=";CHR$(34);STR$(YSIZE-PIXELY(Y2));CHR$(34);" stroke=";CHR$(34);"black";CHR$(34);" stroke-width=";CHR$(34);"1";CHR$(34);"/>"
ELSE
   CALL  RECURSIVE(N-1, X1, Y1, X3, Y3, X4, Y4,#1)
   CALL  RECURSIVE(N-1, X4, Y4, X2, Y2, X5, Y5,#1)
END IF
END SUB
 		 

再帰図形

 投稿者：しばっち  投稿日：2012年10月21日(日)16時24分23秒
  PUBLIC NUMERIC XMIN,XMAX,YMIN,YMAX,XSIZE,YSIZE
PUBLIC STRING F$
LET XSIZE=600
LET YSIZE=600
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,1,-.5,.5
SET POINT STYLE  1
SET COLOR MODE "REGULAR"
LET N=10
!'INPUT  PROMPT "LEVEL=": N
!'LET F$="葉脈.svg"
IF F$<>"" THEN
   OPEN #1:NAME F$
   ERASE #1
   PRINT #1:"<?xml version=";CHR$(34);"1.0";CHR$(34);" encoding=";CHR$(34);"utf-8";CHR$(34);"?>"
   PRINT #1:"<!DOCTYPE svg PUBLIC ";CHR$(34);"-//W3C//DTD SVG 1.1//EN";CHR$(34);" ";CHR$(34);"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd";CHR$(34);" ["
   PRINT #1:" <!ENTITY ns_svg ";CHR$(34);"http://www.w3.org/2000/svg";CHR$(34);">"
   PRINT #1:" <!ENTITY ns_xlink ";CHR$(34);"http://www.w3.org/1999/xlink";CHR$(34);">"
   PRINT #1:"]>"
   PRINT #1:"<svg  version=";CHR$(34);"1.1";CHR$(34);" xmlns=";CHR$(34);"&ns_svg;";CHR$(34);" width=";CHR$(34);STR$(XSIZE);CHR$(34);" height=";CHR$(34);STR$(YSIZE);CHR$(34);" viewBox=";CHR$(34);"0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34)
   PRINT #1:" overflow=";CHR$(34);"visible";CHR$(34);" enable-background=";CHR$(34);"new 0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34);" xml:space=";CHR$(34);"preserve";CHR$(34);">"
END IF
CALL RECURSIVE(N,.5,SQR(3)/6,0,0,1,0,#1)
IF F$<>"" THEN
   PRINT #1:"</svg>"
   CLOSE #1
END IF
END

EXTERNAL  SUB RECURSIVE(N,AX,AY,BX,BY,CX,CY,#1)
IF N=0 THEN
   PLOT AREA:AX,AY;BX,BY;CX,CY
   IF F$<>"" THEN PRINT #1:"<polygon fill=";CHR$(34);"black";CHR$(34);" stroke=";CHR$(34);"black";CHR$(34);" stork-width=";CHR$(34);"1";CHR$(34);" points=";CHR$(34);STR$(PIXELX(AX));",";STR$(YSIZE-PIXELY(AY));" ";STR$(PIXELX(BX));",";STR$(YSIZE-PIXELY(BY));" ";STR$(PIXELX(CX));",";STR$(YSIZE-PIXELY(CY));" ";STR$(PIXELX(AX));",";STR$(YSIZE-PIXELY(AY));CHR$(34);"/>"
ELSE
   CALL RECURSIVE(N-1,(CX+2*BX)/3,(CY+2*BY)/3,BX,BY,AX,AY,#1)
   CALL RECURSIVE(N-1,(3*CX+2*BX-2*AX)/3,(3*CY+2*BY-2*AY)/3,(CX+2*BX)/3,(CY+2*BY)/3,CX,CY,#1)
END IF
END SUB
 

再帰図形

 投稿者：しばっち  投稿日：2012年10月21日(日)16時25分16秒
  PUBLIC NUMERIC L1,L2,LTH,RTH,XSIZE,YSIZE
PUBLIC STRING F$
LET XSIZE=600
LET YSIZE=600
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW  0 , XSIZE-1 , 0,YSIZE-1
SET POINT STYLE  1
SET COLOR MODE "REGULAR"
CLEAR
LET N=11
!'INPUT  PROMPT "LEVEL":N
LET L1=.6523
LET L2=.6523
LET LTH=45
LET RTH=17.5
!'LET F$="雲.svg"
IF F$<>"" THEN
   OPEN #1:NAME F$
   ERASE #1
   PRINT #1:"<?xml version=";CHR$(34);"1.0";CHR$(34);" encoding=";CHR$(34);"utf-8";CHR$(34);"?>"
   PRINT #1:"<!DOCTYPE svg PUBLIC ";CHR$(34);"-//W3C//DTD SVG 1.1//EN";CHR$(34);" ";CHR$(34);"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd";CHR$(34);" ["
   PRINT #1:" <!ENTITY ns_svg ";CHR$(34);"http://www.w3.org/2000/svg";CHR$(34);">"
   PRINT #1:" <!ENTITY ns_xlink ";CHR$(34);"http://www.w3.org/1999/xlink";CHR$(34);">"
   PRINT #1:"]>"
   PRINT #1:"<svg  version=";CHR$(34);"1.1";CHR$(34);" xmlns=";CHR$(34);"&ns_svg;";CHR$(34);" width=";CHR$(34);STR$(XSIZE);CHR$(34);" height=";CHR$(34);STR$(YSIZE);CHR$(34);" viewBox=";CHR$(34);"0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34)
   PRINT #1:" overflow=";CHR$(34);"visible";CHR$(34);" enable-background=";CHR$(34);"new 0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34);" xml:space=";CHR$(34);"preserve";CHR$(34);">"
END IF
CALL RECURSIVE(N,150,300,550,300,#1)
IF F$<>"" THEN
   PRINT #1:"</svg>"
   CLOSE #1
END IF
END

EXTERNAL  SUB RECURSIVE(N,X1,Y1,X2,Y2,#1)
IF N=0 THEN
   PLOT LINES: X1,Y1;X2,Y2
   IF F$<>"" THEN PRINT #1:"<line x1=";CHR$(34);STR$(INT(X1));CHR$(34);" y1=";CHR$(34);STR$(INT(YSIZE-Y1));CHR$(34);" x2=";CHR$(34);STR$(INT(X2));CHR$(34);" y2=";CHR$(34);STR$(INT(YSIZE-Y2));CHR$(34);" stroke=";CHR$(34);"black";CHR$(34);" stroke-width=";CHR$(34);"1";CHR$(34);"/>"
ELSE
   CALL RECURSIVE(N-1,X1,Y1,L1*(X2-X1)*COS(LTH*PI/180)-L1*(Y2-Y1)*SIN(LTH*PI/180)+X1,L1*(X2-X1)*SIN(LTH*PI/180)+L1*(Y2-Y1)*COS(LTH*PI/180)+Y1,#1)
   CALL RECURSIVE(N-1,L2*(X1-X2)*COS(-RTH*PI/180)-L2*(Y1-Y2)*SIN(-RTH*PI/180)+X2,L2*(X1-X2)*SIN(-RTH*PI/180)+L2*(Y1-Y2)*COS(-RTH*PI/180)+Y2,X2,Y2,#1)
END IF
END SUB
 

再帰図形

 投稿者：しばっち  投稿日：2012年10月21日(日)16時26分1秒
  PUBLIC NUMERIC L1,L2,LTH,RTH,XSIZE,YSIZE
PUBLIC STRING F$
LET XSIZE=600
LET YSIZE=600
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW  0 , XSIZE-1 , 0,YSIZE-1
SET POINT STYLE  1
SET COLOR MODE "REGULAR"
LET N=12
!'INPUT  PROMPT "LEVEL":N
LET L1=1/SQR(2)
LET L2=.5
LET LTH=90
LET RTH=0
!'LET F$="霜柱.svg"
IF F$<>"" THEN
   OPEN #1:NAME F$
   ERASE #1
   PRINT #1:"<?xml version=";CHR$(34);"1.0";CHR$(34);" encoding=";CHR$(34);"utf-8";CHR$(34);"?>"
   PRINT #1:"<!DOCTYPE svg PUBLIC ";CHR$(34);"-//W3C//DTD SVG 1.1//EN";CHR$(34);" ";CHR$(34);"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd";CHR$(34);" ["
   PRINT #1:" <!ENTITY ns_svg ";CHR$(34);"http://www.w3.org/2000/svg";CHR$(34);">"
   PRINT #1:" <!ENTITY ns_xlink ";CHR$(34);"http://www.w3.org/1999/xlink";CHR$(34);">"
   PRINT #1:"]>"
   PRINT #1:"<svg  version=";CHR$(34);"1.1";CHR$(34);" xmlns=";CHR$(34);"&ns_svg;";CHR$(34);" width=";CHR$(34);STR$(XSIZE);CHR$(34);" height=";CHR$(34);STR$(YSIZE);CHR$(34);" viewBox=";CHR$(34);"0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34)
   PRINT #1:" overflow=";CHR$(34);"visible";CHR$(34);" enable-background=";CHR$(34);"new 0 0 ";STR$(XSIZE);" ";STR$(YSIZE);CHR$(34);" xml:space=";CHR$(34);"preserve";CHR$(34);">"
END IF
CALL RECURSIVE(N,200,300,600,300,#1)
IF F$<>"" THEN
   PRINT #1:"</svg>"
   CLOSE #1
END IF
END

EXTERNAL  SUB RECURSIVE(N,X1,Y1,X2,Y2,#1)
IF N=0 THEN
   PLOT LINES: X1,Y1;X2,Y2
   IF F$<>"" THEN PRINT #1:"<line x1=";CHR$(34);STR$(INT(X1));CHR$(34);" y1=";CHR$(34);STR$(INT(YSIZE-Y1));CHR$(34);" x2=";CHR$(34);STR$(INT(X2));CHR$(34);" y2=";CHR$(34);STR$(INT(YSIZE-Y2));CHR$(34);" stroke=";CHR$(34);"black";CHR$(34);" stroke-width=";CHR$(34);"1";CHR$(34);"/>"
ELSE
   CALL RECURSIVE(N-1,X1,Y1,L1*(X2-X1)*COS(LTH*PI/180)-L1*(Y2-Y1)*SIN(LTH*PI/180)+X1,L1*(X2-X1)*SIN(LTH*PI/180)+L1*(Y2-Y1)*COS(LTH*PI/180)+Y1,#1)
   CALL RECURSIVE(N-1,L2*(X1-X2)*COS(-RTH*PI/180)-L2*(Y1-Y2)*SIN(-RTH*PI/180)+X2,L2*(X1-X2)*SIN(-RTH*PI/180)+L2*(Y1-Y2)*COS(-RTH*PI/180)+Y2,X2,Y2,#1)
END IF
END SUB
 

数値計算がおかしい？？

 投稿者：安田明  投稿日：2012年10月29日(月)06時40分40秒
  以下のプログラムを、１０進モードで実行すると　(9+6)/9*6が１０と認識されません！
２進モードでは正常です。
何が原因でしょうか？
十進BASICへの信頼がゆらいでます！


!   Check_DisplayABCD
!     ２進と１０進で実行すると異なる？？？
!              2201.10.29   06:00
!----------------------------------------------

Declare numeric A,B,C,D
LET A=9
LET B=6
LET C=9
LET D=6
PRINT  "(A+B)/C= ";(A+B)/C

PRINT  "(A+B)/C*D= ";(A+B)/C*D
PRINT
PRINT  "A=9,B=6,C=9,D=6 のとき"
If (A + B) / C * D = 10 Then
   PRINT  "(A + B) / C * D = 10 成立します"
ELSE
   PRINT "(A + B) / C * D = 10 成立しません"
End If
!---------------------------------------

LET A=9
LET B=6
LET C=3
LET D=2
PRINT
PRINT  "A=9,B=6,C=3,D=2 のとき"
If (A + B) / C * D = 10 Then
   PRINT  "(A + B) / C * D = 10 成立します"
ELSE
   PRINT "(A + B) / C * D = 10 成立しません"
End If

END
 		 

Re: 数値計算がおかしい？？

 投稿者：白石和夫  投稿日：2012年10月29日(月)15時59分17秒
  > No.2012[元記事へ]

十進BASICの利点は，近似計算のむずかしさを理解しやすいところにあります。
たとえば，1.66666666666666666666666667を6倍して10にならないことは容易に理解できると思います。

十進BASICのPRINT文は計算結果を丸めて表示しています。
計算結果をそのまま表示したいときは，
「オプション」メニューの「数値」で，「表示桁数を多く」にチェックしてください。

なお，
http://hp.vector.co.jp/authors/VA008683/QA3.htm
も参考にしてください。
 		 

Re: 数値計算がおかしい？？

 投稿者：山中和義  投稿日：2012年10月30日(火)11時09分55秒
  > No.2012[元記事へ]

安田明さんへのお返事です。

> １０進モードで実行すると　(9+6)/9*6が１０と認識されません！
> ２進モードでは正常です。

対策としては、
演算が有理数の範囲なら、有理数モードを使う。
浮動小数点では、
　IF (A + B) * D = 10 * C THEN
と極力割り算を避けるようにするのがいいと思います。
できない場合は、
　IF (A + B) * D / C  = 10 THEN
と最後に割り算を行うのがいいと思います。
（この場合のように割り切れる可能性があるが、オーバーフローが発生する場合もある）


逆の場合では、

例　0.1の内部値（10進法→2進法、10進法→10進法）
LET A=0.1
PRINT A
FOR i=1 TO 10
   LET S=S+A
NEXT i
PRINT S
IF S=1 THEN PRINT "1です。" ELSE PRINT "1でない。"
END
 		 

選挙制度の考察

 投稿者：GAI  投稿日：2012年11月 8日(木)13時35分40秒
  選挙でよくドント方式という言葉を耳にするのでこの仕組みについて、数値的に調べてみました。
投票者の最大数が各議席を支持することを保証する規則として
ベルギーの法律家、税専門家であったヴィクトル・ドント（1804～1901）
が提案したものがベースとなっている制度。
（詳しくはネットで調べて下さい。）

以下の調査は議員定数を１０人とした場合、Ａ，Ｂ，Ｃの政党への得票数に
従って、その政党の議員が何名になるかを適当な数値を使って集計したものになっています。
（エクセルで一つ一つ各得票数をn等分したのもを一欄にしてソートをかけて上から１０人選びました。）
議員の配当の変化を優先して調査したので、得票数の総計がまちまちになっております。
プログラムを上手く作れば、得票総数を一定にして、議員配当がどの様に変化していくのか、
議員定数が変われば、またそれに従っての得票数も変化するし、政党の数によっても変わる。
またその配当を許す得票数の幅などが見られると思うのですが、如何せん私にそのプログラム
を組み込む力量がありません。
この制度がどの様な仕組みなのかを、数値的に見てみたい。

この趣旨を汲んで頂き、プログラムのほどをよろしくお願いします。



得票数Ａ　：議員配当　　　得票数Ｂ：議員配当　　　得票数Ｃ：議員配当
　　　　　　（人）　　　　　　　　　（人）　　　　　　　　　（人）

1000：　1 　　　　　　1500：　1　　　　　　　　　8000：　8


1000：　1 　　　　　　1600：　1　　　　　　　　　7400：　8


1000：　1 　　　　　　1900：　2　　　　　　　　　7200：　7


1000：　1 　　　　　　2300：　2　　　　　　　　　6800：　7


1000：　1 　　　　　　2600：　2　　　　　　　　　6500：　7


1000：　1 　　　　　　2900：　3　　　　　　　　　6300：　6


1000：　1 　　　　　　3300：　3　　　　　　　　　5500：　6


1000：　1 　　　　　　3600：　4　　　　　　　　　5000：　5


1000：　2 　　　　　　1600：　3　　　　　　　　　2400：　5



 		 

Re: 選挙制度の考察

 投稿者：山中和義  投稿日：2012年11月 8日(木)18時47分36秒
  > No.2015[元記事へ]

GAIさんへのお返事です。

> 選挙でよくドント方式という言葉を耳にするのでこの仕組みについて、数値的に調べてみました。


!http://gakusyu.shizuoka-c.ed.jp/shakai/seiji/02_5_donto.htm

!http://www.liveway.net/technic/20090831_090404.html

LET N=9 !議席数
LET G=3 !政党数
DATA 120,90,60 !総得票数

!LET N=9 !議席数
!LET G=4 !政党数
!DATA 1000,700,600,280 !総得票数

DIM T(G)
MAT READ T

DIM W(G),D(G),S(G)
MAT W=T
MAT D=CON !1から
MAT S=ZER !各政党の議席獲得数
FOR i=1 TO N
!!!MAT PRINT W; !debug
!!!MAT PRINT D; !debug
   LET MX=W(1) !1人当たりの得票数が大きい順に
   LET P=1
   FOR J=2 TO G
      IF W(J)>MX THEN
         LET MX=W(J)
         LET P=J
      ELSEIF W(J)=MX THEN !同点の場合、割る数が小さいもの
         IF D(J)<D(P) THEN
            LET MX=W(J)
            LET P=J
         END IF
      END IF
   NEXT J
   PRINT i;": 政党=";P;W(P) !i人目
   LET S(P)=S(P)+1

   LET D(P)=D(P)+1 !整数で割る
   LET W(P)=T(P)/D(P)
NEXT i
MAT PRINT S;
PRINT


!計算に用いた表を表示する
LET MX=D(1)
FOR J=2 TO G
   IF D(J)>MX THEN LET MX=D(J)
NEXT J
FOR J=1 TO MX
   MAT W=(1/J)*T
   PRINT "÷";STR$(J);":";
   FOR i=1 TO G
      PRINT W(i);
   NEXT i
   PRINT
NEXT J

END


実行結果

1 : 政党= 1  120
2 : 政党= 2  90
3 : 政党= 3  60
4 : 政党= 1  60
5 : 政党= 2  45
6 : 政党= 1  40
7 : 政党= 3  30
8 : 政党= 2  30
9 : 政党= 1  30
4  3  2


÷1: 120  90  60
÷2: 60  45  30
÷3: 40  30  20
÷4: 30  22.5  15
÷5: 24  18  12

 		 

Re: 選挙制度の考察

 投稿者：GAI  投稿日：2012年11月 9日(金)16時55分49秒
  山中和義さんへのお返事です。

紹介して頂いたサイトでエクセルを動かしてみました。
政党の数や議員定数、得票数を自由に操作でき、たちどころに議員構成を見ることができました。

いやーエクセルも使いようですねー。
普段使用していてもほんの一部の機能しか利用していないのが痛いほどわかりました。
知れば知るほど知らないことだらけだと、知ります。

こんな情報がここに存在していることをどうやって探しているんですか？
私が行っている検索ではこんなサイトはひっかかりませんが・・・

いずれにしても、知りたいと思った事をこんなにも的確に解決して頂いたことに感謝いたします。 		 

関数でお絵かき

 投稿者：山中和義  投稿日：2012年11月16日(金)14時24分33秒
 
SET WINDOW -10,10,-10,10 !表示領域
DRAW grid !座標を描く

CALL fvLINE(2,-6, 3,4) !1　y=2x-6
CALL fvLINE(-3/2,9, 0,4) !2　y=(-3/2)x+9
CALL fvLINEH(2, -5,4) !3　y=2
CALL fvLINE(-1/5,2, -5,0) !4　y=(-1/5)+2
CALL fvLINEH(0, -3,3) !5　y=0
CALL fvLINEV(0, 2,9) !6　x=0
CALL fvLINE(6/5,9, -5,0) !7　y=(6/5)x+9
CALL fvLINE(-1,-3, -5,-3) !8　y=-x-3
CALL fvLINEH(3, 0,4) !9　y=3
CALL fvLINE(2/3,-10, 6,9) !10　y=(2/3)x-10
CALL fvLINEH(-6, -9,-8) !11　y=-6
CALL fvLINEV(-3, -8,-4) !12　x=-3
CALL fvCIRCLE(6.5,4.5,0.5, -10,10) !13　(x+6.5)^2+(y+4.5)^2=0.5^2
CALL fvLINEV(1, -8,-4) !14　x=1
CALL fvLINEH(-6, -5,6) !15　y=-6
CALL fvLINEV(9, -8,-4) !16　x=9
CALL fvLINE(-2/3,-2, 6,9) !17　y=(-2/3)x-2
CALL fvLINEV(-1, -8,-4) !18　x=-1
CALL fvLINEV(-5, -10,-2) !19　x=-5
CALL fvCIRCLE(5,6,4, -9,-5) !20　(x+5)^2+(y+6)^2=4^2

END


EXTERNAL SUB fvLINE(A,B, P,Q) !直線y=Ax+B, x∈[P,Q]
PLOT LINES: P,A*P+B; Q,A*Q+B
END SUB

EXTERNAL SUB fvLINE2(A,B, P,Q) !直線y=Ax+B（A≠0）, y∈[P,Q]
IF A=0 THEN
   PRINT "直線y=Ax+BでA=0です。"; A;B; P;Q
   STOP
ELSE
   PLOT LINES: (P-B)/A,P; (Q-B)/A,Q
END IF
END SUB

EXTERNAL SUB fvLINEH(B, P,Q) !水平線y=B, x∈[P,Q]
PLOT LINES: P,B; Q,B
END SUB

EXTERNAL SUB fvLINEV(A, P,Q) !垂直線x=A, y∈[P,Q]
PLOT LINES: A,P; A,Q
END SUB

EXTERNAL SUB fvCIRCLE(A,B,R, P,Q) !円 (x+A)^2+(y+B)^2=R^2, x∈[P,Q]　※中心(-A,-B)、半径R
FOR x=P TO Q STEP 0.01 !上側
   WHEN EXCEPTION IN
      PLOT LINES: x,SQR(R^2-(x+A)^2)-B;
   USE
      PLOT LINES
   END WHEN
NEXT x
PLOT LINES
FOR x=P TO Q STEP 0.01 !下側
   WHEN EXCEPTION IN
      PLOT LINES: x,-SQR(R^2-(x+A)^2)-B;
   USE
      PLOT LINES
   END WHEN
NEXT x
PLOT LINES
END SUB

EXTERNAL SUB fvFNC2(A,B,C, P,Q) !2次関数y=A(x+B)^2+C, x∈[P,Q]　※軸x=-B、頂点(-B,C)
FOR x=P TO Q STEP 0.01
   PLOT LINES: x,A*(x+B)^2+C;
NEXT x
PLOT LINES
END SUB
 

誘導電動機特性計算

 投稿者：島村1243  投稿日：2012年11月17日(土)14時20分4秒
  ! 三相誘導電動機  かご形と巻線形のトルク・電流特性図作成プログラム
!--JEC37 Ｌ型等価回路に依る誘導電動機の特性計算
!--電動機電流は励磁電流を含む

LET nmax=5000
DIM slip(nmax),Pm(nmax), Tm(nmax), CR(nmax)
DIM pf(nmax), TL(nmax),Pin(nmax),Pout(nmax),eff(nmax)
SET WINDOW 1,0,-0.4,4
DRAW grid(0.1,1)

!****ここから、計算データの入力****************
!  *** 定格データ
LET Pr =22.0      !定格出力[kW]
LET Vr =200       !定格線間電圧[V]
LET Ir =85        !定格電流[A]
LET Hz =50        !定格周波数[Hz]
LET pole=4        !極数
LET Nr=1450       !定格回転数[rpm]
LET ic$="E"       !絶縁種別
LET FM$="K1"    !型式 W=巻線形、 C=普通かご形、K1=特殊かご形1種、K2=特殊かご形2種

!  **** 無負荷試験（Noload_Test）データ
LET I0=28.7     !無負荷電流[A]
LET W0=680      !無負荷入力[W]

!  **** 拘束試験データ (100%周波数)
LET Id=85       !拘束電流[A]
LET Vd=50.6     !拘束電圧[V]
LET Wd=3036     !拘束電力[W]

!  **** 拘束試験データ (50%周波数)
LET Idd=85       !拘束電流[A]
LET Vdd=29.8     !拘束電圧[V]
LET Wdd=2319     !拘束電力[W]

!  **** 一次・二次巻線抵抗（線間）  温度(Cﾟ) ****
LET R1at=0.1007  !周囲温度における一次巻線抵抗[Ω]
!R2at=           !周囲温度における二次巻線抵抗[Ω]
LET Ta=20        !測定周囲温度

!  **** 負荷トルク特性設定 ****
LET Ltorq_ID=2    !１は定トルク、２は2乗トルク
LET Tpu=1.0       !定格滑りにおける全負荷トルクの割合指定[pu]
!**********ここまで************************************

LET ds=1/nmax
LET sqr3=sqr(3)
LET pai=3.14159
LET Er=Vr/sqr3   !Ｙ換算定格相電圧[V]
LET Ed=Vd/sqr3
LET Edd=Vdd/sqr3
LET TmR=Pr*1000/2/PI/Nr*60 !定格トルク[N.m]

If ic$ = "A" Or ic$ = "B" Or ic$ = "E" Then !基準温度上昇は75度設定
   LET Tb = 310 !'=235+75
   LET Kr=1
ElseIf ic$ = "F" Then !基準温度上昇は115度設定
   LET Tb = 350 !'=235+115
   LET Kr=1.13
Else
   pause  "絶縁種別記号が誤っています。"
   STOP
END IF
LET N0 = 120 * Hz / pole !同期速度[rpm]
LET Tr = Pr*1000/(2*pai*Nr/60) !定格トルク[N-m]
LET R1 = R1at / 2 * Tb / (235 + Ta)
LET y0 = I0 / Er
LET g0 = W0 / Vr / Vr
LET b0 = Sqr(y0 * y0 - g0 * g0)
LET Zd = Ed / Id
LET Rd = Wd / 3 / Id / Id
LET Rd1=Rd
LET Xd = Sqr(Zd * Zd - Rd * Rd)
LET Xd1=Xd

IF FM$="K1" Or FM$="K2" Then
   LET Zdd = Edd / Idd
   LET Rdd = Wdd / 3 / Idd / Idd
   LET Rd2=Rdd
   LET Xdd = Sqr(Zdd ^ 2 - Rdd ^ 2)
   LET Xd2=2*Xdd
   LET h = ( Xd2 - Xd1) / (Rd1 - Rd2)
   LET m = (4 + h * h) / 3
   IF h<1 Then LET km=1.6
   IF h>=1 Then LET km=m
   LET Rd3=Rd1-km*(Rd1-Rd2)
   LET Xd3=Xd1+km*(Xd2-Xd1)
End IF
LET kv = 1
LET kz = 1

!計算滑りsを設定し特性を計算
FOR kk = 1 TO nmax    !滑りをds[pu]刻みで1.0[pu]まで計算
   LET s =ds * kk
   Call enzan2
NEXT kk
Call sakuzu


Sub enzan2 !---滑りｓ時のモータ特性及び負荷トルク計算----
    !モータ定数計算方法は電気工学ハンドブック（昭和５３年版）722頁２章2.1.1に依る。
    IF FM$ = "C" Or FM$ = "W" Then
       LET X = Xd1
       LET R = kr * Rd1
    ElseIF FM$ = "K1" Or FM$ = "K2" Then
       IF s<=0.2 Then
          LET R=kr*Rd3
          LET X=Xd3
       ElseIF s<=0.5 Then
          LET R = kr * (Rd2 -(0.5-s)/0.3* (Rd2 - Rd3))
          LET X = Xd2 +(0.5-s)/0.3* (Xd3 - Xd2)
       Else
          LET R = kr * (Rd1 -(1-s)/0.5* (Rd1 - Rd2))
          LET X = Xd1 +(1-s)/0.5* (Xd2 - Xd1)
       End IF
    Else
       pause  "電動機の形式記号が誤りです。半角でＣ、Ｗ、Ｋ１又はＫ２を入力して下さい。"
       STOP
    End If

    LET g = R / (R * R + X * X)
    LET b = X / (R * R + X * X)
    LET g12 = g - g0
    LET b12 = b - b0
    LET R2 = g12 / (g12 * g12 + b12 * b12) - R1
    LET R12s = R1 + R2 / s
    LET X12 = b12 / (g12 * g12 + b12 * b12)
    LET Z12s = Sqr(R12s ^ 2 + X12 ^ 2)
    LET I2 = kv * Er / Z12s / kz
    LET I2r = I2 * R12s / Z12s
    LET I2x = I2 * X12 / Z12s
    LET I0r = kv * Er * g0 / kz
    LET I0x = kv *Er * b0 / kz
    LET I1 = Sqr((I0r + I2r) ^ 2 + (I0x + I2x) ^ 2)
    LET P2 = 3 *kz* R2/ s * I2 ^ 2
    LET Mtorq = P2/(2*pai*N0/60)
    IF Ltorq_ID =1 Then
       LET Ltorq = Tr * Tpu
    ELSEIF Ltorq_ID =2 THEN
       LET Ltorq = Tr * ((1 - s) * N0 / Nr) ^ 2 * Tpu
    End IF

    !'*** 特性図作画用出力データの一時記憶 ***
    LET TL(kk) = Ltorq
    LET slip(kk)=s
    LET Pm(kk) = (1 - s) * P2 / 1000
    LET Tm(kk) = Mtorq
    LET TL(kk)=Ltorq
    LET CR(kk) = I1
    LET pf(kk) = (I0r + I2r) / I1
    LET Pin(kk) = 3 * kv * Er * I1 * pf(kk) / 1000
    LET Pout(kk) =2 *pai *N0 /60 * (1 - s) * Tm(kk) / 1000
    LET eff(kk)= Pout(kk)/Pin(kk)
End Sub

Sub sakuzu !---特性曲線作図
    !---電動機トルク曲線---
    FOR kk=1 TO nmax
       LET s=kk*ds
       PLOT LINES:s,Tm(kk)/TmR;
    NEXT kk
    PLOT LINES
    !---電動機電流曲線---
    SET LINE COLOR "red"
    FOR kk=1 TO nmax
       LET s=kk*ds
       PLOT LINES:s,CR(kk)/Ir;
    NEXT kk
    PLOT LINES
    !---負荷トルク曲線---
    SET LINE COLOR "green"
    FOR kk=1 TO nmax
       LET s=kk*ds
       PLOT LINES:s,TL(kk)/TmR;
    NEXT kk
    PLOT LINES
    !横軸線の描画
    SET LINE COLOR "black"
    PLOT LINES:1,0;0,0
    PLOT TEXT,AT 0.4,3.8:"赤：電動機電流[pu]"
    PLOT TEXT,AT 0.4,3.6:"黒：電動機トルク[pu]"
    PLOT TEXT,AT 0.4,3.4:"緑：負荷トルク[pu]"
    PLOT TEXT,AT 0.55,-0.35:"滑りs[pu] <---"
    pause "作図完了です。"
End Sub

End 		 

Re: 魔方陣(奇数)

 投稿者：山中和義  投稿日：2012年12月 9日(日)10時04分59秒
  > No.1710[元記事へ]

> 魔方陣(奇数 魔方陣のみ)
> N * N 方陣において1～N^2までの数字を全て使用し、各縦、横、斜めの列の和が全て同じ

行列の演算で求めてみました。


!奇数の魔方陣

!行列Mのつくり方
!n×nの場合
!右斜めの対角線に、数字(n-1)/2を入れる。
!これを基準に右斜めに数字が揃うように、0から(n-1)までの数字を順に埋めていく。
!3 4 … n-1 0 1 2
!4 … n-1 0 1 2 3
!　：
!0 1 2 3 4 … n-1
!1 2 3 4 … n-1 0
!2 3 4 … n-1 0 1
!　：

LET N=9

DIM X(N,N) !行や列の並びを反転させる
MAT X=ZER
FOR i=1 TO N
   LET X(N-i+1,i)=1
NEXT i
PRINT "行列X（この行列は、「行列の演算」で実現するために用いる）"
MAT PRINT X; !debug
PRINT "として、"
PRINT

DIM M(N,N)
FOR i=1 TO N
   FOR J=1 TO N
      LET M(i,J)=MOD((i+INT((N-1)/2))+(J-1),N)
   NEXT J
NEXT i
PRINT "行列M"
MAT PRINT M; !debug

DIM B(N,N)
MAT B=M*X
MAT B=TRN(B)
PRINT "と、行列M*Xの転置行列(M*X)^t、すなわち、Mを反時計まわりに90度回転したもの"
MAT PRINT B; !debug
MAT B=(N)*B
PRINT "を、";N;"倍したもの（n*(M*X)^t）"
MAT PRINT B; !debug
MAT M=M+B
PRINT "を足す。（M+n*(M*X)^t）"
PRINT
MAT PRINT M;


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

DIM F(0 TO N*N-1) !数字の使用回数
MAT F=ZER
FOR i=1 TO N
   FOR J=1 TO N
      LET T=M(i,J)
      IF F(T)=1 THEN !相異なるものかどうか
         PRINT T;"が重複します。"
         STOP
      END IF
      LET F(T)=1 !「使用」とする
   NEXT J
NEXT i

DIM W(N,1) !行の和
MAT W=CON !(1,1,1,…,1)^t
MAT W=M*W !内積をとる
MAT PRINT W;

DIM Y(1,N) !列の和
MAT Y=CON
MAT Y=Y*M
MAT PRINT Y;


PRINT tr(M)!左斜め対角線の和 tr(M)

LET T=0 !左斜め対角線の和
FOR i=1 TO N
   LET T=T+M(N-i+1,i)
NEXT i
PRINT T

END

EXTERNAL FUNCTION tr(A(,)) !行列Aのトレース　※左斜め対角線の和
LET T=0
FOR i=0 TO MIN(SIZE(A,1),SIZE(A,2))-1
   LET T=T+A(i+LBOUND(A,1),i+LBOUND(A,2))
NEXT i
LET tr=T
END FUNCTION


実行結果

行列X（この行列は、「行列の演算」で実現するために用いる）
0  0  0  0  0  0  0  0  1
0  0  0  0  0  0  0  1  0
0  0  0  0  0  0  1  0  0
0  0  0  0  0  1  0  0  0
0  0  0  0  1  0  0  0  0
0  0  0  1  0  0  0  0  0
0  0  1  0  0  0  0  0  0
0  1  0  0  0  0  0  0  0
1  0  0  0  0  0  0  0  0

として、

行列M
5  6  7  8  0  1  2  3  4
6  7  8  0  1  2  3  4  5
7  8  0  1  2  3  4  5  6
8  0  1  2  3  4  5  6  7
0  1  2  3  4  5  6  7  8
1  2  3  4  5  6  7  8  0
2  3  4  5  6  7  8  0  1
3  4  5  6  7  8  0  1  2
4  5  6  7  8  0  1  2  3

と、行列M*Xの転置行列(M*X)^t、すなわち、Mを反時計まわりに90度回転したもの
4  5  6  7  8  0  1  2  3
3  4  5  6  7  8  0  1  2
2  3  4  5  6  7  8  0  1
1  2  3  4  5  6  7  8  0
0  1  2  3  4  5  6  7  8
8  0  1  2  3  4  5  6  7
7  8  0  1  2  3  4  5  6
6  7  8  0  1  2  3  4  5
5  6  7  8  0  1  2  3  4

を、 9 倍したもの（n*(M*X)^t）
36  45  54  63  72  0  9  18  27
27  36  45  54  63  72  0  9  18
18  27  36  45  54  63  72  0  9
9  18  27  36  45  54  63  72  0
0  9  18  27  36  45  54  63  72
72  0  9  18  27  36  45  54  63
63  72  0  9  18  27  36  45  54
54  63  72  0  9  18  27  36  45
45  54  63  72  0  9  18  27  36

を足す。（M+n*(M*X)^t）

41  51  61  71  72  1  11  21  31
33  43  53  54  64  74  3  13  23
25  35  36  46  56  66  76  5  15
17  18  28  38  48  58  68  78  7
0  10  20  30  40  50  60  70  80
73  2  12  22  32  42  52  62  63
65  75  4  14  24  34  44  45  55
57  67  77  6  16  26  27  37  47
49  59  69  79  8  9  19  29  39

360
360
360
360
360
360
360
360
360

360  360  360  360  360  360  360  360  360

360
360

 		 

Re: 魔方陣(3×3、4×4)

 投稿者：山中和義  投稿日：2012年12月12日(水)11時05分25秒
  > No.2175[元記事へ]

●3×3
3つの3つ組で等差数列を考える。
代数で表すと、
　a      a   +x   a   +2x
　a +y   a+ y+x   a+ y+2x
　a+2y   a+2y+x   a+2y+2x
となる。
たとえば、カレンダーの数字の並びである。
　                   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
　30 31
　横方向の公差、すなわちx=1
　縦方向の公差、すなわちy=7

左上から順に1番目の数字、2番目の数字、…、9番目の数字として、
3×3の魔方陣の並び
　1 2 3　　　2 9 4
　4 5 6　→　7 5 3
　7 8 9　　　6 1 8
に対応させて並べる。

応用
素数による魔方陣は、
　　→12
　↓　 5  17  29
　42　47  59  71
　　　89 101 113
と選んで、
　17 113  47　　魔法数=177
　89  59  29
　71   5 101
とする。

●4×4
4つの4つ組で等差数列を考える。
代数で表すと、
　a      a   +x   a   +2x   a   +3x
　a +y   a+ y+x   a+ y+2x   a+ y+3x
　a+2y   a+2y+x   a+2y+2x   a+2y+3x
　a+3y   a+3y+x   a+3y+2x   a+3y+3x
となる。
左上から順に1番目の数字、2番目の数字、…、16番目の数字として、
4×4の魔方陣の並び
　 1  2  3  4　　　 1 15 14  4
　 5  6  7  8　→　12  6  7  9
　 9 10 11 12　　　 8 10 11  5
　13 14 15 61　　　13  3  2 16
に対応させて並べる。


!等差数列の魔方陣

LET a=13
LET x=1
LET y=7

PRINT a     ; a+x     ; a+2*x
PRINT a+y   ; a+y+x   ; a+y+2*x
PRINT a+2*y ; a+2*y+x ; a+2*y+2*x
PRINT

PRINT a+x     ; a+2*y+2*x ; a+y
PRINT a+2*y   ; a+y+x     ; a+2*x
PRINT a+y+2*x ; a         ; a+2*y+x
PRINT "魔法数="; 3*(a+y+x)

PRINT


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

LET a=3
LET x=1
LET y=7

PRINT a     ; a+x     ; a+2*x     ; a+3*x
PRINT a+y   ; a+y+x   ; a+y+2*x   ; a+y+3*x
PRINT a+2*y ; a+2*y+x ; a+2*y+2*x ; a+2*y+3*x
PRINT a+3*y ; a+3*y+x ; a+3*y+2*x ; a+3*y+3*x
PRINT

PRINT a         ; a+3*y+2*x ; a+3*y+x   ; a+3*x
PRINT a+2*y+3*x ; a+y+x     ; a+y+2*x   ; a+2*y
PRINT a+y+3*x   ; a+2*y+x   ; a+2*y+2*x ; a+y
PRINT a+3*y     ; a+2*x     ; a+x       ; a+3*y+3*x
PRINT "魔法数="; 2*(2*a+3*y+3*x)

END

 		 

再帰図形ジェネレータ

 投稿者：しばっち  投稿日：2012年12月16日(日)14時48分15秒
  PUBLIC NUMERIC NN,XX,YY,RR,X(20),Y(20),L(20),R(20),S(20)
LET MODE=0
SELECT CASE MODE
CASE 0
   RESTORE 1 !'この行番号を直接書き換えてください
   READ NN
   FOR I=1 TO NN
      READ X(I),Y(I) !'座標データ 始点(0,0)から終点(1,0)へ
   NEXT I
   READ XS,XE,YS,YE  !'WINDOW設定
   FOR I=1 TO NN-1
      READ S(I) !'符号反転(1 or -1)
   NEXT I
1    DATA 5
     DATA 0,0, .333333,0, .5,.288675134594813, .666666,0, 1,0 !'コッホ曲線
     DATA -.1,1.1,-.6,.6
     !'DATA 1,1,1,1
     DATA 1,-1,1,-1   !'変形コッホ
     !'DATA 1,-1,-1,1 !'変形コッホ
     !'DATA 1,1,-1,-1 !'変形コッホ
     !'----------------------------------------------------------
2    DATA 3
     DATA 0,0,.5,.5,1,0 !'C曲線
     DATA -.5,1.5,-1,1
     DATA 1,1 !'C曲線
     !'DATA 1,-1 !'ドラゴン曲線
     !'----------------------------------------------------------
3    DATA 6
     DATA 0,0, .33333,0, .33333,.33333, .66666,.33333, .66666,0, 1,0
     DATA -.1,1.1,-.6,.6
     !'DATA 1,1,1,1,1
     DATA 1,-1,1,-1,1
     !'DATA 1,1,-1,1,1
     !'----------------------------------------------------------
4    DATA 8
     DATA 0,0, .25,0, .25,.25, .5,.25, .5,-.25,.75,-.25,.75,0, 1,0
     DATA -.1,1.1,-.6,.6
     DATA 1,1,1,1,1,1,1
     !'----------------------------------------------------------
5    DATA 5
     DATA 0,0,.26500453458963,0,.3,.4, .33499546541037,0,1,0 !'森
     DATA -.1,1.1,-.6,.6
     DATA 1,1,1,1
     !'----------------------------------------------------------
6    DATA 7
     DATA 0,0,.2,0,.2,.2,.4,.2,.4,-.2,.8,-.2,1,0 !'さんご礁
     DATA -.1,1.1,-.6,.6
     DATA 1,1,1,1,1,1
     !'----------------------------------------------------------
7    DATA 6
     DATA 0,0,.12,0,.12,.2078,.53,.2078,.53,0,1,0 !'ひび割れた岩?
     DATA -.1,1.1,-.6,.6
     DATA 1,1,1,1,1
     !'----------------------------------------------------------
8    DATA 13
     DATA 0,0,.1870534607777,0,.319320231338024,-.132266770560324,.5,-.18067976866193,.680679768661883,-.132266770560324,.812946539222206,0,.680679768661883,.132266770560324,.5,.18067976866193,.319320231338023,.132266770560324,.451587001898347,0,.632266770560277,-4.84129981016061E-2,.812946539222206,0,1,0
     DATA -.1,1.1,-.6,.6
     DATA 1,1,1,1,1,1,1,1,1,1,1,1
     !'----------------------------------------------------------
9    DATA 5
     DATA 0,0,.5,0,.5,.3333333,.5,0,1,0
     DATA -.1,1.1,-.6,.6
     DATA 1,1,1,1
     !'----------------------------------------------------------
10    DATA 4
      DATA 0,0,.25,.433012,.75,.433012,1,0
      DATA -.5,1.5,-1,1
      DATA 1,1,1
      !'----------------------------------------------------------
11    DATA 10
      DATA  0,0,0 ,-.2928932188 , .103553390588518 ,-.396446609388518 , .396446609388518 ,-.396446609388518 , .5 ,-.2928932188 , .5, .2928932188 , .603553390565553 , .396446609388518 , .896446609365553 , .396446609388518 ,1,.2928932188,1,0
      DATA -.5,1.5,-1,1
      DATA 1,1,1,1,1,1,1,1,1,1
      !'----------------------------------------------------------
12    DATA 7
      DATA 0,0,.292893218813,0, .292893218813 ,.292893218813 , .5 ,8.57864376267724E-2 , .707106781185455 ,.292893218813 , .707106781185455 , 0 , 1,0
      DATA -.1,1.1,-.6,.6
      DATA 1,1,1,1,1,1
      !'----------------------------------------------------------
13    DATA 9
      DATA 0,0, .211324865405187 , 0 , .394337567297406 ,.105662432702593 , .5 ,.288675134594813 , .5 ,.5 , .5 ,.288675134594813 , .605662432702593 ,.105662432702593 , .788675134594812 , 0 , 1, 0
      DATA -.1,1.1,-.6,.6
      DATA 1,1,1,1,1,1,1,1
      !'----------------------------------------------------------
      !'ここにDATA文を追加してください
      !'----------------------------------------------------------
   CASE 1 !'乱数によりデータ生成
      RANDOMIZE
      LET NN=INT(RND*4)+3
      LET X(1)=0 !'始点
      LET Y(1)=0
      LET S(1)=1-INT(RND*2)*2
      FOR I=2 TO NN-1
         LET X(I)=RND
         LET Y(I)=RND-.4
         LET S(I)=1-INT(RND*2)*2
      NEXT I
      LET X(NN)=1 !'終点
      LET Y(NN)=0
      LET XS=-.5  !'WINDOW設定
      LET XE=1.5
      LET YS=-1
      LET YE=1
      PRINT "DATA";NN !'このDATA文を「ここに..」に追加してください
      PRINT "DATA";
      FOR I=1 TO NN-1
         PRINT X(I);",";Y(I);",";
      NEXT I
      PRINT X(NN);",";Y(NN)
      PRINT "DATA ";XS;",";XE;",";YS;",";YE
      PRINT "DATA ";
      FOR I=1 TO NN-2
         PRINT S(I);",";
      NEXT I
      PRINT S(NN-1)
   END SELECT
   FOR I=1 TO NN-1
      LET R(I)=ANGLE(X(I+1)-X(I),Y(I+1)-Y(I))-RR
      LET RR=RR+R(I)
      LET L(I)=SQR((X(I)-X(I+1))^2+(Y(I+1)-Y(I))^2)
   NEXT I
   IF MOD(RR,2*PI)<>0 THEN LET R(NN)=-RR
   SET WINDOW  XS,XE,YE,YS
   SET POINT STYLE  1
   SET COLOR MODE "REGULAR"
   FOR N=2 TO 6
      CLEAR
      DRAW GRID(.1,.1)
      LET RR=0
      LET XX=0
      LET YY=0
      CALL RECURSIVE(N,1,1)
      WAIT DELAY 1
   NEXT N
END

EXTERNAL  SUB RECURSIVE(N,LL,SIGN)
   IF N=0 THEN
      PLOT LINES: XX,YY;
      LET XX=XX+LL*COS(RR)
      LET YY=YY-LL*SIN(RR)
      PLOT LINES: XX,YY
   ELSE
      FOR I=1 TO NN-1
         LET RR=RR+R(I)*SIGN
         CALL RECURSIVE(N-1,LL*L(I),S(I))
      NEXT I
      IF R(NN)<>0 THEN LET RR=RR+R(NN)*SIGN
   END IF
END SUB
 		 

おまけ

 投稿者：しばっち  投稿日：2012年12月16日(日)14時49分12秒
  RESTORE 1 !'この行番号を直接書き換えてください
READ NN
DIM X(NN),Y(NN),S(NN),R(NN),L(NN)
FOR I=1 TO NN
   READ X(I),Y(I) !'座標データ 始点(0,0)から終点(1,0)へ
NEXT I
READ XS,XE,YS,YE !'WINDOW設定
FOR I=1 TO NN-1
   READ S(I) !'符号反転(1 or -1)
NEXT I
1 DATA 5
  DATA 0,0, .333333,0, .5,.288675134594813, .666666,0, 1,0 !'コッホ曲線
  DATA -.1,1.1,-.6,.6
  !'DATA 1,1,1,1
  DATA 1,-1,1,-1 ! '変形コッホ
  !'DATA 1,-1,-1,1 '変形コッホ
  !'DATA 1,1,-1,-1 '変形コッホ
  !'----------------------------------------------------------
2 DATA 3
  DATA 0,0,.5,.5,1,0 !'C曲線
  DATA -.5,1.5,-1,1
  DATA 1,1 !'C曲線
  !'DATA 1,-1 !'ドラゴン曲線
  !'----------------------------------------------------------
3 DATA 6
  DATA 0,0, .33333,0, .33333,.33333, .66666,.33333, .66666,0, 1,0
  DATA -.1,1.1,-.6,.6
  !'DATA 1,1,1,1,1
  DATA 1,-1,1,-1,1
  !'DATA 1,1,-1,1,1
  !'----------------------------------------------------------
  !'ここにDATA文を追加してください
  !'----------------------------------------------------------
  FOR I=1 TO NN-1
     LET R(I)=ANGLE(X(I+1)-X(I),Y(I+1)-Y(I))-RR
     LET RR=RR+R(I)
     LET L(I)=SQR((X(I)-X(I+1))^2+(Y(I+1)-Y(I))^2)
  NEXT I
  IF MOD(RR,2*PI)<>0 THEN LET R(NN)=-RR
  !' 再帰図形プログラムの書き出し
  PRINT "PUBLIC NUMERIC X,Y,R"
  PRINT "SET WINDOW ";XS;",";XE;",";YE;",";YS
  PRINT "SET POINT STYLE  1"
  PRINT "SET COLOR MODE ";CHR$(34);"REGULAR";CHR$(34)
  PRINT "DRAW GRID(.1,.1)"
  PRINT "INPUT  PROMPT ";CHR$(34);"LEVEL=";CHR$(34);": N"
  PRINT "CALL RECURSIVE(N,1,1)"
  PRINT "END"
  PRINT
  PRINT "EXTERNAL SUB RECURSIVE(LEV,L,SIGN)"
  PRINT "IF LEV=0 THEN"
  PRINT "PLOT LINES: X,Y;"
  PRINT "LET  X=X+L*COS(RAD(R))"
  PRINT "LET  Y=Y-L*SIN(RAD(R))"
  PRINT "PLOT LINES: X,Y"
  PRINT "ELSE"
  FOR I=1 TO NN-1
     IF R(I)<>0 THEN
        IF R(I)>0 THEN PRINT "R=R+"; ELSE PRINT "R=R-";
        PRINT STR$(ABS(DEG(R(I))));"*SIGN"
     END IF
     PRINT "CALL RECURSIVE(LEV-1,L*";STR$(L(I));",";STR$(S(I));")"
  NEXT I
  IF R(NN)<>0 THEN
     IF R(NN)>0 THEN PRINT "R=R+"; ELSE PRINT "R=R-";
     PRINT STR$(ABS(DEG(R(NN))));"*SIGN"
  END IF
  PRINT "END IF"
  PRINT "END SUB"
END
 		 

かけ算魔方陣

 投稿者：山中和義  投稿日：2012年12月17日(月)15時18分57秒
  > No.2182[元記事へ]

等比数列による積の魔方陣（かけ算魔方陣）

参考サイト　http://www.junko-k.com/mondai/mondai147.htm

!●3×3
!3つの3つ組で等比数列を考える。
!代数で表すと、
!　1     a      a^2
!　b     ab     a^2b
!　b^2   ab^2   a^2b^2
!となる。
!左上から順に1番目の数字、2番目の数字、…、9番目の数字として、
!3×3の魔方陣の並び
!　1 2 3　　　2 9 4
!　4 5 6　→　7 5 3
!　7 8 9　　　6 1 8
!に対応させて並べる。

LET N=3
DATA 2,9,4 !3×3の魔方陣
DATA 7,5,3
DATA 6,1,8

DIM M(N^2)
MAT READ M

LET A=2
LET B=3
FOR K=1 TO N^2
   LET W=M(K)-1 !等比数列の位置（i行J列）
   LET i=INT(W/N)
   LET J=MOD(W,N)
   PRINT B^i*A^J; !その値
   IF MOD(K,N)=0 THEN PRINT
NEXT K

END


実行結果

2  36  3
9  6  4
12  1  18



●4×4
4つの4つ組で等比数列を考える。
代数で表すと、
　1     a      a^2      a^3
　b     ab     a^2b     a^3b
　b^2   ab^2   a^2b^2   a^3b^2
　b^3   ab^3   a^2b^3   a^3b^3
となる。
左上から順に1番目の数字、2番目の数字、…、16番目の数字として、
4×4の魔方陣の並び
　 1  2  3  4　　　 1 15 14  4
　 5  6  7  8　→　12  6  7  9
　 9 10 11 12　　　 8 10 11  5
　13 14 15 61　　　13  3  2 16
に対応させて並べる。


LET N=4
DATA  1,15,14, 4 !4×4の魔方陣
DATA 12, 6, 7, 9
DATA  8,10,11, 5
DATA 13, 3, 2,16

とすればよい。



べき乗数による積の魔方陣（かけ算魔方陣）


!●3×3
!べき乗数A^Kの指数Kを、
!3×3の魔方陣の並び
!　2 9 4
!　7 5 3
!　6 1 8
!に対応させて考える。
!「積が一定」は、指数の和（参考. 対数）を一定すれば良いことになる。

LET N=3
DATA 2,9,4 !3×3の魔方陣
DATA 7,5,3
DATA 6,1,8

DIM M(N^2)
MAT READ M

LET A=2
FOR i=1 TO N^2
   PRINT A^(M(i)-1);
   IF MOD(i,N)=0 THEN PRINT
NEXT i

END


実行結果

2  256  8
64  16  4
32  1  128


4×4の魔方陣も同様である。
 		 

驚異の世界

 投稿者：GAI  投稿日：2012年12月19日(水)20時45分25秒
  | 17,171,126, 54,230,100, 93,264,145|
|124, 66,290, 85, 57,168,162, 23,225|
|216,115, 75,279,198, 29,170, 76, 42|
|261,186, 33,210, 68, 38,200,135, 69|
| 50,270, 92, 87,248,165, 21,153,114|
|105, 51,152,150, 27,207,116, 62,330|
|138, 25,243,132, 58,310, 95, 63,136|
|190, 84, 34,184,125, 81,297,174, 31|
| 99,232,155, 19,189,102, 46,260,108|

の９×９マトリックスを調べてみて下さい。　　 		 

Re: 驚異の世界

 投稿者：山中和義  投稿日：2012年12月20日(木)11時52分24秒
  > No.2252[元記事へ]

GAIさんへのお返事です。

> ９×９マトリックスを調べてみて下さい。

DATA  17,171,126, 54,230,100, 93,264,145
DATA 124, 66,290, 85, 57,168,162, 23,225
DATA 216,115, 75,279,198, 29,170, 76, 42
DATA 261,186, 33,210, 68, 38,200,135, 69
DATA  50,270, 92, 87,248,165, 21,153,114
DATA 105, 51,152,150, 27,207,116, 62,330
DATA 138, 25,243,132, 58,310, 95, 63,136
DATA 190, 84, 34,184,125, 81,297,174, 31
DATA  99,232,155, 19,189,102, 46,250,108

和と積の魔方陣である。
使われている数字は、
17,19,21,23,25,27,29,31,33を元に、1,2,3,4,5,6,8,9,10倍したものである。

17*1  19*9  21*6  27*2  23*10 25*4  31*3  33*8  29*5
31*4  33*2  29*10 17*5  19*3  21*8  27*6  23*1  25*9
27*8  23*5  25*3  31*9  33*6  29*1  17*10 19*4  21*2
29*9  31*6  33*1  21*10 17*4  19*2  25*8  27*5  23*3
25*2  27*10 23*4  29*3  31*8  33*5  21*1  17*9  19*6
21*5  17*3  19*8  25*6  27*1  23*9  29*4  31*2  33*10
23*6  25*1  27*9  33*4  29*2  31*10 19*5  21*3  17*8
19*10 21*4  17*2  23*8  25*5  27*3  33*9  29*6  31*1
33*3  29*8  31*5  19*1  21*9  17*6  23*2  25*10 27*4
 		 

倍数の判定

 投稿者：山中和義  投稿日：2012年12月24日(月)12時21分37秒
  問題
1,12,123,1234,12345,123456,1234567,12345678,123456789,1234567890,12345678901,123456789012, …
となる数字の並びの数が素数となるものを見つけよ。

答え
xは非負整数、yは1から9までの数とする。
{1234567890}がx個と1からyまでの数字が並んだ(10x+y)桁の数は、
　{1234567890} … {1234567890}123…y
　　　└── x個 ──┘
と表される。
まず、一の位が0,2,4,6,8のとき、2の倍数。　0,5のとき、5の倍数
各桁の数の和から、3,9のとき、3の倍数
よって、1,7の場合を検証すればよい。
（終り）

次の桁数が予想される。
1の場合、31, 111, 121, 141, 161, 171, 191, …
7の場合、157, 167, 187, …


OPTION ARITHMETIC RATIONAL !多桁の整数

LET y=1
FOR x=0 TO 20
!!LET K=9*x+y
!!LET N=INT(10^K*123456789/999999999) !123456789123…の一般項
   LET K=10*x+y
   LET N=INT(10^K*1234567890/9999999999) !1234567890123…の一般項

   PRINT K;"桁"; N
   LET t=prmdiv(N)
   IF t=N THEN PRINT "素数" ELSE PRINT "合成数";t
NEXT x

END


EXTERNAL FUNCTION prmdiv(n) !１より大きな最小の約数（最小因数）
OPTION ARITHMETIC RATIONAL !多桁の整数
IF n<>INT(n) THEN !整数以外なら
   PRINT "prmdiv関数でパラメータが不適当です。"; n
   STOP
ELSEIF n=0 THEN
   LET prmdiv=0
ELSE
   LET n=ABS(n) !絶対値をとる

   IF MOD(n,2)=0 THEN !最小因数が2である場合
      LET prmdiv=2
   ELSEIF MOD(n,3)=0 THEN !最小因数が3である場合
      LET prmdiv=3
   ELSEIF MOD(n,5)=0 THEN !最小因数が5である場合
      LET prmdiv=5
   ELSE !以下、7以上の奇数(2,3,5とそれぞれ互いに素な数のみ)ごとに割っていく
      DATA 1,7,11,13,17,19,23,29
      DIM P(0 TO 7)
      MAT READ P

      LET a=7
      LET J=0
      LET i=1
      DO
         IF MOD(n,a)=0 THEN !nがaで初めて割り切れれば、最小因数はaである
            LET prmdiv=a
            EXIT FUNCTION
         END IF
         LET i=i+1
         IF i>=8 THEN
            LET i=0
            LET J=J+30
         END IF
         LET a=J+P(i)
      LOOP WHILE a*a<=n !a≦√nの範囲が対象となる

      LET prmdiv=n !最小因数がその数自身の場合、素数である
   END IF
END IF
END FUNCTION

 		 

Re: 倍数の判定

 投稿者：山中和義  投稿日：2012年12月25日(火)13時37分38秒
  > No.2531[元記事へ]

> 次の桁数が予想される。
> 1の場合、31, 111, 121, 141, 161, 171, 191, …
> 7の場合、157, 167, 187, …

確率的素数判定法のひとつ「フェルマー・テスト」で絞り込んでみました。

参考サイト　http://oeis.org/A057137
　　　　　　http://oeis.org/A120819


OPTION ARITHMETIC RATIONAL !多桁の整数

LET a=2 !底

LET y=1
FOR x=0 TO 100
!!LET K=9*x+y
!!LET N=INT(10^K*123456789/999999999) !123456789123…の一般項
   LET K=10*x+y
   LET N=INT(10^K*1234567890/9999999999) !1234567890123…の一般項

   IF fermat(a,N)=1 THEN PRINT K;"桁は、確率的素数"
NEXT x

END


EXTERNAL FUNCTION fermat(a,n) !フェルマーテスト　1:確率的素数、0:合成数
OPTION ARITHMETIC RATIONAL !多桁の整数
LET fermat=0
IF gcd(a,n)<>1 THEN EXIT FUNCTION !aとnは互いに素でない、合成数である
IF modpow(a,n-1,n)<>1 THEN EXIT FUNCTION !a^(n-1)≡1 mod n とならなければ、合成数である
LET fermat=1 !確率的素数
END FUNCTION

EXTERNAL FUNCTION gcd(a,b) !最大公約数
OPTION ARITHMETIC RATIONAL !多桁の整数
DO UNTIL b=0
   LET t=b
   LET b=MOD(a,b)
   LET a=t
LOOP
LET gcd=a
END FUNCTION

EXTERNAL FUNCTION modpow(a,n,b) !a^n≡x mod b のxを返す　※nは非負整数
OPTION ARITHMETIC RATIONAL !多桁の整数
IF n<0 OR n<>INT(n) THEN !非負整数以外なら
   PRINT "modpow関数でパラメータが不適当です。"; n
   STOP
ELSE
   LET S=MOD(1,b)
   DO WHILE n>0 !べき乗nを２進展開する
      IF MOD(n,2)=1 THEN LET S=MOD(S*a,b) !ビットが１なら計算する
      LET a=MOD(a*a,b)
      LET n=INT(n/2)
   LOOP
   LET modpow=S
END IF
END FUNCTION

 		 

プログラムの依頼

 投稿者：GAI  投稿日：2012年12月28日(金)14時14分52秒
  任意の正の整数nに対して、まずこの数を超える最も近い(n-1)の倍数へ移し、さらにその移した数を超える最も近い(n-2)の倍数へ更に移していくプロセスを最も近い2の倍数になるまで続けることにして、その結果をf(n)とする。

例
10→18(9の倍数で10を超える最も近い数)
　→24(8の倍数で18を超える最も近い数)
　→28(7の倍数で24を超える最も近い数)
　→30(6の倍数で28を超える最も近い数)
  →30(5の倍数で30を超える最も近い数)
  →32(4の倍数で30を超える最も近い数)
  →33(3の倍数で32を超える最も近い数)
  →34(2の倍数で33を超える最も近い数)

従ってf(10)=34
となる。
こうしてf(n)が定義されたものについて、任意のnを与えればf(n)の値を知れるプログラムを作って頂きたいのです。


この妙な関数f(n)が
　n→∞で
　n^2/f(n)→π  ということが起こるという。 		 

Re: プログラムの依頼

 投稿者：山中和義  投稿日：2012年12月28日(金)16時05分46秒
  > No.2766[元記事へ]

GAIさんへのお返事です。

> この妙な関数f(n)が
> 　n→∞で
> 　n^2/f(n)→π  ということが起こるという。

n     f(n)      n^2/f(n)
9995  31812118  3.14031354341135
9996  31813522  3.14080333513529
9997  31814038  3.14138082691672
9998  31816050  3.1418106270263
9999  31832412  3.1408239187153
10000  31833630  3.14133198130405



DEF f(m,t)=INT((m+(t-1))/t)*t !m以上で最小のtの倍数

FOR n=1 TO 10000

   LET fn=n
   FOR k=n-1 TO 2 STEP -1
      LET fn=f(fn,k)
      !!!PRINT fn !debug
   NEXT k
   PRINT n; fn; n^2/fn

NEXT n

END
 		 

素数出現関数を求めて

 投稿者：GAI  投稿日：2012年12月29日(土)17時20分3秒
  PARI/GPという計算ソフトで素数構成関数ができないか挑戦してみました。
まず素数の部分を指定できるように
F(j)=(j-1)!^2%j             !%は余りを出す演算です。（実質０か１が出力されます。）
を定義しました。

次に、整数ｍまでに存在している素数の個数を調べます。
G(m)=sum(j=1,m,F(j))

T(m,n)=floor(((n+1)/(G(m)+1))^(1/(n+1))) 　!0で割り算が起こらないように調整している。
P(n)=1+sum(m=1,2^n+1,T(m,n))               !上でずらした分2^n+1の処理にしている。

でn番目の素数を出す関数P(n)を定義します。

for(n=1,20,print(n,";",P(n-1)))   !ｎとの整合を起こすために、P(n-1)の表示にしている。

出力結果
1;2
2;3
3;5
4;7
5;11
6;13
7;17
8;19
9;23
10;29
11;31
12;37
・・・
・・・

と出力していく。
ただし１１番目以降は2^n+1の処理に時間が膨大に膨れていく。
これを組み合わせると素数を求める一つの式にできるような気がしますが・・・


この流れをBASICに書き直して頂けませんか。





 		 

Re: 素数出現関数を求めて

 投稿者：山中和義  投稿日：2012年12月30日(日)13時52分57秒
  > No.2794[元記事へ]

GAIさんへのお返事です。

> PARI/GPという計算ソフトで素数構成関数ができないか挑戦してみました。

> この流れをBASICに書き直して頂けませんか。

BASICで記述しても非実用的ですね。


!http://en.wikipedia.org/wiki/Formula_for_primes

FOR N=1 TO 20
   PRINT N; P(N)
NEXT N
END

EXTERNAL FUNCTION F(J) !素数判定　1:素数、0:素数でない　→PrimeQ(j)
LET S=1 !Wilsonの定理「pが素数⇔(p-1)! ≡-1 (mod p)」より、0,1を返す
FOR i=2 TO J-1 !(j-1)!
   LET S=MOD(S*i,J)
   IF S=0 THEN EXIT FOR
NEXT i
LET F=MOD(S*S,J) !(j-1)!^2 mod j
END FUNCTION

EXTERNAL FUNCTION G(M) !m以下の素数の数　→PrimePi(m)
LET S=0
IF M>=2 THEN LET S=1 !2は素数
FOR J=3 TO M STEP 2 !奇数を対象とする
   LET S=S+F(J)
NEXT J
LET G=S !Σ[j=2,m]PrimeQ(j)
END FUNCTION

EXTERNAL FUNCTION T(M,N) !xが1より大きいときxの正のx乗根は1～2の間の数になる
LET T=INT( (N/(G(M)+1))^(1/N) )
END FUNCTION

EXTERNAL FUNCTION P(N) !n番目の素数　→Prime(n)
LET S=0
FOR M=1 TO 2^N
   LET S=S+T(M,N)
NEXT M
LET P=S+1
END FUNCTION

 		 

Re: 素数出現関数を求めて

 投稿者：GAI  投稿日：2012年12月31日(月)01時29分19秒
  > No.2824[元記事へ]

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

>
> !http://en.wikipedia.org/wiki/Formula_for_primes

の記事を参考にプログラムを変更し

P(n)=1+sum(m=1,2*floor(n*log(n)+1),(1-floor((sum(j=1,m,(j-1)!^2%j)/n))))

なる一つの式で構成してみました。（PARIでのプログラム）
（指数関数部分が対数関数処理でいけるものを選びました。）

n=1～100は軽く表示してくれます。
またn=150でも１分位待っていますとP(150)=863
の素数を返してきました。
前のに比べたら格段の進歩になりました。
 		 

Re: 素数出現関数を求めて

 投稿者：MyTrade  投稿日：2012年12月31日(月)09時17分57秒
  > No.2794[元記事へ]

GAIさんへのお返事です。

＊山中和義さんのプログラムの関数P(N)の部分を改善してみました。

EXTERNAL FUNCTION P(N) !n番目の素数　→Prime(n)
LET S=0
FOR M=1 TO 2^N
   LET tt=T(M,N)
   IF tt=0 THEN EXIT FOR !途中打ち切り
   LET S=S+tt
NEXT M
LET P=S+1
END FUNCTION

100番目までのすべての素数を出力するのに約3分です。
P(150)の計算は約30秒でした。


＊関数P(N)は次のように定義することも可能です。

EXTERNAL FUNCTION P(N) !n番目の素数　→Prime(n)
LET ss=1
LET M=0
DO
   LET M=M+1
   LET ss=ss+T(M,N)
LOOP UNTIL M=ss
LET P=ss
END FUNCTION
 		 

素数多発関数の考察

 投稿者：GAI  投稿日：2012年12月31日(月)18時19分2秒
  f(n)=2*n^2-199
の関数で素数を発生させるｎの値の表（*は合成数の結果となるもの。）
これより効率よい関数を探せないか？
（n=1～1000で調査したもの）


** 20 30 40 50 60 70 80 90
11 21 31 41 51 61 71 81 91
12 22 ** 42 52 62 72 82 92
13 23 33 43 53 ** 73 ** 93
14 24 34 44 ** 64 74 84 **
15 25 35 45 55 ** ** 85 95
16 26 36 ** 56 66 76 86 96
17 27 37 47 57 67 ** 87 **
18 ** 38 48 58 68 78 88 98
19 29 39 49 59 69 ** 89 99


100 110 *** 130 *** *** 160 170 180 ***
*** 111 *** 131 141 151 *** *** 181 191
*** 112 122 132 142 *** 162 *** *** 192
103 113 123 *** 143 153 *** 173 *** ***
104 114 124 *** *** *** 164 174 *** ***
105 115 125 135 145 *** 165 175 *** ***
106 116 *** 136 146 156 *** *** 186 ***
107 117 127 137 147 *** 167 177 187 197
*** *** 128 138 148 *** 168 *** 188 ***
109 119 129 *** 149 159 169 *** *** ***


200 210 220 230 240 *** *** 270 280 ***
201 211 *** *** 241 251 261 271 *** ***
202 212 222 232 242 *** 262 272 282 ***
203 *** 223 233 243 253 263 273 283 ***
*** 214 224 234 244 254 *** 274 *** 294
*** 215 225 235 245 *** *** 275 285 295
206 216 *** *** 246 256 *** *** 286 ***
*** 217 227 237 *** 257 *** 277 *** ***
*** 218 228 238 *** 258 *** 278 *** 298
*** 219 229 239 249 259 *** *** 289 299


300 *** 320 *** 340 *** 360 370 *** ***
301 311 321 331 341 351 *** 371 *** 391
302 *** 322 *** *** 352 *** *** 382 392
*** 313 323 *** 343 *** *** *** 383 ***
304 314 *** 334 345 354 364 374 *** 394
*** 315 325 335 *** *** *** *** 385 ***
306 *** 326 *** 346 356 366 *** 386 ***
307 317 327 *** *** 357 367 377 *** ***
308 318 *** *** 348 358 *** 378 388 ***
309 319 *** *** 349 *** *** *** 389 399


*** *** 420 *** *** *** 460 *** *** ***
401 *** *** *** *** *** 461 *** *** 491
402 412 422 432 *** *** *** *** *** 492
403 413 423 *** 443 *** 463 473 *** 493
*** 414 424 *** 444 454 464 474 *** 494
405 415 *** *** 445 456 465 475 485 495
406 *** 426 436 446 *** 466 476 486 496
407 417 427 437 *** *** *** 477 *** ***
408 *** 428 438 448 458 468 478 488 ***
409 *** 429 *** 449 459 469 479 *** ***


500 *** *** *** *** 550 *** *** *** ***
501 *** 521 531 541 551 561 *** *** ***
*** *** *** 532 *** 552 *** 572 *** ***
503 513 523 533 *** 553 563 573 *** ***
*** *** 524 534 544 554 *** 574 584 ***
*** 515 *** 535 545 *** *** *** *** ***
506 516 526 536 *** *** *** *** 586 ***
507 *** *** 537 547 *** 567 577 587 ***
508 518 528 538 *** 558 568 *** 588 ***
*** 519 529 539 549 559 *** *** *** ***


600 *** *** 630 640 *** 660 670 680 690
*** *** *** *** *** *** 661 671 681 691
602 612 622 632 *** 652 *** *** *** 692
603 *** 623 633 643 *** 663 673 683 693
*** 614 624 *** 644 *** *** 674 684 ***
605 615 625 *** 645 655 665 *** 685 695
606 616 626 636 646 *** 666 676 686 ***
607 617 627 *** *** *** 667 *** *** 697
*** 618 628 *** 648 658 668 678 688 ***
609 *** *** 639 649 *** 669 *** 689 ***


*** 710 *** 730 *** *** 760 770 780 790
701 711 *** *** *** 751 *** *** *** ***
703 *** 722 *** *** 752 *** 772 *** 792
*** *** *** 733 743 753 *** *** *** 793
*** *** *** *** *** 754 764 774 784 794
705 715 725 735 745 755 765 *** *** ***
*** 716 726 736 746 *** *** 776 *** ***
707 *** *** 737 *** 757 *** 777 *** ***
*** *** 728 *** 748 *** *** 778 *** 798
*** *** 729 739 *** 759 *** 779 *** 799


800 810 820 830 *** 850 *** 870 *** 890
*** 811 *** *** *** 851 861 *** 881 891
802 812 822 832 *** 852 862 *** *** ***
*** *** *** 833 843 853 *** 873 *** ***
804 *** 824 834 *** 854 864 874 884 894
*** *** 825 835 845 855 865 875 885 ***
*** 816 *** *** *** 856 866 *** 886 896
*** *** *** 837 *** *** *** 877 887 ***
*** 818 *** 838 848 *** 868 *** 888 898
*** 819 *** *** *** 859 *** *** *** ***


*** *** *** *** 940 950 *** 970 980 ***
901 911 921 *** 941 *** 961 *** 981 ***
*** 912 922 932 942 952 962 972 982 ***
903 913 *** 933 943 *** *** *** 983 ***
904 *** 924 *** *** 954 *** *** *** ***
905 *** 925 *** 945 *** 965 *** *** ***
906 *** *** 936 *** 956 966 *** *** 996
907 917 927 937 947 *** *** *** 987 997
*** *** *** 938 948 958 968 *** 988 ***
909 919 *** 939 949 *** 969 *** *** ***

 		 

　戻る