中学校技術科で使っています

　　中学校技術科で使っています 藤原達也 2007/02/18 22:58:00 
　　└!動きが面白く、文が短いのは、すばらしいと... SECOND 2007/02/19 08:26:59 
　　　├!もう少し凝ってみました。 SECOND 2007/02/20 17:02:51 
　　　│└DELETED  SECOND  2007/02/20 22:39:53  (削除)
　　　├!訂正、大きなバグあった。四隅の、反転位置... SECOND 2007/02/21 05:19:14 
　　　│└四隅の処理に、難解な問題がある。 SECOND 2007/02/21 16:57:58 
　　　│　└壁のすり抜けですね！？ 山中和義 2007/02/21 21:30:45 
　　　│　　└続き 山中和義 2007/02/21 21:32:35 
　　　│　　　└さらに続き 山中和義 2007/02/21 21:33:30 
　　　│　　　　└毎回大変有り難うございます。 SECOND 2007/02/22 01:18:59 
　　　│　　　　　└続き SECOND 2007/02/22 02:34:38 
　　　│　　　　　　└続き SECOND 2007/02/22 07:28:38 
　　　├!ステップ幅が１より大きくても良いようにし... SECOND 2007/02/22 07:45:35 
　　　│└前出プログラムの最適化（変数Ｓの削除） 山中和義 2007/02/22 11:46:00 
　　　│　└!有り難うございました。 SECOND 2007/02/22 17:12:32 
　　　│　　└バグは無いです。 SECOND 2007/02/22 18:59:23 
　　　└!これで、すっきりです。 SECOND 2007/02/22 23:04:14

　　中学校技術科で使っています 藤原達也 2007/02/18 22:58:00  ツリーへ

中学校技術科で使っています 返事を書くノートメニュー

藤原達也 <oqpbepsfnm> 2007/02/18 22:58:00

お世話になります。
中学校技術科の情報基礎でこのＢＡＳＩＣを使っています。
もう５年ぐらい使っているので、いろいろなデータがあります。
他に、このような用途を考えている方がいらっしゃると
データを差し上げますのでご連絡ください。
生徒は現在、ピンポンゲームを学習中です（笑）。

set window -8,8,-8,8
!最初のホ゛ールの位置(bx,by)
!ホ゛ールが一度に動く距離(mx,my)
let bx=0
let by=0
let mx=0.3
let my=0.5
10 set area color 4
draw disk with scale(0.3)*shift(bx,by)
if bx<-8 or bx>8 then let mx=mx*(-1)
if by<-8 or by>8 then let my=my*(-1)
wait delay 0.01
!同じ位置に白色の円を描いて消している
set area color 0
draw disk with scale(0.3)*shift(bx,by)
let bx=bx+mx
let by=by+my
goto 10
end

　　└!動きが面白く、文が短いのは、すばらしいと... SECOND 2007/02/19 08:26:59  ツリーへ

Re: 中学校技術科で使っています 返事を書くノートメニュー

SECOND <cszcthjjdj> 2007/02/19 08:26:59

!動きが面白く、文が短いのは、すばらしいと思います。
!それに魅せられて、履歴線を付けてみました。上書き御免ください。
!不思議な周期動作です。

SET WINDOW -8,8,-8,8
!最初のボールの位置(bx,by)
!ボールが一度に動く距離(mx,my)
LET bx=0
LET by=0
LET mx=0.32
LET my=0.5
SET DRAW MODE NOTXOR
SET LINE COLOR 2
SET AREA COLOR 4
DO
DRAW disk WITH SCALE(0.3)*SHIFT(bx,by) ! 赤色の円
WAIT DELAY 0.01
DRAW disk WITH SCALE(0.3)*SHIFT(bx,by) !線を消さず、赤色の円だけを消す( NOTXOR)

PLOT LINES : bx,by; ! 線を書き、２度書きで消える( NOTXOR)

LET bx=bx+mx
LET by=by+my
IF 8<ABS(bx) THEN
LET by=by-my/mx*FP(bx)
LET bx=IP(bx)
LET mx=-mx
END IF
IF 8<ABS(by) THEN
LET bx=bx-mx/my*FP(by)
LET by=IP(by)
LET my=-my
END IF
LOOP

END

　　　├!もう少し凝ってみました。 SECOND 2007/02/20 17:02:51  ツリーへ

Re: !動きが面白く、文が短いのは、すばらしいと... 返事を書くノートメニュー

SECOND <cszcthjjdj> 2007/02/20 17:02:51

!もう少し凝ってみました。

OPTION ARITHMETIC RATIONAL !ステップ加算の累積誤差を押える。

!　　　　　　　ボールの初期位置 bx=by=0 デフォルトを使用。
LET mx= 8/25 ! ボールのX速度、ステップ⊿X　分数式で８に命中。
LET my= 8/16 ! ボールのY速度、ステップ⊿Y　分数式で８に命中。
LET r = 1 !　ボールの半径

SET WINDOW -8-r*1.3, 8+r*1.3, -8-r*1.3, 8+r*1.3
PLOT LINES:-8-r,8+r; 8+r,8+r; 8+r,-8-r; -8-r,-8-r; -8-r,8+r ! 壁面

SET DRAW MODE NOTXOR ! ２度書きで消える NOTXOR モード
SET LINE COLOR 2 ! 青
SET AREA COLOR 2 ! 青
DO
DRAW disk WITH SCALE(r)*SHIFT(bx,by) ! ボールを書く
WAIT DELAY 0.01
DRAW disk WITH SCALE(r)*SHIFT(bx,by) ! ボールだけを消す
PLOT LINES : bx,by; ! 履歴線を（書く・消す）
LET bx=bx+mx
LET by=by+my
IF 8=<ABS(bx) THEN LET mx=-mx ! X速度反転
IF 8=<ABS(by) THEN LET my=-my ! Y速度反転
LOOP

END

　　　│└DELETED  SECOND  2007/02/20 22:39:53  (削除) ツリーへ

Re: !もう少し凝ってみました。 返事を書く

SECOND <cszcthjjdj> 2007/02/20 22:39:53 ** この記事は削除されました

　　　├!訂正、大きなバグあった。四隅の、反転位置... SECOND 2007/02/21 05:19:14  ツリーへ

Re: !動きが面白く、文が短いのは、すばらしいと... 返事を書くノートメニュー

SECOND <cszcthjjdj> 2007/02/21 05:19:14

!訂正、大きなバグあった。四隅の、反転位置補正と、速度反転の際、
!(bx=-8.094, by=+8.467) のように、両方が越えていて、かつ
! by の、出かたが大きいと、正しく処理されていなかった。

!以下の条件では、ベルヌーイ・シフト写像に似たような、
!無理数の左シフト相当を続けており、カオス状態だと思います。
!周期点がないので、再び白紙に戻る事は無く、履歴線は、
!全体を埋め尽くします。

OPTION ARITHMETIC DECIMAL_HIGH ! 10進1000桁
SET WINDOW -9,9,-9,9
! 　　　　　　ボールの初期位置 bx=by=0 デフォルト
LET mx=SQR(2)/4 ! ボールのX速度、ステップ⊿X　(mx=8/25, my=8/16
LET my=SQR(5)/5 ! ボールのY速度、ステップ⊿Y　　等では白紙に戻る)
LET r=0.7 ! 　ボールの半径
PLOT LINES:-8-r,8+r; 8+r,8+r; 8+r,-8-r; -8-r,-8-r; -8-r,8+r ! 壁面

SET DRAW MODE NOTXOR ! ２度書きで消える NOTXOR モード
SET LINE COLOR 2 ! 青
SET AREA COLOR 2 ! 青
DO
DRAW disk WITH SCALE(r)*SHIFT(bx,by) ! ボールを書く
WAIT DELAY 0.01
DRAW disk WITH SCALE(r)*SHIFT(bx,by) ! ボールだけを消す
PLOT LINES : bx,by; ! 履歴線を（書く・消す）
LET bx=bx+mx
LET by=by+my
LET s=0
IF 8<ABS(bx) THEN
LET by=by-my/mx*FP(bx) ! X端座標x,y
LET bx=IP(bx)
LET s=1
END IF
IF 8<ABS(by) THEN
LET bx=bx-mx/my*FP(by) ! Y端座標x,y
LET by=IP(by)
LET my=-my ! Y速度反転
LET s=2
END IF
IF s=1 THEN LET mx=-mx ! X速度反転
LOOP

END

　　　│└四隅の処理に、難解な問題がある。 SECOND 2007/02/21 16:57:58  ツリーへ

Re: !訂正、大きなバグあった。四隅の、反転位置... 返事を書くノートメニュー

SECOND <cszcthjjdj> 2007/02/21 16:57:58

四隅の処理に、難解な問題がある。
この掲示板に、図の掲示ができると、そのケースを明快に図示、
できるのであるが、やむおえません。

例として、壁の左上隅の近傍の場合、

壁の上辺を横切ってから、さらに左辺の延長上を、横切っている場合、
進入角度次第で、bx,by の、どちらが大きくはみ出ているかは不定。

しかし、この場合は、速度反転が、by だけであるので、
bx よりも by を先に処理しないと、bx まで反転してしまう。

結論から言うと、
上下の辺を横切っている場合、bx,by はみ出し量を問わず、
　　　　　はみ出し⊿by だけで、壁交点(bx,by)を求め、Y速度のみ反転する。

左右の辺を横切っている場合、bx,by はみ出し量を問わず、
　　　　　はみ出し⊿bx だけで、壁交点(bx,by)を求め、X速度のみ反転する。

四隅の点、丁度の時は、以上のいずれかが、処理されていれば、
次の移動時に、もう反対側も処理される。この場合、

ボールは、四隅の点の同じ場所に、２度プロットされ、３度目で移動される。
微細な幅の反転が、重なっているとする。現状は、この状態です。が、・・

ややいい加減で、もう少しきれいにならないものか？

　　　│　└壁のすり抜けですね！？ 山中和義 2007/02/21 21:30:45  ツリーへ

Re: 四隅の処理に、難解な問題がある。 返事を書くノートメニュー

山中和義 <drdlxujciw> 2007/02/21 21:30:45

壁のすり抜けですね！？

「ウインドウ・クリッピングの処理をする直線描画」を使って、バウンド位置を補正しています。

SET WINDOW -10,10,-10,10
!!!set window -8,8,-8,8
DRAW grid

CALL GL2D.gl2Window(-8,8,-8,8)

!最初のボールの位置(bx,by)
!ボールが一度に動く距離(mx,my)
LET bx=0
LET by=0
LET mx=1.3 !!!!!大きくするとはみ出す
LET my=0.5 !!!!!

10 set area color 4
draw disk with scale(0.3)*shift(bx,by)

IF bx=<-8 OR bx>=8 THEN LET mx=-mx
IF by=<-8 OR by>=8 THEN LET my=-my

wait delay 0.1

!同じ位置に白色の円を描いて消している
!!!set area color 0
!!!draw disk with scale(0.3)*shift(bx,by)

LET x1=bx !現在位置
LET y1=by

LET bx=bx+mx !次の位置
LET by=by+my

CALL GL2D.gl2Line(x1,y1,bx,by,1) !次の位置を補正

goto 10

END

　　　│　　└続き 山中和義 2007/02/21 21:32:35  ツリーへ

Re: 壁のすり抜けですね！？ 返事を書くノートメニュー

山中和義 <drdlxujciw> 2007/02/21 21:32:35

続き

MODULE GL2D

SHARE NUMERIC fLeft(0 TO 2),fRight(0 TO 2),fBottom(0 TO 2),fTop(0 TO 2)
CALL gl2Window(-1,1,-1,1)

PUBLIC SUB gl2Window
EXTERNAL SUB gl2Window(l,r,b,t)
CALL LineSet(1,0,-l, fLeft) !ウインドウ範囲を表す直線（法線n、距離D）
CALL LineSet(-1,0,r, fRight)
CALL LineSet(0,1,-b, fBottom)
CALL LineSet(0,-1,t, fTop)
END SUB

!クリッピング
EXTERNAL SUB ClipLine(Ln(), p0(),p1(), numClip) !２点p0、p1を通る直線を直線<n,D>でクリッピングする
DECLARE NUMERIC c(0 TO 1)

LET f0=DOT(p0,Ln) !点と直線との位置を確認する
LET f1=DOT(p1,Ln)

IF f0>=0 THEN
IF f1>=0 THEN !borth of p[i] and p[i+1] are inside
LET numOutput=2
ELSE !p[i]:inside, p[i+1]:outside
CALL LineIntersectPoint(Ln,p0,p1, c) !交点を求める
LET p1(0)=c(0)
LET p1(1)=c(1)
LET numOutput=2
END IF
ELSE
IF f1>=0 THEN !p[i]:outside, p[i+1]:inside
CALL LineIntersectPoint(Ln,p0,p1, c)
LET p0(0)=c(0)
LET p0(1)=c(1)
LET numOutput=2
ELSE
!no output
LET numOutput=0
END IF
END IF
LET numClip=numOutput
END SUB

PUBLIC SUB gl2Line
EXTERNAL SUB gl2Line(x1,y1,x2,y2,c) !線分の描画　LINE(x1,y1)-(x2,y2),c
DECLARE NUMERIC p0(0 TO 2),p1(0 TO 2)

IF c>=0 THEN SET LINE COLOR c !色を設定する

CALL Vec2Set(x1,y1, p0) !始点
CALL Vec2Set(x2,y2, p1) !終点

LET numClip=2 !クリッピングする頂点の数

CALL ClipLine(fLeft, p0,p1,numClip) !ウインドウの左端でクリッピングする
IF numClip=0 THEN EXIT SUB
CALL ClipLine(fTop, p0,p1,numClip) !上
IF numClip=0 THEN EXIT SUB
CALL ClipLine(fBottom, p0,p1,numClip) !下
IF numClip=0 THEN EXIT SUB
CALL ClipLine(fRight, p0,p1,numClip) !右
IF numClip=0 THEN EXIT SUB

CALL plot_line(p0(0),p0(1), p1(0),p1(1)) !線分を描く
LET x2=p1(0) !差し戻し
LET y2=p1(1)
END SUB

　　　│　　　└さらに続き 山中和義 2007/02/21 21:33:30  ツリーへ

Re: 続き 返事を書くノートメニュー

山中和義 <drdlxujciw> 2007/02/21 21:33:30

さらに続き

!直線
EXTERNAL SUB LineIntersectPoint(Ln(),p0(),p1(), c()) !２点p0、p1を通る直線と直線<n,D>との交点を求める
DECLARE NUMERIC l(0 TO 2),m(0 TO 2)
!※交点
!　　　　　　　　　　　　(A,B,D)・(x0,y0,1)
!　(x,y)＝(x0,y0) － -------------------------- × (x1-x0,y1-y0)
!　　　　　　　　　　 (A,B,D)・(x1-x0,y1-y0,0)

LET l(0)=p1(0)-p0(0) !x1-x0
LET l(1)=p1(1)-p0(1) !y1-y0
LET l(2)=0
LET tt=DOT(Ln,l) !(A,B,D)・(x1-x0,y1-y0,0)

IF ABS(tt)<c_Eps THEN !平行なら
PRINT "直線と直線との交点: tt=0です。"
ELSE !交点があれば
LET t=DOT(p0,Ln) !(A,B,D)・(x0,y0,1)
MAT m=(t/tt)*l !式の後ろ側

LET c(0)=p0(0)-m(0)
LET c(1)=p0(1)-m(1)
END IF
END SUB

EXTERNAL SUB LineSet(nx,ny,D, Ln()) !法線ベクトルと原点からの符号付き距離で直線を表す
LET Ln(0)=nx
LET Ln(1)=ny
LET Ln(2)=D
END SUB

EXTERNAL SUB plot_line(fx,fy, tx,ty) !点(fx,fy)から点(tx,ty)へ線分を描く
PLOT LINES: fx,fy; tx,ty
END SUB

!点
EXTERNAL SUB Vec2Set(x,y, v())
LET v(0)=x
LET v(1)=y
LET v(2)=1
END SUB

END MODULE

　　　│　　　　└毎回大変有り難うございます。 SECOND 2007/02/22 01:18:59  ツリーへ

Re: さらに続き 返事を書くノートメニュー

SECOND <cszcthjjdj> 2007/02/22 01:18:59

毎回大変有り難うございます。
趣旨は、
厳密な処理を、どれくらい短い文で実現・・、です。（＾＾；）

　　　│　　　　　└続き SECOND 2007/02/22 02:34:38  ツリーへ

Re: 毎回大変有り難うございます。 返事を書くノートメニュー

SECOND <cszcthjjdj> 2007/02/22 02:34:38

続き
訂正、大きなバグ(が)あった。←ががぬけてる・・のリスト中で、
draw disk.. と、wait delay..　を、取り外し、
plot lines だけで高速に走らせてみると、四隅近傍の
不正は無くなったようですが、急場に付け加えたｓなる変数が、
気に入りません。よけいな変数を、追加しないでも出来そうに
思えるのです。それにアルゴリズムも、きたない、重複がある。

　　　│　　　　　　└続き SECOND 2007/02/22 07:28:38  ツリーへ

Re: 続き 返事を書くノートメニュー

SECOND <cszcthjjdj> 2007/02/22 07:28:38

続き
やはり、今のままの方が、演算量が少なく、短く済むようです。
と言うのは、交点計算を省略できる。

四隅近傍において、bx,by ともにはみ出している場合、

はみ出し bx を、取り合えず無条件に先行させて壁面、又はその延長へ引き戻すと、
その座標(x,y)は、( IP(bx), by-my/mx*FP(bx) ) となりますが、(step<1 の制限)

左右の壁面に、交点があれば、Y のはみ出しも、同時に消滅します。
上下の壁面に、交点があれば、Y のはみ出しは、残っています。

交点が上下と左右の壁の、どちら側にあるかの、判定を、計算に依らず

はみ出し bx 処理のあと、はみ出し by 処理が無ければ、交点は、左右にあった。(mx 反転のみ)
はみ出し bx 処理のあと、はみ出し by 処理が有れば、　交点は、上下にあった。(my 反転のみ)

という事ですので、変数 S の情報追加は、仕方ないかもしれません。

上記の座標は、( SGN(bx)*8, by-my/mx*(bx-SGN(bx)*8) ) にすれば、1<step 可。

後で、直します。

　　　├!ステップ幅が１より大きくても良いようにし... SECOND 2007/02/22 07:45:35  ツリーへ

Re: !動きが面白く、文が短いのは、すばらしいと... 返事を書くノートメニュー

SECOND <cszcthjjdj> 2007/02/22 07:45:35

!ステップ幅が１より大きくても良いようにした。
!このリストは、１より大きい試験ステップになっていて、速いので、
!mx,my を適宜に、小さく直して下さい。

!以下の条件では、ベルヌーイ・シフト写像に似たような、
!無理数の左シフト相当を続けており、カオス状態だと思います。
!周期点がないので、再び白紙に戻る事は無く、履歴線は、
!全体を埋め尽くします。

OPTION ARITHMETIC DECIMAL_HIGH ! 10進1000桁
SET WINDOW -9,9,-9,9
! 　　　　　　ボールの初期位置 bx=by=0 デフォルト
LET mx=SQR(2)!/4 ! ボールのX速度、ステップ⊿X　(mx=8/25, my=8/16
LET my=SQR(3)!/5 ! ボールのY速度、ステップ⊿Y　　等では白紙に戻る)
LET r=0.7 ! 　ボールの半径
PLOT LINES:-8-r,8+r; 8+r,8+r; 8+r,-8-r; -8-r,-8-r; -8-r,8+r ! 壁面

SET DRAW MODE NOTXOR ! ２度書きで消える NOTXOR モード
SET LINE COLOR 2 ! 青
SET AREA COLOR 2 ! 青
DO
DRAW disk WITH SCALE(r)*SHIFT(bx,by) ! ボールを書く
WAIT DELAY 0.01
DRAW disk WITH SCALE(r)*SHIFT(bx,by) ! ボールだけを消す
PLOT LINES : bx,by; ! 履歴線を（書く・消す）
LET bx=bx+mx
LET by=by+my
LET s=0
IF 8<ABS(bx) THEN
LET by=by-my/mx*(bx-SGN(bx)*8) ! X端座標x,y
LET bx=SGN(bx)*8
LET s=1
END IF
IF 8<ABS(by) THEN
LET bx=bx-mx/my*(by-SGN(by)*8) ! Y端座標x,y
LET by=SGN(by)*8
LET my=-my ! Y速度反転
LET s=2
END IF
IF s=1 THEN LET mx=-mx ! X速度反転
LOOP

END

　　　│└前出プログラムの最適化（変数Ｓの削除） 山中和義 2007/02/22 11:46:00  ツリーへ

Re: !ステップ幅が１より大きくても良いようにし... 返事を書くノートメニュー

山中和義 <drdlxujciw> 2007/02/22 11:46:00

前出プログラムの最適化（変数Ｓの削除）

クリッピングで
「どの壁からはみ出したかを求める（交点）」のと
「反転（交点の箇所）」とを
分けて考えるといいと思います。

、
SET WINDOW -9,9,-9,9
! 　　　　　　ボールの初期位置 bx=by=0 デフォルト
LET mx=SQR(2)!/4 ! ボールのX速度、ステップ⊿X　(mx=8/25, my=8/16
LET my=SQR(3)!/5 ! ボールのY速度、ステップ⊿Y　　等では白紙に戻る)
LET r=0.7 ! 　ボールの半径
PLOT LINES:-8-r,8+r; 8+r,8+r; 8+r,-8-r; -8-r,-8-r; -8-r,8+r ! 壁面

SET DRAW MODE NOTXOR ! ２度書きで消える NOTXOR モード
SET LINE COLOR 2 ! 青
SET AREA COLOR 2 ! 青
DO
DRAW disk WITH SCALE(r)*SHIFT(bx,by) ! ボールを書く
WAIT DELAY 0.01
DRAW disk WITH SCALE(r)*SHIFT(bx,by) ! ボールだけを消す
PLOT LINES : bx,by; ! 履歴線を（書く・消す）
LET bx=bx+mx
LET by=by+my
IF 8<ABS(bx) THEN !左右端でクリッピング
LET by=by-my/mx*(bx-SGN(bx)*8)
LET bx=SGN(bx)*8
!!!LET mx=-mx! X速度反転　※ここでしない
END IF
IF 8<ABS(by) THEN !上下端でクリッピング
LET bx=bx-mx/my*(by-SGN(by)*8)
LET by=SGN(by)*8
!!!LET my=-my ! Y速度反転　※ここでしない
END IF
IF ABS(bx)=8 THEN LET mx=-mx ! X速度反転
IF ABS(by)=8 THEN LET my=-my ! Y速度反転
LOOP

END

　　　│　└!有り難うございました。 SECOND 2007/02/22 17:12:32  ツリーへ

Re: 前出プログラムの最適化（変数Ｓの削除） 返事を書くノートメニュー

SECOND <cszcthjjdj> 2007/02/22 17:12:32

!有り難うございました。
!mx=my=0.5 でバグがでています。

　　　│　　└バグは無いです。 SECOND 2007/02/22 18:59:23  ツリーへ

Re: !有り難うございました。 返事を書くノートメニュー

SECOND <cszcthjjdj> 2007/02/22 18:59:23

バグは無いです。
ただ、液晶パネルのタイミングのためか？
mx=my=0.5 のとき、
角に当る手前で、戻るように時々見えるのはなぜか？
もう少し詳細にトレースします。
ありがとう、ございました。

　　　└!これで、すっきりです。 SECOND 2007/02/22 23:04:14  ツリーへ

Re: !動きが面白く、文が短いのは、すばらしいと... 返事を書くノートメニュー

SECOND <cszcthjjdj> 2007/02/22 23:04:14

!これで、すっきりです。
!このリストは、１より大きい試験ステップになっていて、速いので、
!mx,my を適宜に、小さく直して下さい。

!以下の条件では、ベルヌーイ・シフト写像に似たような、
!無理数の左シフト相当を続けており、カオス状態だと思います。
!周期点がないので、再び白紙に戻る事は無く、履歴線は、
!全体を埋め尽くします。

OPTION ARITHMETIC DECIMAL_HIGH ! 10進1000桁
SET WINDOW -9,9,-9,9
! 　　　　　　ボールの初期位置 bx=by=0 デフォルト
LET mx=SQR(2)!/4 ! ボールのX速度、ステップ⊿X　(mx=8/25, my=8/16
LET my=SQR(3)!/5 ! ボールのY速度、ステップ⊿Y　　等では白紙に戻る)
LET r=0.7 ! 　ボールの半径
PLOT LINES:-8-r,8+r; 8+r,8+r; 8+r,-8-r; -8-r,-8-r; -8-r,8+r ! 壁面

SET DRAW MODE NOTXOR ! ２度書きで消える NOTXOR モード
SET LINE COLOR 2 ! 青
SET AREA COLOR 2 ! 青
DO
DRAW disk WITH SCALE(r)*SHIFT(bx,by) ! ボールを書く
WAIT DELAY 0.01
DRAW disk WITH SCALE(r)*SHIFT(bx,by) ! ボールだけを消す
PLOT LINES : bx,by; ! 履歴線を（書く・消す）
LET bx=bx+mx
LET by=by+my

IF 8=<ABS(bx) THEN
LET by=by-my/mx*(bx-SGN(bx)*8) ! X端座標x,y
LET bx=SGN(bx)*8
IF ABS(by)=<8 THEN LET mx=-mx ! X速度反転
END IF
IF 8=<ABS(by) THEN
LET bx=bx-mx/my*(by-SGN(by)*8) ! Y端座標x,y
LET by=SGN(by)*8
LET my=-my ! Y速度反転
END IF

LOOP

END

インデックスへ EXIT
新規発言を反映させるにはブラウザの更新ボタンを押してください。

中学校技術科で使っています	返事を書くノートメニュー
藤原達也 <oqpbepsfnm> 2007/02/18 22:58:00
お世話になります。中学校技術科の情報基礎でこのＢＡＳＩＣを使っています。もう５年ぐらい使っているので、いろいろなデータがあります。他に、このような用途を考えている方がいらっしゃるとデータを差し上げますのでご連絡ください。生徒は現在、ピンポンゲームを学習中です（笑）。 set window -8,8,-8,8 !最初のホ゛ールの位置(bx,by) !ホ゛ールが一度に動く距離(mx,my) let bx=0 let by=0 let mx=0.3 let my=0.5 10 set area color 4 draw disk with scale(0.3)shift(bx,by) if bx<-8 or bx>8 then let mx=mx(-1) if by<-8 or by>8 then let my=my(-1) wait delay 0.01 !同じ位置に白色の円を描いて消している set area color 0 draw disk with scale(0.3)shift(bx,by) let bx=bx+mx let by=by+my goto 10 end

Re: 中学校技術科で使っています	返事を書くノートメニュー
SECOND <cszcthjjdj> 2007/02/19 08:26:59
!動きが面白く、文が短いのは、すばらしいと思います。 !それに魅せられて、履歴線を付けてみました。上書き御免ください。 !不思議な周期動作です。 SET WINDOW -8,8,-8,8 !最初のボールの位置(bx,by) !ボールが一度に動く距離(mx,my) LET bx=0 LET by=0 LET mx=0.32 LET my=0.5 SET DRAW MODE NOTXOR SET LINE COLOR 2 SET AREA COLOR 4 DO DRAW disk WITH SCALE(0.3)SHIFT(bx,by) ! 赤色の円 WAIT DELAY 0.01 DRAW disk WITH SCALE(0.3)SHIFT(bx,by) !線を消さず、赤色の円だけを消す( NOTXOR) PLOT LINES : bx,by; ! 線を書き、２度書きで消える( NOTXOR) LET bx=bx+mx LET by=by+my IF 8<ABS(bx) THEN LET by=by-my/mxFP(bx) LET bx=IP(bx) LET mx=-mx END IF IF 8<ABS(by) THEN LET bx=bx-mx/myFP(by) LET by=IP(by) LET my=-my END IF LOOP END

Re: !動きが面白く、文が短いのは、すばらしいと...	返事を書くノートメニュー
SECOND <cszcthjjdj> 2007/02/20 17:02:51
!もう少し凝ってみました。 OPTION ARITHMETIC RATIONAL !ステップ加算の累積誤差を押える。 !　　　　　　　ボールの初期位置 bx=by=0 デフォルトを使用。 LET mx= 8/25 ! ボールのX速度、ステップ⊿X　分数式で８に命中。 LET my= 8/16 ! ボールのY速度、ステップ⊿Y　分数式で８に命中。 LET r = 1 !　ボールの半径 SET WINDOW -8-r1.3, 8+r1.3, -8-r1.3, 8+r1.3 PLOT LINES:-8-r,8+r; 8+r,8+r; 8+r,-8-r; -8-r,-8-r; -8-r,8+r ! 壁面 SET DRAW MODE NOTXOR ! ２度書きで消える NOTXOR モード SET LINE COLOR 2 ! 青 SET AREA COLOR 2 ! 青 DO DRAW disk WITH SCALE(r)SHIFT(bx,by) ! ボールを書く WAIT DELAY 0.01 DRAW disk WITH SCALE(r)SHIFT(bx,by) ! ボールだけを消す PLOT LINES : bx,by; ! 履歴線を（書く・消す） LET bx=bx+mx LET by=by+my IF 8=<ABS(bx) THEN LET mx=-mx ! X速度反転 IF 8=<ABS(by) THEN LET my=-my ! Y速度反転 LOOP END

Re: !もう少し凝ってみました。	返事を書く
SECOND <cszcthjjdj> 2007/02/20 22:39:53 ** この記事は削除されました

Re: !動きが面白く、文が短いのは、すばらしいと...	返事を書くノートメニュー
SECOND <cszcthjjdj> 2007/02/21 05:19:14
!訂正、大きなバグあった。四隅の、反転位置補正と、速度反転の際、 !(bx=-8.094, by=+8.467) のように、両方が越えていて、かつ ! by の、出かたが大きいと、正しく処理されていなかった。 !以下の条件では、ベルヌーイ・シフト写像に似たような、 !無理数の左シフト相当を続けており、カオス状態だと思います。 !周期点がないので、再び白紙に戻る事は無く、履歴線は、 !全体を埋め尽くします。 OPTION ARITHMETIC DECIMAL_HIGH ! 10進1000桁 SET WINDOW -9,9,-9,9 ! 　　　　　　ボールの初期位置 bx=by=0 デフォルト LET mx=SQR(2)/4 ! ボールのX速度、ステップ⊿X　(mx=8/25, my=8/16 LET my=SQR(5)/5 ! ボールのY速度、ステップ⊿Y　　等では白紙に戻る) LET r=0.7 ! 　ボールの半径 PLOT LINES:-8-r,8+r; 8+r,8+r; 8+r,-8-r; -8-r,-8-r; -8-r,8+r ! 壁面 SET DRAW MODE NOTXOR ! ２度書きで消える NOTXOR モード SET LINE COLOR 2 ! 青 SET AREA COLOR 2 ! 青 DO DRAW disk WITH SCALE(r)SHIFT(bx,by) ! ボールを書く WAIT DELAY 0.01 DRAW disk WITH SCALE(r)SHIFT(bx,by) ! ボールだけを消す PLOT LINES : bx,by; ! 履歴線を（書く・消す） LET bx=bx+mx LET by=by+my LET s=0 IF 8<ABS(bx) THEN LET by=by-my/mxFP(bx) ! X端座標x,y LET bx=IP(bx) LET s=1 END IF IF 8<ABS(by) THEN LET bx=bx-mx/myFP(by) ! Y端座標x,y LET by=IP(by) LET my=-my ! Y速度反転 LET s=2 END IF IF s=1 THEN LET mx=-mx ! X速度反転 LOOP END

Re: !訂正、大きなバグあった。四隅の、反転位置...	返事を書くノートメニュー
SECOND <cszcthjjdj> 2007/02/21 16:57:58
四隅の処理に、難解な問題がある。この掲示板に、図の掲示ができると、そのケースを明快に図示、できるのであるが、やむおえません。例として、壁の左上隅の近傍の場合、壁の上辺を横切ってから、さらに左辺の延長上を、横切っている場合、進入角度次第で、bx,by の、どちらが大きくはみ出ているかは不定。しかし、この場合は、速度反転が、by だけであるので、 bx よりも by を先に処理しないと、bx まで反転してしまう。結論から言うと、上下の辺を横切っている場合、bx,by はみ出し量を問わず、　　　　　はみ出し⊿by だけで、壁交点(bx,by)を求め、Y速度のみ反転する。左右の辺を横切っている場合、bx,by はみ出し量を問わず、　　　　　はみ出し⊿bx だけで、壁交点(bx,by)を求め、X速度のみ反転する。四隅の点、丁度の時は、以上のいずれかが、処理されていれば、次の移動時に、もう反対側も処理される。この場合、ボールは、四隅の点の同じ場所に、２度プロットされ、３度目で移動される。微細な幅の反転が、重なっているとする。現状は、この状態です。が、・・ややいい加減で、もう少しきれいにならないものか？

Re: 四隅の処理に、難解な問題がある。	返事を書くノートメニュー
山中和義 <drdlxujciw> 2007/02/21 21:30:45
壁のすり抜けですね！？「ウインドウ・クリッピングの処理をする直線描画」を使って、バウンド位置を補正しています。 SET WINDOW -10,10,-10,10 !!!set window -8,8,-8,8 DRAW grid CALL GL2D.gl2Window(-8,8,-8,8) !最初のボールの位置(bx,by) !ボールが一度に動く距離(mx,my) LET bx=0 LET by=0 LET mx=1.3 !!!!!大きくするとはみ出す LET my=0.5 !!!!! 10 set area color 4 draw disk with scale(0.3)shift(bx,by) IF bx=<-8 OR bx>=8 THEN LET mx=-mx IF by=<-8 OR by>=8 THEN LET my=-my wait delay 0.1 !同じ位置に白色の円を描いて消している !!!set area color 0 !!!draw disk with scale(0.3)shift(bx,by) LET x1=bx !現在位置 LET y1=by LET bx=bx+mx !次の位置 LET by=by+my CALL GL2D.gl2Line(x1,y1,bx,by,1) !次の位置を補正 goto 10 END

Re: 壁のすり抜けですね！？	返事を書くノートメニュー
山中和義 <drdlxujciw> 2007/02/21 21:32:35
続き MODULE GL2D SHARE NUMERIC fLeft(0 TO 2),fRight(0 TO 2),fBottom(0 TO 2),fTop(0 TO 2) CALL gl2Window(-1,1,-1,1) PUBLIC SUB gl2Window EXTERNAL SUB gl2Window(l,r,b,t) CALL LineSet(1,0,-l, fLeft) !ウインドウ範囲を表す直線（法線n、距離D） CALL LineSet(-1,0,r, fRight) CALL LineSet(0,1,-b, fBottom) CALL LineSet(0,-1,t, fTop) END SUB !クリッピング EXTERNAL SUB ClipLine(Ln(), p0(),p1(), numClip) !２点p0、p1を通る直線を直線<n,D>でクリッピングする DECLARE NUMERIC c(0 TO 1) LET f0=DOT(p0,Ln) !点と直線との位置を確認する LET f1=DOT(p1,Ln) IF f0>=0 THEN IF f1>=0 THEN !borth of p[i] and p[i+1] are inside LET numOutput=2 ELSE !p[i]:inside, p[i+1]:outside CALL LineIntersectPoint(Ln,p0,p1, c) !交点を求める LET p1(0)=c(0) LET p1(1)=c(1) LET numOutput=2 END IF ELSE IF f1>=0 THEN !p[i]:outside, p[i+1]:inside CALL LineIntersectPoint(Ln,p0,p1, c) LET p0(0)=c(0) LET p0(1)=c(1) LET numOutput=2 ELSE !no output LET numOutput=0 END IF END IF LET numClip=numOutput END SUB PUBLIC SUB gl2Line EXTERNAL SUB gl2Line(x1,y1,x2,y2,c) !線分の描画　LINE(x1,y1)-(x2,y2),c DECLARE NUMERIC p0(0 TO 2),p1(0 TO 2) IF c>=0 THEN SET LINE COLOR c !色を設定する CALL Vec2Set(x1,y1, p0) !始点 CALL Vec2Set(x2,y2, p1) !終点 LET numClip=2 !クリッピングする頂点の数 CALL ClipLine(fLeft, p0,p1,numClip) !ウインドウの左端でクリッピングする IF numClip=0 THEN EXIT SUB CALL ClipLine(fTop, p0,p1,numClip) !上 IF numClip=0 THEN EXIT SUB CALL ClipLine(fBottom, p0,p1,numClip) !下 IF numClip=0 THEN EXIT SUB CALL ClipLine(fRight, p0,p1,numClip) !右 IF numClip=0 THEN EXIT SUB CALL plot_line(p0(0),p0(1), p1(0),p1(1)) !線分を描く LET x2=p1(0) !差し戻し LET y2=p1(1) END SUB

Re: 続き	返事を書くノートメニュー
山中和義 <drdlxujciw> 2007/02/21 21:33:30
さらに続き !直線 EXTERNAL SUB LineIntersectPoint(Ln(),p0(),p1(), c()) !２点p0、p1を通る直線と直線<n,D>との交点を求める DECLARE NUMERIC l(0 TO 2),m(0 TO 2) !※交点 !　　　　　　　　　　　　(A,B,D)・(x0,y0,1) !　(x,y)＝(x0,y0) － -------------------------- × (x1-x0,y1-y0) !　　　　　　　　　　 (A,B,D)・(x1-x0,y1-y0,0) LET l(0)=p1(0)-p0(0) !x1-x0 LET l(1)=p1(1)-p0(1) !y1-y0 LET l(2)=0 LET tt=DOT(Ln,l) !(A,B,D)・(x1-x0,y1-y0,0) IF ABS(tt)<c_Eps THEN !平行なら PRINT "直線と直線との交点: tt=0です。" ELSE !交点があれば LET t=DOT(p0,Ln) !(A,B,D)・(x0,y0,1) MAT m=(t/tt)*l !式の後ろ側 LET c(0)=p0(0)-m(0) LET c(1)=p0(1)-m(1) END IF END SUB EXTERNAL SUB LineSet(nx,ny,D, Ln()) !法線ベクトルと原点からの符号付き距離で直線を表す LET Ln(0)=nx LET Ln(1)=ny LET Ln(2)=D END SUB EXTERNAL SUB plot_line(fx,fy, tx,ty) !点(fx,fy)から点(tx,ty)へ線分を描く PLOT LINES: fx,fy; tx,ty END SUB !点 EXTERNAL SUB Vec2Set(x,y, v()) LET v(0)=x LET v(1)=y LET v(2)=1 END SUB END MODULE

Re: さらに続き	返事を書くノートメニュー
SECOND <cszcthjjdj> 2007/02/22 01:18:59
毎回大変有り難うございます。趣旨は、厳密な処理を、どれくらい短い文で実現・・、です。（＾＾；）

Re: 毎回大変有り難うございます。	返事を書くノートメニュー
SECOND <cszcthjjdj> 2007/02/22 02:34:38
続き訂正、大きなバグ(が)あった。←ががぬけてる・・のリスト中で、 draw disk.. と、wait delay..　を、取り外し、 plot lines だけで高速に走らせてみると、四隅近傍の不正は無くなったようですが、急場に付け加えたｓなる変数が、気に入りません。よけいな変数を、追加しないでも出来そうに思えるのです。それにアルゴリズムも、きたない、重複がある。

Re: 続き	返事を書くノートメニュー
SECOND <cszcthjjdj> 2007/02/22 07:28:38
続きやはり、今のままの方が、演算量が少なく、短く済むようです。と言うのは、交点計算を省略できる。四隅近傍において、bx,by ともにはみ出している場合、はみ出し bx を、取り合えず無条件に先行させて壁面、又はその延長へ引き戻すと、その座標(x,y)は、( IP(bx), by-my/mxFP(bx) ) となりますが、(step<1 の制限) 左右の壁面に、交点があれば、Y のはみ出しも、同時に消滅します。上下の壁面に、交点があれば、Y のはみ出しは、残っています。交点が上下と左右の壁の、どちら側にあるかの、判定を、計算に依らずはみ出し bx 処理のあと、はみ出し by 処理が無ければ、交点は、左右にあった。(mx 反転のみ) はみ出し bx 処理のあと、はみ出し by 処理が有れば、　交点は、上下にあった。(my 反転のみ) という事ですので、変数 S の情報追加は、仕方ないかもしれません。上記の座標は、( SGN(bx)8, by-my/mx(bx-SGN(bx)8) ) にすれば、1<step 可。後で、直します。

Re: !動きが面白く、文が短いのは、すばらしいと...	返事を書くノートメニュー
SECOND <cszcthjjdj> 2007/02/22 07:45:35
!ステップ幅が１より大きくても良いようにした。 !このリストは、１より大きい試験ステップになっていて、速いので、 !mx,my を適宜に、小さく直して下さい。 !以下の条件では、ベルヌーイ・シフト写像に似たような、 !無理数の左シフト相当を続けており、カオス状態だと思います。 !周期点がないので、再び白紙に戻る事は無く、履歴線は、 !全体を埋め尽くします。 OPTION ARITHMETIC DECIMAL_HIGH ! 10進1000桁 SET WINDOW -9,9,-9,9 ! 　　　　　　ボールの初期位置 bx=by=0 デフォルト LET mx=SQR(2)!/4 ! ボールのX速度、ステップ⊿X　(mx=8/25, my=8/16 LET my=SQR(3)!/5 ! ボールのY速度、ステップ⊿Y　　等では白紙に戻る) LET r=0.7 ! 　ボールの半径 PLOT LINES:-8-r,8+r; 8+r,8+r; 8+r,-8-r; -8-r,-8-r; -8-r,8+r ! 壁面 SET DRAW MODE NOTXOR ! ２度書きで消える NOTXOR モード SET LINE COLOR 2 ! 青 SET AREA COLOR 2 ! 青 DO DRAW disk WITH SCALE(r)SHIFT(bx,by) ! ボールを書く WAIT DELAY 0.01 DRAW disk WITH SCALE(r)SHIFT(bx,by) ! ボールだけを消す PLOT LINES : bx,by; ! 履歴線を（書く・消す） LET bx=bx+mx LET by=by+my LET s=0 IF 8<ABS(bx) THEN LET by=by-my/mx(bx-SGN(bx)8) ! X端座標x,y LET bx=SGN(bx)8 LET s=1 END IF IF 8<ABS(by) THEN LET bx=bx-mx/my(by-SGN(by)8) ! Y端座標x,y LET by=SGN(by)8 LET my=-my ! Y速度反転 LET s=2 END IF IF s=1 THEN LET mx=-mx ! X速度反転 LOOP END

Re: !ステップ幅が１より大きくても良いようにし...	返事を書くノートメニュー
山中和義 <drdlxujciw> 2007/02/22 11:46:00
前出プログラムの最適化（変数Ｓの削除）クリッピングで「どの壁からはみ出したかを求める（交点）」のと「反転（交点の箇所）」とを分けて考えるといいと思います。、 SET WINDOW -9,9,-9,9 ! 　　　　　　ボールの初期位置 bx=by=0 デフォルト LET mx=SQR(2)!/4 ! ボールのX速度、ステップ⊿X　(mx=8/25, my=8/16 LET my=SQR(3)!/5 ! ボールのY速度、ステップ⊿Y　　等では白紙に戻る) LET r=0.7 ! 　ボールの半径 PLOT LINES:-8-r,8+r; 8+r,8+r; 8+r,-8-r; -8-r,-8-r; -8-r,8+r ! 壁面 SET DRAW MODE NOTXOR ! ２度書きで消える NOTXOR モード SET LINE COLOR 2 ! 青 SET AREA COLOR 2 ! 青 DO DRAW disk WITH SCALE(r)SHIFT(bx,by) ! ボールを書く WAIT DELAY 0.01 DRAW disk WITH SCALE(r)SHIFT(bx,by) ! ボールだけを消す PLOT LINES : bx,by; ! 履歴線を（書く・消す） LET bx=bx+mx LET by=by+my IF 8<ABS(bx) THEN !左右端でクリッピング LET by=by-my/mx(bx-SGN(bx)8) LET bx=SGN(bx)8 !!!LET mx=-mx! X速度反転　※ここでしない END IF IF 8<ABS(by) THEN !上下端でクリッピング LET bx=bx-mx/my(by-SGN(by)8) LET by=SGN(by)8 !!!LET my=-my ! Y速度反転　※ここでしない END IF IF ABS(bx)=8 THEN LET mx=-mx ! X速度反転 IF ABS(by)=8 THEN LET my=-my ! Y速度反転 LOOP END

Re: 前出プログラムの最適化（変数Ｓの削除）	返事を書くノートメニュー
SECOND <cszcthjjdj> 2007/02/22 17:12:32
!有り難うございました。 !mx=my=0.5 でバグがでています。

Re: !有り難うございました。	返事を書くノートメニュー
SECOND <cszcthjjdj> 2007/02/22 18:59:23
バグは無いです。ただ、液晶パネルのタイミングのためか？ mx=my=0.5 のとき、角に当る手前で、戻るように時々見えるのはなぜか？もう少し詳細にトレースします。ありがとう、ございました。

Re: !動きが面白く、文が短いのは、すばらしいと...	返事を書くノートメニュー
SECOND <cszcthjjdj> 2007/02/22 23:04:14
!これで、すっきりです。 !このリストは、１より大きい試験ステップになっていて、速いので、 !mx,my を適宜に、小さく直して下さい。 !以下の条件では、ベルヌーイ・シフト写像に似たような、 !無理数の左シフト相当を続けており、カオス状態だと思います。 !周期点がないので、再び白紙に戻る事は無く、履歴線は、 !全体を埋め尽くします。 OPTION ARITHMETIC DECIMAL_HIGH ! 10進1000桁 SET WINDOW -9,9,-9,9 ! 　　　　　　ボールの初期位置 bx=by=0 デフォルト LET mx=SQR(2)!/4 ! ボールのX速度、ステップ⊿X　(mx=8/25, my=8/16 LET my=SQR(3)!/5 ! ボールのY速度、ステップ⊿Y　　等では白紙に戻る) LET r=0.7 ! 　ボールの半径 PLOT LINES:-8-r,8+r; 8+r,8+r; 8+r,-8-r; -8-r,-8-r; -8-r,8+r ! 壁面 SET DRAW MODE NOTXOR ! ２度書きで消える NOTXOR モード SET LINE COLOR 2 ! 青 SET AREA COLOR 2 ! 青 DO DRAW disk WITH SCALE(r)SHIFT(bx,by) ! ボールを書く WAIT DELAY 0.01 DRAW disk WITH SCALE(r)SHIFT(bx,by) ! ボールだけを消す PLOT LINES : bx,by; ! 履歴線を（書く・消す） LET bx=bx+mx LET by=by+my IF 8=<ABS(bx) THEN LET by=by-my/mx(bx-SGN(bx)8) ! X端座標x,y LET bx=SGN(bx)8 IF ABS(by)=<8 THEN LET mx=-mx ! X速度反転 END IF IF 8=<ABS(by) THEN LET bx=bx-mx/my(by-SGN(by)8) ! Y端座標x,y LET by=SGN(by)8 LET my=-my ! Y速度反転 END IF LOOP END