teacup. [ 掲示板 ] [ 掲示板作成 ] [ 有料掲示板 ] [ ブログ ]

 <思いやりのあるコミュニティ宣言>
 teacup.掲示板は、皆様の権利を守りながら、思いやり、温かみのあるコミュニティづくりを応援します。
 いつもご協力いただきありがとうございます。

 投稿者
  題名
  内容 入力補助画像・ファイル<IMG>タグが利用可能です。(詳細)
    
 URL
[ ケータイで使う ] [ BBSティッカー ] [ 書込み通知 ] [ 検索 ]

スレッド一覧

  1. スレッドが使えます(2)
  2. Paract BASIC(22)
  3. Amusement_Program(10)
  4. 改修予定のJIS非互換(3)
  5. 複数ページ長編プログラム(新規投稿)(16)
  6. 「十進BASIC第2掲示板」投稿記事リスト(17)
  7. Full BASIC互換ライブラリ(8)
  8. 「十進BASIC掲示板過去ログ」インデックス(トピック)(17)
  9. 人の色覚の数理(14)
  10. 「十進BASIC掲示板過去ログ」インデックス(ツリー)(91)
スレッド一覧(全10)  他のスレッドを探す  スレッド作成

*掲示板をお持ちでない方へ、まずは掲示板を作成しましょう。無料掲示板作成


不自由なハノイの塔

 投稿者:kikiriri  投稿日:2020年 6月 4日(木)06時53分30秒
返信・引用
  しばっち様へ
いいですね。
 
 

不自由なハノイの塔

 投稿者:しばっち  投稿日:2020年 6月 3日(水)20時44分45秒
返信・引用
  不自由なハノイの塔

不自由なハノイの塔ではハノイの塔のルールに次の条件を加えます。

●条件
1番上の1枚目の円盤は3本ある棒のうち、真ん中(の棒)には置いてはいけない。


この条件を適用すると1枚目の円盤は奇数回毎に棒Aと棒Cを繰り返し移動します。
すると偶数回で移動できる円盤は1通りしかありません。

移動回数は

   1枚の時、 1回
   2枚の時、 5回
   3枚の時、17回
   4枚の時、53回
                  となり、

よって円盤がn枚の時は
     2*3^(n-1)-1回となります。

円盤が3枚の場合ですが、下記の実行結果を見ても1枚目の円盤は真ん中(の棒)にはありません。
ちなみにNo.1までが円盤1枚の時の No.5までが円盤2枚の時の解答となります。

その他棒の数を4本、5本と増やす流儀もあるようです。

LET N=3
DIM S(N,3),A$(N)
MAT READ A$
PRINT "円盤";N;"枚"
PRINT "No. 0"
FOR K=1 TO N
   LET S(K,1)=1
   PRINT A$(K)
NEXT K
FOR I=1 TO 2*3^(N-1)-1
   IF MOD(I,2)=1 THEN
      LET J=1
      SWAP S(1,1),S(1,3)
   ELSE
      FOR J=2 TO N
         IF S(1,1)=0 AND S(J-1,1)=0 AND S(J,1)=1 AND S(J,2)=0 OR S(1,1)=0 AND S(J-1,2)=0 AND S(J,2)=1 AND S(J,1)=0 THEN
            SWAP S(J,1),S(J,2)
            EXIT FOR
         END IF
         IF S(1,1)=0 AND S(J-1,1)=0 AND S(J,1)=1 AND S(J,3)=0 OR S(1,3)=0 AND S(1,1)=0 AND S(J-1,3)=0 AND S(J,3)=1 AND S(J,1)=0 THEN
            SWAP S(J,1),S(J,3)
            EXIT FOR
         END IF
         IF S(1,3)=0 AND S(J-1,3)=0 AND S(J,3)=1 AND S(J,2)=0 OR S(J,2)=1 AND S(J,3)=0 AND S(J-1,2)=0 THEN
            SWAP S(J,3),S(J,2)
            EXIT FOR
         END IF
      NEXT J
   END IF
   PRINT REPEAT$("-",78)
   PRINT "No.";I
   FOR J=1 TO N
      FOR K=1 TO 3
         IF S(J,K)=1 THEN
            PRINT A$(J)
            EXIT FOR
         END IF
         PRINT REPEAT$(" ",26);
      NEXT K
   NEXT J
NEXT I
DATA "            ■            "
DATA "          ■■■          "
DATA "        ■■■■■        "
DATA "      ■■■■■■■      "
DATA "    ■■■■■■■■■    "
DATA "  ■■■■■■■■■■■  "
END


                実行結果

円盤 3 枚
No. 0
            ■
          ■■■
        ■■■■■
------------------------------------------------------------------------------
No. 1
                                                                ■
          ■■■
        ■■■■■
------------------------------------------------------------------------------
No. 2
                                                                ■
                                    ■■■
        ■■■■■
------------------------------------------------------------------------------
No. 3
            ■
                                    ■■■
        ■■■■■
------------------------------------------------------------------------------
No. 4
            ■
                                                              ■■■
        ■■■■■
------------------------------------------------------------------------------
No. 5
                                                                ■
                                                              ■■■
        ■■■■■
------------------------------------------------------------------------------
No. 6
                                                                ■
                                                              ■■■
                                  ■■■■■
------------------------------------------------------------------------------
No. 7
            ■
                                                              ■■■
                                  ■■■■■
------------------------------------------------------------------------------
No. 8
            ■
                                    ■■■
                                  ■■■■■
------------------------------------------------------------------------------
No. 9
                                                                ■
                                    ■■■
                                  ■■■■■
------------------------------------------------------------------------------
No. 10
                                                                ■
          ■■■
                                  ■■■■■
------------------------------------------------------------------------------
No. 11
            ■
          ■■■
                                  ■■■■■
------------------------------------------------------------------------------
No. 12
            ■
          ■■■
                                                            ■■■■■
------------------------------------------------------------------------------
No. 13
                                                                ■
          ■■■
                                                            ■■■■■
------------------------------------------------------------------------------
No. 14
                                                                ■
                                    ■■■
                                                            ■■■■■
------------------------------------------------------------------------------
No. 15
            ■
                                    ■■■
                                                            ■■■■■
------------------------------------------------------------------------------
No. 16
            ■
                                                              ■■■
                                                            ■■■■■
------------------------------------------------------------------------------
No. 17
                                                                ■
                                                              ■■■
                                                            ■■■■■
 

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

 投稿者:nagram  投稿日:2020年 5月28日(木)14時50分27秒
返信・引用 編集済
  名無しさんさんへのお返事です。

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

十進BASICに添付するファイル

C:¥Program Files (x86)¥Decimal BASIC¥BASICw32¥REVISION.TXT

の [修正・変更の履歴] に

「Ver.7.8.5.2 PLOT AREA文がLINE STYLEの影響を受ける誤りを修正。」

とあります。
 

ハノイの塔の2

 投稿者:kikiriri  投稿日:2020年 5月28日(木)08時20分0秒
返信・引用
  なので、円盤の数が3枚の時
2^3=8
8-1=7
7回
これは、あっています。
円盤の数が、1まいのとき、
2^1=2
2-1=1
これもあっています。
円盤の数が2枚の時
2^2=4
4-1=3
これもあっています。
4枚を超えると暗算では難しいですが。
一般の式 2^n  -  1  を使うと。
2^4=16
16-1は15より15回だと思われます。
 

ハノイの塔

 投稿者:kikiriri  投稿日:2020年 5月28日(木)08時13分54秒
返信・引用
  2^n-1

n枚の円盤の時の最短移動回数です。
 

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

 投稿者:名無しさん  投稿日:2020年 5月27日(水)16時32分12秒
返信・引用
     > No.4821[元記事へ]

Ver. 7.8.5.4ですが,支障ないようです。

10 SET LINE STYLE 2
20 PLOT LINES:0,0; 0,1
30 SET AREA COLOR 2
40 PLOT AREA : 0,0;1,0;0.5,1
50 END

 最新verをDLしたら直ってましたね(ver7.6.6では元のまま)
 この7.8.5.4と7.6.6の間に、修正したご記憶は持っていらっしゃるのですか?
 

画像ヒストグラム平坦化

 投稿者:しばっち  投稿日:2020年 5月24日(日)14時36分5秒
返信・引用 編集済
  ヒストグラムを平坦化しコンストラストを改善します。
モノクロ画像では濃度値に対して平坦化しますが
カラー画像では、R,G,B各々に対してではなくHSVに変換して
彩度(S)又は明度(V)に対して平坦化します。

https://qiita.com/Dason08/items/1b28e24d12630182fd69
https://algorithm.joho.info/image-processing/histogram-equalization/

PUBLIC NUMERIC XSIZE,YSIZE
OPTION BASE 0
DIM HIST(255)
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
DIM M(XSIZE-1,YSIZE-1)
ASK PIXEL ARRAY(0,0) M
DIM OUT(XSIZE,YSIZE),IN(XSIZE,YSIZE)
LET MODE=0
FOR Y=0 TO YSIZE-1
   FOR X=0 TO XSIZE-1
      CALL RGB(M(X,Y),R,G,B)
      CALL RGB2HSV(R,G,B,H,S,V)
      SELECT CASE MODE
      CASE 0
         LET IN(X,Y)=S
         LET HIST(S)=HIST(S)+1
      CASE 1
         LET IN(X,Y)=V
         LET HIST(V)=HIST(V)+1
      END SELECT
   NEXT X
NEXT Y
CALL PLANE(OUT,IN,HIST,XSIZE,YSIZE)
FOR Y=0 TO YSIZE-1
   FOR X=0 TO XSIZE-1
      CALL RGB(M(X,Y),R,G,B)
      CALL RGB2HSV(R,G,B,H,S,V)
      SELECT CASE MODE
      CASE 0
         CALL HSV2RGB(R,G,B,H,OUT(X,Y),V)
      CASE 1
         CALL HSV2RGB(R,G,B,H,S,OUT(X,Y))
      END SELECT
      LET M(X,Y)=SETRGB(R,G,B)
   NEXT X
NEXT Y
MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:M
END

EXTERNAL  SUB PLANE(OUT(,),IN(,),HIST(),XSIZE,YSIZE)
FOR Y=0 TO YSIZE-1
   FOR X=0 TO XSIZE-1
      FOR I=0 TO IN(X,Y)
         LET OUT(X,Y)=OUT(X,Y)+HIST(I)
      NEXT I
      LET OUT(X,Y)=INT(OUT(X,Y)*255/XSIZE/YSIZE)
   NEXT X
NEXT Y
END SUB

EXTERNAL FUNCTION SETRGB(R,G,B)
LET R=MIN(255,MAX(R,0))
LET G=MAX(0,MIN(G,255))
LET B=MAX(0,MIN(B,255))
LET SETRGB=B*65536+G*256+R
END FUNCTION

EXTERNAL SUB RGB(X,R,G,B)
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB

EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB

EXTERNAL SUB HSV2RGB(R,G,B,H,S,V)
IF S=0 THEN
   LET R=V
   LET G=V
   LET B=V
   EXIT SUB
END IF
LET T=V-S*V/255
LET HH=H
IF H>=300 OR H<60 THEN
   IF H>=300 THEN LET HH=360-HH
   IF H<60 THEN LET HH=-HH
   LET HH=HH/60
   LET RR=0
   IF HH<0 THEN
      LET BB=1
      LET GG=HH+BB
   ELSE
      LET GG=1
      LET BB=GG-HH
   END IF
ELSEIF H>=60 AND H<180 THEN
   LET HH=HH-120
   LET HH=HH/60
   LET GG=0
   IF HH<0 THEN
      LET BB=1
      LET RR=HH+BB
   ELSE
      LET RR=1
      LET BB=RR-HH
   END IF
ELSEIF H>=180 AND H<300 THEN
   LET HH=HH-240
   LET HH=HH/60
   LET BB=0
   IF HH<0 THEN
      LET RR=1
      LET GG=HH+RR
   ELSE
      LET GG=1
      LET RR=GG-HH
   END IF
END IF
LET R=-RR*(V-T)+V
LET R=INT(R)
LET G=-GG*(V-T)+V
LET G=INT(G)
LET B=-BB*(V-T)+V
LET B=INT(B)
END SUB

EXTERNAL SUB RGB2HSV(R,G,B,H,S,V)
LET V=MAX(MAX(R,G),B)
LET T=MIN(MIN(R,G),B)
IF V=0 THEN
   LET S=0
ELSE
   LET S=((V-T)*255)/V
END IF
IF S=0 THEN
   LET H=0
ELSE
   LET RR=(V-R)/(V-T)
   LET GG=(V-G)/(V-T)
   LET BB=(V-B)/(V-T)
   IF V=R THEN
      LET H=BB-GG
   ELSEIF V=G THEN
      LET H=2+RR-BB
   ELSEIF V=B THEN
      LET H=4+GG-RR
   END IF
   LET H=H*60
END IF
IF H<0 THEN LET H=H+360
END SUB
 

画像イコライザー

 投稿者:しばっち  投稿日:2020年 5月24日(日)14時34分14秒
返信・引用
  画像に対してグラフィックイコライザー風な(DCT係数を0~2倍します)処理を
行います。
スライドバーを動かした後、グラフィックウィンドゥ内をマウスでクリックしてください。


OPTION BASE 0
DIM R(16,16),G(16,16),B(16,16)
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
DIM M(XSIZE-1,YSIZE-1),MM(XSIZE-1,YSIZE-1),V(16)
LET SW=0 !' 0 OR 1
LET BAND=8 !' 8 OR 16
ASK PIXEL ARRAY(0,0) M
LOCATE VALUE NOWAIT(1),RANGE -8 TO 8,AT 0:L
LOCATE VALUE NOWAIT(2),RANGE -8 TO 8,AT 0:H1
LOCATE VALUE NOWAIT(3),RANGE -8 TO 8,AT 0:H2
LOCATE VALUE NOWAIT(4),RANGE -8 TO 8,AT 0:H3
LOCATE VALUE NOWAIT(5),RANGE -8 TO 8,AT 0:H4
LOCATE VALUE NOWAIT(6),RANGE -8 TO 8,AT 0:H5
LOCATE VALUE NOWAIT(7),RANGE -8 TO 8,AT 0:H6
LOCATE VALUE NOWAIT(8),RANGE -8 TO 8,AT 0:H7
IF BAND=16 THEN
   LOCATE VALUE NOWAIT(9),RANGE -8 TO 8,AT 0:H8
   LOCATE VALUE NOWAIT(10),RANGE -8 TO 8,AT 0:H9
   LOCATE VALUE NOWAIT(11),RANGE -8 TO 8,AT 0:H10
   LOCATE VALUE NOWAIT(12),RANGE -8 TO 8,AT 0:H11
   LOCATE VALUE NOWAIT(13),RANGE -8 TO 8,AT 0:H12
   LOCATE VALUE NOWAIT(14),RANGE -8 TO 8,AT 0:H13
   LOCATE VALUE NOWAIT(15),RANGE -8 TO 8,AT 0:H14
   LOCATE VALUE NOWAIT(16),RANGE -8 TO 8,AT 0:H15
END IF
DO
   DO  !'ウェイト。マウスでウィンドゥ内をクリックする。
      IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP
      MOUSE POLL X,Y,LL,RR
      LOCATE VALUE NOWAIT(1):L
      LOCATE VALUE NOWAIT(2):H1
      LOCATE VALUE NOWAIT(3):H2
      LOCATE VALUE NOWAIT(4):H3
      LOCATE VALUE NOWAIT(5):H4
      LOCATE VALUE NOWAIT(6):H5
      LOCATE VALUE NOWAIT(7):H6
      LOCATE VALUE NOWAIT(8):H7
      IF BAND=16 THEN
         LOCATE VALUE NOWAIT(9):H8
         LOCATE VALUE NOWAIT(10):H9
         LOCATE VALUE NOWAIT(11):H10
         LOCATE VALUE NOWAIT(12):H11
         LOCATE VALUE NOWAIT(13):H12
         LOCATE VALUE NOWAIT(14):H13
         LOCATE VALUE NOWAIT(15):H14
         LOCATE VALUE NOWAIT(16):H15
      END IF
   LOOP WHILE LL=0 AND RR=0
   CLEAR
   LET V(0)=L
   LET V(1)=H1
   LET V(2)=H2
   LET V(3)=H3
   LET V(4)=H4
   LET V(5)=H5
   LET V(6)=H6
   LET V(7)=H7
   LET V(8)=H8
   LET V(9)=H9
   LET V(10)=H10
   LET V(11)=H11
   LET V(12)=H12
   LET V(13)=H13
   LET V(14)=H14
   LET V(15)=H15
   SET TEXT HEIGHT YSIZE/10
   SET COLOR COLORINDEX(0,0,0)
   SET TEXT BACKGROUND "OPAQUE"
   SET TEXT JUSTIFY "CENTER" , "TOP"
   PLOT TEXT ,AT XSIZE/2,YSIZE/2 :"処理中"
   FOR Y=0 TO YSIZE-1 STEP BAND
      SET TEXT JUSTIFY "LEFT" , "TOP"
      PLOT TEXT ,AT 0,0 :USING$("###.#",Y/(YSIZE-1)*100)&"%"
      FOR X=0 TO XSIZE-1 STEP BAND
         FOR J=SW TO BAND-1+SW
            FOR I=SW TO BAND-1+SW
               IF X+I-SW<=XSIZE-1 AND Y+J-SW<=YSIZE-1 THEN
                  LET CC=M(X+I-SW,Y+J-SW)
               ELSE
                  LET CC=0
               END IF
               CALL RGB(CC,R(I,J),G(I,J),B(I,J))
            NEXT I
         NEXT J
         IF SW=0 THEN
            CALL DCT(R,BAND)
            CALL DCT(G,BAND)
            CALL DCT(B,BAND)
         ELSEIF SW=1 THEN
            CALL DST(R,BAND)
            CALL DST(G,BAND)
            CALL DST(B,BAND)
         END IF
         FOR I=SW TO BAND-1+SW
            FOR J=SW TO BAND-1+SW
               LET R(I,J)=R(I,J)*(8+V(I))/8*(V(J)+8)/8 !'係数を掛ける。縦横で最大4倍する
               LET G(I,J)=G(I,J)*(8+V(I))/8*(V(J)+8)/8
               LET B(I,J)=B(I,J)*(8+V(I))/8*(V(J)+8)/8
            NEXT J
         NEXT I
         IF SW=0 THEN
            CALL IDCT(R,BAND)
            CALL IDCT(G,BAND)
            CALL IDCT(B,BAND)
         ELSEIF SW=1 THEN
            CALL IDST(R,BAND)
            CALL IDST(G,BAND)
            CALL IDST(B,BAND)
         END IF
         FOR J=SW TO BAND-1+SW
            FOR I=SW TO BAND-1+SW
               IF B(I,J)<0 THEN LET B(I,J)=0
               IF G(I,J)<0 THEN LET G(I,J)=0
               IF R(I,J)<0 THEN LET R(I,J)=0
               IF B(I,J)>255 THEN LET B(I,J)=255
               IF G(I,J)>255 THEN LET G(I,J)=255
               IF R(I,J)>255 THEN LET R(I,J)=255
               IF X+I-SW<=XSIZE-1 AND Y+J-SW<=YSIZE-1 THEN LET MM(X+I-SW,Y+J-SW)=SETRGB(INT(R(I,J)),INT(G(I,J)),INT(B(I,J)))
            NEXT I
         NEXT J
      NEXT X
   NEXT Y
   MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:MM
LOOP
END

EXTERNAL FUNCTION C(X,N)
IF X=0 OR X=N THEN LET C=SQR(.5) ELSE LET C=1
END FUNCTION

EXTERNAL SUB DCT(S(,),N)
OPTION BASE 0
DIM X(N),Y(N)
FOR J=0 TO N-1
   FOR I=0 TO N-1
      LET X(I)=S(I,J)
   NEXT I
   CALL DCT2(X,N,Y)
   FOR I=0 TO N-1
      LET S(I,J)=Y(I)
   NEXT I
NEXT J
FOR J=0 TO N-1
   FOR I=0 TO N-1
      LET X(I)=S(J,I)
   NEXT I
   CALL DCT2(X,N,Y)
   FOR I=0 TO N-1
      LET S(J,I)=Y(I)
   NEXT I
NEXT J
END SUB

EXTERNAL SUB DCT2(A(),N,B())
FOR I=0 TO N-1
   LET S=0
   FOR K=0 TO N-1
      LET S=S+A(K)*COS((2*K+1)*I*PI/2/N)
   NEXT K
   LET B(I)=S*SQR(2/N)*C(I,N)
NEXT I
END SUB

EXTERNAL SUB DCT3(A(),N,B())
FOR I=0 TO N-1
   LET S=0
   FOR K=0 TO N-1
      LET S=S+C(K,N)*A(K)*COS((2*I+1)*K*PI/2/N)
   NEXT K
   LET B(I)=INT(S*SQR(2/N)+.5)
NEXT I
END SUB

EXTERNAL SUB IDCT(S(,),N)
OPTION BASE 0
DIM X(N),Y(N)
FOR J=0 TO N-1
   FOR I=0 TO N-1
      LET X(I)=S(I,J)
   NEXT I
   CALL DCT3(X,N,Y)
   FOR I=0 TO N-1
      LET S(I,J)=Y(I)
   NEXT I
NEXT J
FOR J=0 TO N-1
   FOR I=0 TO N-1
      LET X(I)=S(J,I)
   NEXT I
   CALL DCT3(X,N,Y)
   FOR I=0 TO N-1
      LET S(J,I)=Y(I)
   NEXT I
NEXT J
END SUB

EXTERNAL SUB DST(S(,),N)
OPTION BASE 0
DIM X(N),Y(N)
FOR J=1 TO N
   FOR I=1 TO N
      LET X(I)=S(I,J)
   NEXT I
   CALL DST2(X,N,Y)
   FOR I=1 TO N
      LET S(I,J)=Y(I)
   NEXT I
NEXT J
FOR J=1 TO N
   FOR I=1 TO N
      LET X(I)=S(J,I)
   NEXT I
   CALL DST2(X,N,Y)
   FOR I=1 TO N
      LET S(J,I)=Y(I)
   NEXT I
NEXT J
END SUB

EXTERNAL SUB DST2(A(),N,B())
FOR K=1 TO N
   LET S=0
   FOR I=1 TO N
      LET S=S+A(I)*SIN((2*I-1)*K*PI/2/N)
   NEXT I
   LET B(K)=S*SQR(2/N)*C(K,N)
NEXT K
END SUB

EXTERNAL SUB DST3(A(),N,B())
FOR K=1 TO N
   LET S=0
   FOR I=1 TO N
      LET S=S+C(I,N)*A(I)*SIN((2*K-1)*I*PI/2/N)
   NEXT I
   LET B(K)=INT(S*SQR(2/N)+.5)
NEXT K
END SUB

EXTERNAL SUB IDST(S(,),N)
OPTION BASE 0
DIM X(N),Y(N)
FOR J=1 TO N
   FOR I=1 TO N
      LET X(I)=S(I,J)
   NEXT I
   CALL DST3(X,N,Y)
   FOR I=1 TO N
      LET S(I,J)=Y(I)
   NEXT I
NEXT J
FOR J=1 TO N
   FOR I=1 TO N
      LET X(I)=S(J,I)
   NEXT I
   CALL DST3(X,N,Y)
   FOR I=1 TO N
      LET S(J,I)=Y(I)
   NEXT I
NEXT J
END SUB

EXTERNAL SUB RGB(X,R,G,B)
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB

EXTERNAL FUNCTION SETRGB(R,G,B)
LET R=MIN(255,MAX(R,0))
LET G=MAX(0,MIN(G,255))
LET B=MAX(0,MIN(B,255))
LET SETRGB=B*65536+G*256+R
END FUNCTION

EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
 

画像放射ぼかし

 投稿者:しばっち  投稿日:2020年 5月24日(日)14時32分24秒
返信・引用
  長さと楕円領域の大きさとその中心座標をスライドバーで指定します。
スライドバーを動かした後、グラフィックウィンドゥ内をマウスでクリックしてください。


OPTION BASE 0
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
DIM M(XSIZE-1,YSIZE-1),MM(XSIZE-1,YSIZE-1)
ASK PIXEL ARRAY(0,0) M
LOCATE VALUE NOWAIT(1),RANGE 1 TO MIN(XSIZE,YSIZE)/5,AT 10:LENGTH
LOCATE VALUE NOWAIT(2),RANGE 0 TO XSIZE-1,AT XSIZE/2:X0
LOCATE VALUE NOWAIT(3),RANGE 0 TO YSIZE-1,AT YSIZE/2:Y0
LOCATE VALUE NOWAIT(4),RANGE 1 TO XSIZE/2,AT XSIZE/10:XR
LOCATE VALUE NOWAIT(5),RANGE 1 TO YSIZE/2,AT YSIZE/10:YR
DO
   CLEAR
   SET TEXT HEIGHT YSIZE/10
   SET COLOR COLORINDEX(0,0,0)
   SET TEXT BACKGROUND "OPAQUE"
   SET TEXT JUSTIFY "CENTER" , "TOP"
   PLOT TEXT ,AT XSIZE/2,YSIZE/2 :"処理中"
   LET LENGTH=INT(LENGTH)
   LET X0=INT(X0)
   LET Y0=INT(Y0)
   LET XR=INT(XR)
   LET YR=INT(YR)
   FOR Y=0 TO YSIZE-1
      SET TEXT JUSTIFY "LEFT" , "TOP"
      PLOT TEXT ,AT 0,0 :USING$("###.#",Y/(YSIZE-1)*100)&"%"
      FOR X=0 TO XSIZE-1
         IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP
         IF ((X-X0)/XR)^2+((Y-Y0)/YR)^2>1 THEN
            LET RR=INT(SQR((X-X0)^2+(Y-Y0)^2))
            IF X+X0-XS=0 THEN
               IF Y-Y0>0 THEN LET TH=PI/2 ELSE LET TH=1.5*PI
            ELSE
               LET TH=ANGLE(X-X0,Y-Y0)
            END IF
            LET R1=0
            LET G1=0
            LET B1=0
            LET N=0
            FOR I=0 TO LENGTH-1
               IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP
               LET XX=X0+INT((RR+I)*COS(TH))
               LET YY=Y0+INT((RR+I)*SIN(TH))
               IF XX>=0 AND XX<=XSIZE-1 AND YY>=0 AND YY<=YSIZE-1 THEN
                  LET CC=M(XX,YY)
                  CALL RGB(CC,R,G,B)
                  LET R1=R1+R
                  LET G1=G1+G
                  LET B1=B1+B
                  LET N=N+1
               ELSE
                  EXIT FOR
               END IF
            NEXT I
            IF N>0 THEN LET MM(X,Y)=SETRGB(INT(R1/N),INT(G1/N),INT(B1/N))
         ELSE
            LET MM(X,Y)=M(X,Y)
         END IF
      NEXT X
   NEXT Y
   MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:MM
   DO   !'ウェイト。マウスでウィンドゥ内をクリックする。
      IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP
      MOUSE POLL X,Y,LL,RR
      LOCATE VALUE NOWAIT(1):LENGTH
      LOCATE VALUE NOWAIT(2):X0
      LOCATE VALUE NOWAIT(3):Y0
      LOCATE VALUE NOWAIT(4):XR
      LOCATE VALUE NOWAIT(5):YR
   LOOP WHILE LL=0 AND RR=0
LOOP
END

EXTERNAL SUB RGB(X,R,G,B)
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB

EXTERNAL FUNCTION SETRGB(R,G,B)
LET R=MIN(255,MAX(R,0))
LET G=MAX(0,MIN(G,255))
LET B=MAX(0,MIN(B,255))
LET SETRGB=B*65536+G*256+R
END FUNCTION

EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
 

画像回転ぼかし

 投稿者:しばっち  投稿日:2020年 5月24日(日)14時31分9秒
返信・引用
  回転角度と楕円領域の大きさとその中心座標をスライドバーで指定します。
スライドバーを動かした後、グラフィックウィンドゥ内をマウスでクリックしてください。


OPTION BASE 0
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
DIM M(XSIZE-1,YSIZE-1),MM(XSIZE-1,YSIZE-1)
ASK PIXEL ARRAY(0,0) M
LOCATE VALUE NOWAIT(1),RANGE 1 TO 90,AT 10:ALPHA
LOCATE VALUE NOWAIT(2),RANGE 0 TO XSIZE-1,AT XSIZE/2:X0
LOCATE VALUE NOWAIT(3),RANGE 0 TO YSIZE-1,AT YSIZE/2:Y0
LOCATE VALUE NOWAIT(4),RANGE 1 TO XSIZE/2,AT XSIZE/10:XR
LOCATE VALUE NOWAIT(5),RANGE 1 TO YSIZE/2,AT YSIZE/10:YR
DO
   CLEAR
   SET TEXT HEIGHT YSIZE/10
   SET COLOR COLORINDEX(0,0,0)
   SET TEXT BACKGROUND "OPAQUE"
   SET TEXT JUSTIFY "CENTER" , "TOP"
   PLOT TEXT ,AT XSIZE/2,YSIZE/2 :"処理中"
   LET ALPHA=INT(ALPHA)
   LET X0=INT(X0)
   LET Y0=INT(Y0)
   LET XR=INT(XR)
   LET YR=INT(YR)
   FOR Y=0 TO YSIZE-1
      SET TEXT JUSTIFY "LEFT" , "TOP"
      PLOT TEXT ,AT 0,0 :USING$("###.#",Y/(YSIZE-1)*100)&"%"
      FOR X=0 TO XSIZE-1
         IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP
         IF ((X-X0)/XR)^2+((Y-Y0)/YR)^2>1 THEN
            LET RX=SQR((X-X0)^2+(Y-Y0)^2)
            IF X-X0=0 THEN
               IF Y-Y0>0 THEN LET TH=PI/2 ELSE LET TH=1.5*PI
            ELSE
               LET TH=ANGLE(X-X0,Y-Y0)
            END IF
            LET RR=0
            LET GG=0
            LET BB=0
            FOR I=0 TO ALPHA-1
               IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP
               LET XX=INT(RX*COS(TH+I*PI/180))+X0
               LET YY=INT(RX*SIN(TH+I*PI/180))+Y0
               IF XX>=0 AND XX<=XSIZE-1 AND YY>=0 AND YY<=YSIZE-1 THEN LET CC=M(XX,YY) ELSE EXIT FOR
               CALL RGB(CC,R,G,B)
               LET RR=RR+R
               LET GG=GG+G
               LET BB=BB+B
            NEXT I
            LET RR=INT(RR/(I+1))
            LET GG=INT(GG/(I+1))
            LET BB=INT(BB/(I+1))
            LET MM(X,Y)=SETRGB(RR,GG,BB)
         ELSE
            LET CC=M(X,Y)
            CALL RGB(CC,R,G,B)
            LET MM(X,Y)=SETRGB(R,G,B)
         END IF
      NEXT X
   NEXT Y
   MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:MM
   DO   !'ウェイト。マウスでウィンドゥ内をクリックする。
      IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP
      MOUSE POLL X,Y,LL,RR
      LOCATE VALUE NOWAIT(1):ALPHA
      LOCATE VALUE NOWAIT(2):X0
      LOCATE VALUE NOWAIT(3):Y0
      LOCATE VALUE NOWAIT(4):XR
      LOCATE VALUE NOWAIT(5):YR
   LOOP WHILE LL=0 AND RR=0
LOOP
END

EXTERNAL FUNCTION SETRGB(R,G,B)
LET R=MIN(255,MAX(R,0))
LET G=MAX(0,MIN(G,255))
LET B=MAX(0,MIN(B,255))
LET SETRGB=B*65536+G*256+R
END FUNCTION

EXTERNAL SUB RGB(X,R,G,B)
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB

EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
 

画像ぼかし2

 投稿者:しばっち  投稿日:2020年 5月24日(日)14時29分58秒
返信・引用
  ボカシ処理をします。
スライドバーを動かした後、グラフィックウィンドゥ内をマウスでクリックしてください。


OPTION BASE 0
FILE GETNAME F$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(F$,XSIZE,YSIZE)
DIM M(XSIZE-1,YSIZE-1),MM(XSIZE-1,YSIZE-1)
ASK PIXEL ARRAY(0,0) M
LOCATE VALUE NOWAIT(1),RANGE 1 TO 9,AT 1:N
DO
   CLEAR
   SET TEXT HEIGHT YSIZE/10
   SET COLOR COLORINDEX(0,0,0)
   SET TEXT BACKGROUND "OPAQUE"
   SET TEXT JUSTIFY "CENTER" , "TOP"
   PLOT TEXT ,AT XSIZE/2,YSIZE/2 :"処理中"
   LET N=INT(N)
   FOR Y=0 TO YSIZE-1
      SET TEXT JUSTIFY "LEFT" , "TOP"
      PLOT TEXT ,AT 0,0 :USING$("###.#",Y/(YSIZE-1)*100)&"%"
      FOR X=0 TO XSIZE-1
         LET RR=0
         LET GG=0
         LET BB=0
         LET K=0
         FOR J=-N TO N
            FOR I=-N TO N
               IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP
               IF X+I>=0 AND X+I<=XSIZE-1 AND Y+J>=0 AND Y+J<=YSIZE-1 THEN
                  LET C=M(X+I,Y+J)
                  CALL RGB(C,R,G,B)
                  LET RR=RR+R
                  LET GG=GG+G
                  LET BB=BB+B
                  LET K=K+1
               END IF
            NEXT I
         NEXT J
         LET MM(X,Y)=SETRGB(INT(RR/K),INT(GG/K),INT(BB/K))
      NEXT X
   NEXT Y
   MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:MM
   DO   !'ウェイト。マウスでウィンドゥ内をクリックする。
      IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP
      MOUSE POLL X,Y,LL,RR
      LOCATE VALUE NOWAIT(1):N
   LOOP WHILE LL=0 AND RR=0
LOOP
END

EXTERNAL FUNCTION SETRGB(R,G,B)
LET R=MIN(255,MAX(R,0))
LET G=MAX(0,MIN(G,255))
LET B=MAX(0,MIN(B,255))
LET SETRGB=B*65536+G*256+R
END FUNCTION

EXTERNAL SUB RGB(X,R,G,B)
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB

EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
 

画像ぼかし

 投稿者:しばっち  投稿日:2020年 5月24日(日)14時29分12秒
返信・引用
  長さと角度をスライドバーで指定します。
スライドバーを動かした後、グラフィックウィンドゥ内をマウスでクリックしてください。


OPTION BASE 0
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
DIM M(XSIZE-1,YSIZE-1),MM(XSIZE-1,YSIZE-1)
ASK PIXEL ARRAY(0,0) M
LOCATE VALUE NOWAIT(1),RANGE 1 TO MIN(XSIZE,YSIZE)/5,AT 10:LENGTH
LOCATE VALUE NOWAIT(2),RANGE 0 TO 89,AT 45:TH
DO
   LET LENGTH=INT(LENGTH)
   LET TH=INT(TH)
   CLEAR
   SET TEXT HEIGHT YSIZE/10
   SET COLOR COLORINDEX(0,0,0)
   SET TEXT BACKGROUND "OPAQUE"
   SET TEXT JUSTIFY "CENTER" , "TOP"
   PLOT TEXT ,AT XSIZE/2,YSIZE/2 :"処理中"
   FOR Y=0 TO YSIZE-1
      SET TEXT JUSTIFY "LEFT" , "TOP"
      PLOT TEXT ,AT 0,0 :USING$("###.#",Y/(YSIZE-1)*100)&"%"
      FOR X=0 TO XSIZE-1
         IF GETKEYSTATE(32)<0 OR GETKEYSTATE(13)<0 OR GETKEYSTATE(27)<0 THEN STOP
         LET R=0
         LET G=0
         LET B=0
         FOR L=0 TO LENGTH-1
            IF GETKEYSTATE(32)<0 OR GETKEYSTATE(13)<0 OR GETKEYSTATE(27)<0 THEN STOP
            LET XX=X+COS(TH*PI/180)*L
            LET YY=Y+SIN(TH*PI/180)*L
            IF XX>=0 AND XX<=XSIZE-1 AND YY>=0 AND YY<=YSIZE-1 THEN LET CC=M(INT(XX),INT(YY)) ELSE EXIT FOR
            CALL RGB(CC,R0,G0,B0)
            LET R=R+R0
            LET G=G+G0
            LET B=B+B0
         NEXT L
         LET R=INT(R/(L+1))
         LET G=INT(G/(L+1))
         LET B=INT(B/(L+1))
         LET MM(X,Y)=SETRGB(R,G,B)
      NEXT X
   NEXT Y
   MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:MM
   DO   !'ウェイト。マウスでウィンドゥ内をクリックする。
      IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP
      MOUSE POLL X,Y,LL,RR
      LOCATE VALUE NOWAIT(1):LENGTH
      LOCATE VALUE NOWAIT(2):TH
   LOOP WHILE LL=0 AND RR=0
LOOP
END

EXTERNAL FUNCTION SETRGB(R,G,B)
LET R=MIN(255,MAX(R,0))
LET G=MAX(0,MIN(G,255))
LET B=MAX(0,MIN(B,255))
LET SETRGB=B*65536+G*256+R
END FUNCTION

EXTERNAL SUB RGB(X,R,G,B)
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB

EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
 

画像色調

 投稿者:しばっち  投稿日:2020年 5月24日(日)14時28分11秒
返信・引用
  R,G,Bをスライドバーで指定して色調を変更します。
リアルタイム処理はできないのでウェイトを入れています。
スライドバーを動かした後、グラフィックウィンドゥ内をマウスでクリックしてください。


OPTION BASE 0
FILE GETNAME F$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(F$,XSIZE,YSIZE)
DIM M(XSIZE-1,YSIZE-1),MM(XSIZE-1,YSIZE-1)
ASK PIXEL ARRAY(0,0) M
LOCATE VALUE NOWAIT(1),RANGE 0 TO 255,AT 240:R0 !'セピア調
LOCATE VALUE NOWAIT(2),RANGE 0 TO 255,AT 200:G0
LOCATE VALUE NOWAIT(3),RANGE 0 TO 255,AT 145:B0
DO
   CLEAR
   SET TEXT HEIGHT YSIZE/10
   SET COLOR COLORINDEX(0,0,0)
   SET TEXT BACKGROUND "OPAQUE"
   SET TEXT JUSTIFY "CENTER" , "TOP"
   PLOT TEXT ,AT XSIZE/2,YSIZE/2 :"処理中"
   LET R0=INT(R0)
   LET G0=INT(G0)
   LET B0=INT(B0)
   FOR Y=0 TO YSIZE-1
      SET TEXT JUSTIFY "LEFT" , "TOP"
      PLOT TEXT ,AT 0,0 :USING$("###.#",Y/(YSIZE-1)*100)&"%"
      FOR X=0 TO XSIZE-1
         IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP
         LET C=M(X,Y)
         CALL RGB(C,R,G,B)
         !' LET V=(R+G+B)/3
         LET V=R * 0.298912 + G * 0.586611 + B * 0.114478
         LET RR=R0*V/255
         LET GG=G0*V/255
         LET BB=B0*V/255
         LET MM(X,Y)=SETRGB(INT(RR),INT(GG),INT(BB))
      NEXT X
   NEXT Y
   MAT PLOT CELLS , IN 0,0; XSIZE-1,YSIZE-1:MM
   DO  !'ウェイト。マウスでウィンドゥ内をクリックする。
      IF GetKeyState(32)<0 OR GetKeyState(13)<0 OR GetKeyState(27)<0 THEN STOP
      MOUSE POLL X,Y,LL,RR
      LOCATE VALUE NOWAIT(1):R0
      LOCATE VALUE NOWAIT(2):G0
      LOCATE VALUE NOWAIT(3):B0
   LOOP WHILE LL=0 AND RR=0
LOOP
END

EXTERNAL FUNCTION SETRGB(R,G,B)
LET R=MIN(255,MAX(R,0))
LET G=MAX(0,MIN(G,255))
LET B=MAX(0,MIN(B,255))
LET SETRGB=B*65536+G*256+R
END FUNCTION

EXTERNAL SUB RGB(X,R,G,B)
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB

EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
 

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

 投稿者:しばっち  投稿日:2020年 5月24日(日)14時26分44秒
返信・引用
  これはWindows版BASICの場合ですが
PLOT POINTS文とMAT PLOT CELLS文とでは
動作モードにもよるがMAT PLOT CELLS文で描画するほうが断然速い。
2進モードでは30倍も速い


LET XSIZE=800
LET YSIZE=800
CALL GINIT(XSIZE,YSIZE)
LET T=TIME
!!!SET DRAW MODE HIDDEN !ここの注釈を外すと5倍程速くなる
FOR Y=0 TO YSIZE-1
   FOR X=0 TO XSIZE-1
      LET C=INT(RND*255)
      SET POINT COLOR C
      PLOT POINTS:X,Y
   NEXT X
NEXT Y
!!!SET DRAW MODE EXPLICIT
LET L=TIME-T
PRINT L

OPTION BASE 0
DIM M(XSIZE-1,YSIZE-1)
CLEAR
LET T=TIME
FOR Y=0 TO YSIZE-1
   FOR X=0 TO XSIZE-1
      LET C=INT(RND*255)
      LET M(X,Y)=C
   NEXT X
NEXT Y
MAT PLOT CELLS,IN 0,0; XSIZE-1,YSIZE-1 :M
LET P=TIME-T
PRINT P
PRINT L/P
END

EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
FOR I=0 TO 7
   SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
END SUB


            実行結果


5.38999999999942
.160000000003492
33.687499999261

MAT PLOT CELLS文を使用して
下記のようにスクロールアニメができます。

RANDOMIZE
FILE GETNAME F$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(F$,XSIZE,YSIZE)
LET WIDTH=600 !'ウィンドゥサイズ
LET HEIGHT=600
OPTION BASE 0
DIM MM(WIDTH,HEIGHT),M(XSIZE,YSIZE)
ASK PIXEL ARRAY (0,0) M
CALL GINIT(WIDTH,HEIGHT)
DO
   LET N=INT(RND*50)+10
   LET XR=INT(RND*30-15)
   LET YR=INT(RND*30-15)
   FOR I=1 TO N
      FOR Y=0 TO HEIGHT-1
         FOR X=0 TO WIDTH-1
            LET MM(X,Y)=M(MOD(X+XX,XSIZE),MOD(Y+YY,YSIZE))
         NEXT  X
      NEXT Y
      MAT PLOT CELLS,IN 0,0; WIDTH-1,HEIGHT-1:MM
      LET XX=MOD(XX+XR,XSIZE)
      LET YY=MOD(YY+YR,YSIZE)
   NEXT I
LOOP
END

EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB

EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
 

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

 投稿者:SHIRAISHI Kazuo  投稿日:2020年 5月10日(日)08時20分33秒
返信・引用
  > No.4821[元記事へ]

Ver. 7.8.5.4ですが,支障ないようです。

10 SET LINE STYLE 2
20 PLOT LINES:0,0; 0,1
30 SET AREA COLOR 2
40 PLOT AREA : 0,0;1,0;0.5,1
50 END

 

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

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

複素関数のグラフ

 投稿者:しばっち  投稿日:2020年 4月26日(日)19時02分16秒
返信・引用
  複素関数のグラフ(色関数)

https://ja.wikipedia.org/wiki/定義域の着色
(※クリックではなくマウスで選択コピーしてブラウザのアドレスバーに貼り付け移動してください)

※残念ながら上記URLのサンプルと同じ画像にはなりません。

OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
LET XS,YS=-10
LET XE,YE=10
ASK BITMAP SIZE XSIZE,YSIZE
LET ZMIN=1E+10
FOR Y=0 TO YSIZE-1
   FOR X=0 TO XSIZE-1
      LET XX=WORLDX(X)
      LET YY=WORLDY(Y)
      LET Z=F(COMPLEX(XX,YY))
      IF ABS(Z)<>0 THEN  LET ZZ=LOG10(ABS(Z)) ELSE LET ZZ=0
      LET ZMAX=MAX(ZMAX,ZZ)
      LET ZMIN=MIN(ZMIN,ZZ)
   NEXT X
NEXT Y
DO
   SET WINDOW XS,XE,YS,YE
   FOR Y=0 TO YSIZE-1
      FOR X=0 TO XSIZE-1
         LET XX=WORLDX(X)
         LET YY=WORLDY(Y)
         LET Z=F(COMPLEX(XX,YY))
         IF RE(Z)<>0 OR IM(Z)<>0 THEN LET ARG=ANGLE(RE(Z),IM(Z)) ELSE LET ARG=0
         IF ABS(Z)=0 THEN LET ZZ=0 ELSE LET ZZ=LOG10(ABS(Z))
         LET ZZ=(ZZ-ZMIN)/(ZMAX-ZMIN)
         CALL HSL2RGB(DEG(ARG),255,(1-2^(-ZZ))*255,R,G,B)
         CALL PSET(XX,YY,R,G,B)
      NEXT X
   NEXT Y
   PAUSE "拡大する範囲を指定してください"
   CALL GETSQUARE(XS,YS,XE,YE)
   IF XS=XE  THEN EXIT DO
   IF XS>XE THEN SWAP XS,XE
   IF YS>YE THEN SWAP YS,YE
LOOP
END

EXTERNAL  FUNCTION F(X)
OPTION ARITHMETIC COMPLEX
LET I=SQR(-1)
LET F=(X^2-1)*(X-2-I)^2/(X^2+2+2*I)
END FUNCTION

EXTERNAL SUB HSL2RGB(H,S,L,R,G,B)
OPTION ARITHMETIC COMPLEX
IF S<0 THEN LET S=0
IF S>255 THEN LET S=255
IF L<0 THEN LET L=0
IF L>255 THEN LET L=255
LET SS=S/255
LET LL=L/255
LET H=MOD(INT(H),360)
IF H<0 THEN LET H=H+360
IF LL<=.5 THEN
   LET CMIN=LL*(1-SS)
   LET CMAX=2*LL-CMIN
ELSE
   LET CMAX=LL*(1-SS)+SS
   LET CMIN=2*LL-CMAX
END IF
LET R=H2V(H+120,CMIN,CMAX)*255
LET G=H2V(H,CMIN,CMAX)*255
LET B=H2V(H-120,CMIN,CMAX)*255
LET R=INT(R+.5)
LET B=INT(B+.5)
LET G=INT(G+.5)
IF R<0 THEN LET R=0
IF G<0 THEN LET G=0
IF B<0 THEN LET B=0
IF R>255 THEN LET R=255
IF G>255 THEN LET G=255
IF B>255 THEN LET B=255
END SUB

EXTERNAL FUNCTION H2V(H,CMIN,CMAX)
OPTION ARITHMETIC COMPLEX
IF H<0 THEN LET H=H+360
LET H=MOD(H,360)
IF H<60 THEN
   LET H2V=CMIN+(CMAX-CMIN)*H/60
   EXIT FUNCTION
END IF
IF H>=60 AND H<180 THEN
   LET H2V=CMAX
   EXIT FUNCTION
END IF
IF H>=180 AND H<240 THEN
   LET H2V=CMIN+(CMAX-CMIN)*(240-H)/60
   EXIT FUNCTION
END IF
IF H>=240 THEN LET H2V=CMIN
END FUNCTION

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB

EXTERNAL SUB GETSQUARE(L,T,R,B)
OPTION ARITHMETIC COMPLEX
SET COLOR MODE "REGULAR"
ASK LINE STYLE LSTYLE
SET DRAW MODE NOTXOR
SET LINE STYLE 2
DO
   MOUSE POLL L,T,I,J
LOOP WHILE I=0
LET L0=L
LET T0=T
LET R0=L0
LET B0=T0
PLOT LINES:L0,T0;L0,B0;R0,B0;R0,T0;L0,T0
DO WHILE I=1
   MOUSE POLL R,B,I,J
   LET W=R-L
   LET H=T-B
   IF ABS(H)<ABS(W) THEN
      LET B=T-SGN(H)*ABS(W)
   ELSE
      LET R=L+SGN(W)*ABS(H)
   END IF
   IF L0<>L OR R0<>R OR B0<>B OR T0<>T THEN
      PLOT LINES:L0,T0;L0,B0;R0,B0;R0,T0;L0,T0
      PLOT LINES:L,T;L,B;R,B;R,T;L,T
      LET L0=L
      LET T0=T
      LET R0=R
      LET B0=B
   END IF
LOOP
WAIT DELAY 1
PLOT LINES:L,T;L,B;R,B;R,T;L,T
SET DRAW MODE OVERWRITE
SET LINE STYLE LSTYLE
IF L>R THEN SWAP L,R
IF B>T THEN SWAP B,T
SET COLOR MODE "NATIVE"
END SUB
 

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

 投稿者:しばっち  投稿日:2020年 4月12日(日)14時46分5秒
返信・引用
  > No.4818[元記事へ]

下記のようにしても陰関数のグラフが描画できます。


LET LEFT=-5
LET RIGHT=5
LET BOTTOM=-5
LET TOP=5
SET POINT STYLE 1
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
ASK PIXEL SIZE XSIZE,YSIZE
DRAW GRID
FOR YY=0 TO YSIZE-1
   FOR XX=0 TO YSIZE-1
      LET X=WORLDX(XX)
      LET Y=WORLDY(YY)
      WHEN EXCEPTION IN
         LET L=ABS(F(X,Y))
         IF L<1 AND L/SQR(FX(X,Y)^2+FY(X,Y)^2)<.01 THEN PLOT POINTS: X,Y
      USE
      END WHEN
   NEXT  XX
NEXT  YY
END

EXTERNAL  FUNCTION F(X,Y) !'陰関数 F(X,Y)=0
LET F=X*X+Y*Y-3*X*Y+1
!'LET F=1/(X-Y)-X+3*Y
!'LET F=SIN(X)+SIN(2*Y)+SIN(3*X)+SIN(4*Y)+SIN(5*X)
!'LET F=(FF(Y)^2-FF(X)^4+FF(X)^6)*(FF(X)^2-FF(Y)^4+FF(Y)^6)
!'LET F=(FF(X)^2+FF(Y)^2-3)*(1.5*FF(X)^4-FF(X)^6-1.5*FF(Y)^4)
!'LET F=(FF(X)^2+FF(Y)^2)^3-4*FF(X)^2*FF(Y)^2
END FUNCTION

EXTERNAL  FUNCTION FF(X)
LET FF=X-2.6*INT((X+1.3)/2.6)
END FUNCTION

EXTERNAL  FUNCTION FX(X,Y) !' ∂/∂x F(x,y)
LET H=1/256
!'LET FX=(-F(X-H,Y)+F(X+H,Y))/(2*H)
LET FX=(F(X-2*H,Y)-8*F(X-H,Y)+8*F(X+H,Y)-F(X+2*H,Y))/(12*H)
!'LET FX=(-F(X-3*H,Y)+9*F(X-2*H,Y)-45*F(X-H,Y)+45*F(X+H,Y)-9*F(X+2*H,Y)+F(X+3*H,Y))/(60*H)
!'LET FX=(3*F(X-4*H,Y)-32*F(X-3*H,Y)+168*F(X-2*H,Y)-672*F(X-H,Y)+672*F(X+H,Y)-168*F(X+2*H,Y)+32*F(X+3*H,Y)-3*F(X+4*H,Y))/(840*H)
END FUNCTION

EXTERNAL  FUNCTION FY(X,Y) !' ∂/∂y F(x,y)
LET H=1/256
!'LET FY=(-F(X,Y-H)+F(X,Y+H))/(2*H)
LET FY=(F(X,Y-2*H)-8*F(X,Y-H)+8*F(X,Y+H)-F(X,Y+2*H))/(12*H)
!'LET FY=(-F(X,Y-3*H)+9*F(X,Y-2*H)-45*F(X,Y-H)+45*F(X,Y+H)-9*F(X,Y+2*H)+F(X,Y+3*H))/(60*H)
!'LET FY=(3*F(X,Y-4*H)-32*F(X,Y-3*H)+168*F(X,Y-2*H)-672*F(X,Y-H)+672*F(X,Y+H)-168*F(X,Y+2*H)+32*F(X,Y+3*H)-3*F(X,Y+4*H))/(840*H)
END FUNCTION
 

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

 投稿者:しばっち  投稿日:2020年 4月 8日(水)20時36分41秒
返信・引用
  > No.4817[元記事へ]

陰関数 F(x,y)=0 の導関数 dy/dx=f(x,y) は数値微分でも代用できるようです。

LET XS=-5
LET XE=5
LET YS=-5
LET YE=5
SET WINDOW XS,XE,YS,YE
DRAW GRID
LET N=100 !'分割数
LET H=(XE-XS)/N
FOR L=1 TO 2
   READ XX,YY
   DATA 1,1
   DATA -1,-1
   FOR I=1 TO 2
      LET T=0
      LET X=XX !'初期値
      LET Y=YY
      WHEN EXCEPTION IN
         FOR J=1 TO N
            LET K1=F1(T,X,Y)
            LET L1=F2(T,X,Y)

            LET K2=F1(T+H/2,X+H/2*K1,Y+H/2*L1)
            LET L2=F2(T+H/2,X+H/2*K1,Y+H/2*L1)

            LET K3=F1(T+H/2,X+H/2*K2,Y+H/2*L2)
            LET L3=F2(T+H/2,X+H/2*K2,Y+H/2*L2)

            LET K4=F1(T+H,X+H*K3,Y+H*L3)
            LET L4=F2(T+H,X+H*K3,Y+H*L3)

            LET X0=X+H*(K1+2*K2+2*K3+K4)/6
            LET Y0=Y+H*(L1+2*L2+2*L3+L4)/6
            LET T0=T+H
            PLOT LINES:X,Y;X0,Y0
            LET X=X0
            LET Y=Y0
            LET T=T0
            IF X>XE OR X<XS OR Y<YS OR Y>YE THEN EXIT FOR
         NEXT J
      USE
         PLOT LINES
      END WHEN
      LET H=-H
   NEXT  I
NEXT L
END

EXTERNAL  FUNCTION F1(T,X,Y) !'dx/dt=f1(t,x,y)
LET F1=FY(X,Y)
END FUNCTION

EXTERNAL  FUNCTION F2(T,X,Y) !'dy/dt=f2(t,x,y)
LET F2=-FX(X,Y)
END FUNCTION

EXTERNAL  FUNCTION F(X,Y) !'陰関数 F(x,y)=0
LET F=X^2+Y^2-3*X*Y+1
END FUNCTION

EXTERNAL  FUNCTION FX(X,Y) !' ∂/∂x F(x,y)
LET H=1/256
LET FX=(F(X-2*H,Y)-8*F(X-H,Y)+8*F(X+H,Y)-F(X+2*H,Y))/(12*H)
END FUNCTION

EXTERNAL  FUNCTION FY(X,Y) !' ∂/∂y F(x,y)
LET H=1/256
LET FY=(F(X,Y-2*H)-8*F(X,Y-H)+8*F(X,Y+H)-F(X,Y+2*H))/(12*H)
END FUNCTION
 

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

 投稿者:しばっち  投稿日:2020年 4月 5日(日)14時27分39秒
返信・引用
  X^2+Y^2-3*X*Y+1=0のグラフ
https://hp.vector.co.jp/authors/VA008683/F_GRAPH.htm


導関数 dy/dx=(2*x-3*y)/(3*x-2*y)を求め、dx/dt=3*x-2*y dy/dt=2*x-3*yとして
2元連立常微分方程式をルンゲクッタ法で解く
https://www.wolframalpha.com/input/?i=x%5E2%2By%5E2-3*x*y%2B1%3D0%2Cdy%2Fdx&lang=ja

陰関数 F(x,y)=0のグラフはdy/dx=f(x,y)の解曲線とすれば描画できる。

LET XS=-5
LET XE=5
LET YS=-5
LET YE=5
SET WINDOW XS,XE,YS,YE
DRAW GRID
LET N=100 !'分割数
LET H=(XE-XS)/N
FOR L=1 TO 2
   READ XX,YY
   DATA 1,1
   DATA -1,-1
   FOR I=1 TO 2
      LET T=0
      LET X=XX !'初期値
      LET Y=YY
      WHEN EXCEPTION IN
         FOR J=1 TO N
            LET K1=F1(T,X,Y)
            LET L1=F2(T,X,Y)

            LET K2=F1(T+H/2,X+H/2*K1,Y+H/2*L1)
            LET L2=F2(T+H/2,X+H/2*K1,Y+H/2*L1)

            LET K3=F1(T+H/2,X+H/2*K2,Y+H/2*L2)
            LET L3=F2(T+H/2,X+H/2*K2,Y+H/2*L2)

            LET K4=F1(T+H,X+H*K3,Y+H*L3)
            LET L4=F2(T+H,X+H*K3,Y+H*L3)

            LET X0=X+H*(K1+2*K2+2*K3+K4)/6
            LET Y0=Y+H*(L1+2*L2+2*L3+L4)/6
            LET T0=T+H
            PLOT LINES:X,Y;X0,Y0
            LET X=X0
            LET Y=Y0
            LET T=T0
         NEXT J
      USE
         PLOT LINES
      END WHEN
      LET H=-H
   NEXT  I
NEXT L
END

EXTERNAL  FUNCTION F1(T,X,Y) !'dx/dt=f1(t,x,y)
LET F1=3*X-2*Y
END FUNCTION

EXTERNAL  FUNCTION F2(T,X,Y) !'dy/dt=f2(t,x,y)
LET F2=2*X-3*Y
END FUNCTION
--------------------------------------------------------------------------------
1/(X-Y)-X+3*Y=0のグラフ
dy/dx=((x-y)^2+1)/(3*(x-y)^2+1)
https://www.wolframalpha.com/input/?i=1%2F%28x-y%29-x%2B3*y%3D0%2Cdy%2Fdx&lang=ja

LET XS=-5
LET XE=5
LET YS=-5
LET YE=5
SET WINDOW XS,XE,YS,YE
DRAW GRID
LET N=100 !'分割数
LET H=(XE-XS)/N
FOR L=1 TO 2
   READ XX,YY
   DATA 1,0
   DATA -1,0
   FOR I=1 TO 2
      LET T=0
      LET X=XX !'初期値
      LET Y=YY
      WHEN EXCEPTION IN
         FOR J=1 TO N
            LET K1=F1(T,X,Y)
            LET L1=F2(T,X,Y)

            LET K2=F1(T+H/2,X+H/2*K1,Y+H/2*L1)
            LET L2=F2(T+H/2,X+H/2*K1,Y+H/2*L1)

            LET K3=F1(T+H/2,X+H/2*K2,Y+H/2*L2)
            LET L3=F2(T+H/2,X+H/2*K2,Y+H/2*L2)

            LET K4=F1(T+H,X+H*K3,Y+H*L3)
            LET L4=F2(T+H,X+H*K3,Y+H*L3)

            LET X0=X+H*(K1+2*K2+2*K3+K4)/6
            LET Y0=Y+H*(L1+2*L2+2*L3+L4)/6
            LET T0=T+H
            PLOT LINES:X,Y;X0,Y0
            LET X=X0
            LET Y=Y0
            LET T=T0
         NEXT J
      USE
         PLOT LINES
      END WHEN
      LET H=-H
   NEXT  I
NEXT L
END

EXTERNAL  FUNCTION F1(T,X,Y) !'dx/dt=f1(t,x,y)
LET F1=3*(X-Y)^2+1
END FUNCTION

EXTERNAL  FUNCTION F2(T,X,Y) !'dy/dt=f2(t,x,y)
LET F2=(X-Y)^2+1
END FUNCTION
 

レンタル掲示板
/172