|
|
白石先生、名無しさん。
いろいろ検証した結果、どうやら私のパコソンのパフォーマンスが悪すぎたようです。
この際だから、改良して再びトライしたやつをアップしときます。
反応が極めて悪くごくたまにしか反応しません。どうも東芝のパコソンは全部作りが安っぽいんだよなあ。
ソース
SET COLOR mode"native"
OPTION BASE 0
DEF kaku(n)=PI/2*n
LET name$="" !任意の画像ファイル名
gload name$
ASK PIXEL SIZE(0,1;1,0)A,B
LET cp=45-1
LET aa=IP(a/(cp+1))
LET bb=IP(b/(cp+1))
LET xcel=aa-1
LET ycel=bb-1
DIM cm(cp,cp),cs(aa*bb-1,cp,cp),ID(ycel,xcel),idmo(ycel,xcel),IDku(ycel,xcel),ckyu(cp,cp),rot(aa*bb-1)
LET igaid=-1
LET igawh1=-1
LET palid=-1
SET WINDOW 0,a-1,b-1,0
FOR yd=0TO ycel
FOR xd=0TO xcel
LET n=aa*yd+xd
FOR y=0TO cp
FOR x=0TO cp
ASK PIXEL VALUE((cp+1)*xd+x,(cp+1)*yd+y)cs(n,y,x)
NEXT x
NEXT y
NEXT xd
NEXT yd
LET celba=cp+61
LET xpix=celba*aa
LET ypix=celba*bb
LET xpix2p=(cp+1)*aa-1
LET ypix2p=(cp+1)*bb-1
SET bitmap SIZE xpix,ypix
SET WINDOW 0,xpix-1,ypix-1,0
CALL 黒
DIM wh1(xpix-1,ypix-1),wh2(xpix2p+24,ypix2p+24+celba)
CALL shuffle
FOR yd=1 TO ycel
PLOT 0,celba*yd;xpix-1,celba*yd
NEXT YD
FOR xd=1 TO xcel
PLOT celba*xd,0;celba*xd,ypix-1
NEXT XD
CALL 凸凹ロオテイニ
LET x=0
LET y=0
SET AREA COLOR 0
DO
mouse poll xm,ym,l,r
IF l=1 THEN LET swl=1
IF r=1 THEN LET swr=1
IF -1<x AND x<xcel AND -1<y AND y<ycel THEN
LET x=INT(xm/celba)
LET y=INT(ym/celba)
IF swr=1 AND r=0 THEN CALL 組立面移動
IF swl=1 AND l=0 THEN
IF id(y,x)<0THEN
pause"それはエラーだね"&CHR$(13)&CHR$(10)&"ウッ!"
ELSE
CALL 囲い
CALL 決定
CALL 組立面移動
END IF
END IF
END IF
LOOP
SUB 凸凹ロオテイニ
FOR yd=0 TO ycel
FOR xd=0 TO xcel
LET n=id(yd,xd)
LET rot(n)=INT(RND*3)
DRAW 凸凹ロオテ(n)WITH ROTATE(kaku(rot(n)))*SHIFT(celba*xd+30+cp/2,celba*yd+30+cp/2)
NEXT XD
NEXT YD
END SUB
SUB 囲い
SET LINE width 9
SET LINE COLOR 0
SET LINE COLOR"blue"
LET xccn=celba*x
LET yccn=celba*y
PLOT xccn+5,yccn+5;xccn+celba-5,yccn+5;xccn+celba-5,yccn+celba-5;xccn+5,yccn+celba-5;xccn+5,yccn+5
END SUB
SUB 決定
LET xccn=celba*x
LET yccn=celba*y
ASK PIXEL ARRAY(xccn+30,yccn+30)cm
LET n=id(y,x)
LET igaid=n
LET igawh1=aa*y+x
LET id(y,x)=-1
PLOT AREA:xccn+1,yccn+1;xccn+celba-1,yccn+1;xccn+celba-1,yccn+celba-1;xccn+1,yccn+celba-1
END SUB
SUB shuffle
LET n=aa*bb-1
MAT id=(-1)*CON
FOR o=0 TO n
DO
LET xd2=INT(RND*aa)
LET yd2=INT(RND*bb)
IF id(yd2,xd2)<0THEN
LET id(yd2,xd2)=o
EXIT DO
END IF
LOOP
NEXT o
END SUB
SUB 組立面イニ
SET LINE width 9
set line color"black"
LET xccn=celba*x
LET yccn=celba*y
PLOT xccn+5,yccn+5;xccn+celba-5,yccn+5;xccn+celba-5,yccn+celba-5;xccn+5,yccn+celba-5;xccn+5,yccn+5
ASK PIXEL ARRAY(0,0)wh1
SET bitmap SIZE xpix2p+1+24,ypix2p+1+24+celba
SET WINDOW -12,xpix2p+12,ypix2p+12+celba,-12
CLEAR
SET LINE width 1
SET LINE COLOR 16777215
PLOT -12,ypix2p+1+12;xpix2p+1+12,ypix2p+1+12
MAT idku=(-1)*CON
MAT idmo=idku
LET kais=1
LET palid=-1
LET palwh1=-1
SET TEXT HEIGHT 12
SET TEXT JUSTIFY"center","top"
SET AREA COLOR 255
PLOT AREA:70,ypix2p+1+12+10;129,ypix2p+1+12+10;129,ypix2p+1+12+39;70,ypix2p+1+12+39
PLOT TEXT,AT 100,ypix2p+1+12+18:"切替"
SET AREA COLOR 16711935
PLOT AREA:150,ypix2p+1+12+10;209,ypix2p+1+12+10;209,ypix2p+1+12+39;150,ypix2p+1+12+39
PLOT TEXT,AT 180,ypix2p+1+12+18:"移動"
END SUB
SUB ボタン反応(x,c)
SET LINE width 5
SET LINE COLOR 16711680
PLOT LINES:70+2,ypix2p+1+12+10+2;129,ypix2p+1+12+10+2;129-2,ypix2p+1+12+39-2;70+2,ypix2p+1+12+39-2;70+2,ypix2p+1+12+10+2
WAIT DELAY .4
SET LINE COLOR c
PLOT LINES:70+2,ypix2p+1+12+10+2;129,ypix2p+1+12+10+2;129-2,ypix2p+1+12+39-2;70+2,ypix2p+1+12+39-2;70+2,ypix2p+1+12+10+2
END SUB
SUB 組立面移動
IF kais=0THEN CALL 組立面イニ ELSE CALL 画面12
LET swl=0
LET swr=0
WAIT DELAY 1.5
SET LINE width 1
SET LINE COLOR"green"
SET AREA COLOR 0
LET x=0
LET y=0
LET xold=0
LET yold=0
IF igaid>-1THEN
ASK PIXEL ARRAY((cp+1)*x,(cp+1)*y)ckyu
MAT PLOT CELLS,IN (cp+1)*x,(cp+1)*y;(cp+1)*x+cp,(cp+1)*y+cp:cm
PLOT LINES:(cp+1)*x,(cp+1)*y;(cp+1)*x+cp,(cp+1)*y;(cp+1)*x+cp,(cp+1)*y+cp;(cp+1)*x,(cp+1)*y+cp;(cp+1)*x,(cp+1)*y
DO
mouse poll xm,ym,l,r
IF l=1 THEN LET swl=0
IF r=1 THEN LET swr=0
LET x=INT(xm/(cp+1))
LET y=INT(ym/(cp+1))
IF -1<x AND x<aa AND -1<y AND y<bb THEN
IF l=0 AND swl=1THEN
IF idku(y,x)<0THEN
CALL 復活(0,0,ckyu)
CALL 嵌込
LET swl=0
LET swr=0
EXIT DO
END IF
ELSEIF r=0 AND swr=1 THEN
LET xccn=(cp+1)*x
LET yccn=(cp+1)*y
DRAW ロオテ(rot(igaid),cm)WITH ROTATE(kaku(1))*SHIFT(cp/2+xccn,cp/2+yccn)
ASK PIXEL ARRAY(xccn,yccn)cm
PLOT LINES:xccn,yccn;xccn+cp,yccn;xccn+cp,yccn+cp;xccn,yccn+cp;xccn,yccn
LET swl=0
LET swr=0
END IF
END IF
LOOP
END IF
LET swl=0
LET swr=0
LET f=0
LET f2=1
DO
mouse poll xm,ym,l,r
IF l=1 THEN LET swl=1
IF r=1 THEN LET swr=1
IF l=0 AND swl=1 OR r=0 AND swr=1THEN
IF -1<xm AND xm<(cp+1)*aa AND -1<ym AND ym<(cp+1)*bb THEN
LET x=INT(xm/(cp+1))
LET y=INT(ym/(cp+1))
IF -1<x AND x<aa AND -1<y AND y<bb THEN
IF l=0 AND swl=1THEN
CALL 選嵌
LET swl=0
ELSEIF r=0 AND swr=1THEN
IF igaid>-1THEN
IF y>-1THEN
LET xccn=x*(cp+1)-10
LET yccn=y*(cp+1)-10
ELSE
LET xccn=-10
LET yccn=ypix2p+1+12+20
END IF
DRAW ロオテ(rot(igaid),cm)WITH ROTATE(kaku(1))*SHIFT(cp/2+xccn-10,cp/2+yccn-10)
ASK PIXEL ARRAY(xccn,yccn)cm
PLOT LINES:xccn,yccn;xccn+cp+20,yccn;xccn+cp+20,yccn+cp+20;xccn,yccn+cp+20;xccn,yccn
LET swr=0
END IF
END IF
END IF
END IF
END IF
IF l=0 AND swl=1 THEN
IF -1<x AND x<aa AND -1<y AND y<bb THEN
IF ypix2p+1+12+10<ym AND ym<ypix2p+1+12+40 AND 70<xm AND xm<130 THEN
IF igaid>-1THEN
CALL ボタン反応(150,16111935)
caLL 面間移動
LET swl=0
LET swr=0
EXIT SUB
END IF
ELSEIF ypix2p+1+12+10<ym AND ym<ypix2p+1+12+40 AND 150<xm AND xm<209THEN
IF igaid<0THEN
CALL ボタン反応(70,255)
CALL 復活(x,y,ckyu)
CALL 画面21
LET swl=0
LET swr=0
EXIT SUB
END IF
END IF
END IF
END IF
LOOP
END SUB
SUB 復活(xold,yold,c(,))
MAT PLOT CELLS,IN (cp+1)*xold,(cp+1)*yold;(cp+1)*xold+cp,(cp+1)*yold+cp:c
END SUB
SUB 嵌込
LET xccn=(cp+1)*x
LET yccn=(cp+1)*y
FOR o=1 TO 3
sET LINE COLOR"blue"
PLOT xccn,yccn;xccn+cp,yccn;xccn+cp,yccn+cp;xccn,yccn+cp;xccn,yccn
WAIT DELAY .1
sET LINE COLOR"green"
PLOT xccn,yccn;xccn+cp,yccn;xccn+cp,yccn+cp;xccn,yccn+cp;xccn,yccn
WAIT DELAY .1
NEXT O
SET LINE COLOR 0
PLOT xccn,yccn;xccn+cp,yccn;xccn+cp,yccn+cp;xccn,yccn+cp;xccn,yccn
DRAW 凸凹ロオテ(igaid)WITH ROTATE(kaku(rot(igaid)))*SHIFT(cp/2+xccn,cp/2+yccn)
LET idku(y,x)=igaid
LET idmo(y,x)=igawh1
LET igaid=-1
LET f2=1
END SUB
PICTURE ロオテ(r,c(,))
LET r=r+1
IF r>3THEN LET r=0
MAT PLOT CELLS,IN -cp/2,-cp/2;cp/2,cp/2:c
END PICTURE
SUB 選嵌
IF f=0THEN
IF igaid<0AND idku(y,x)>-1THEN
LET xccn=x*(cp+1)-10
LET yccn=y*(cp+1)-10
PLOT AREA:xccn,yccn;xccn+cp,yccn;xccn+cp,yccn+cp;xccn,yccn+cp
ASK PIXEL ARRAY(xccn,yccn)ckyu
DRAW 凸凹ロオテ(idku(y,x)) WITH ROTATE(kaku(rot(idku(y,x))))*SHIFT(xccn+cp/2-10,yccn+cp/2-10)
ASK PIXEL ARRAY(xccn,yccn)cm
SET LINE COLOR"green"
PLOT LINES:xccn,yccn;xccn+cp+20,yccn;xccn+cp+20,yccn+cp+20;xccn,yccn+cp+20;xccn,yccn
LET igaid=idku(y,x)
LET igawh1=idmo(y,x)
LET yold=y
LET idku(y,x)=-1
LET F=1
LET f2=0
END IF
ELSE
IF idku(y,x)<0AND igaid>-1THEN
CALL 嵌込
ASK PIXEL ARRAY((cp+1)*x-10,(cp+1)*y-10)ckyu
LET f=0
END IF
END IF
END SUB
SUB 面間移動
IF y>-1THEN CALL 復活(x,y,ckyu) ELSE PLOT AREA:-10,ypix2p+1+12+20;-10,ypix2p+1+12+20+cp;cp+10,ypix2p+1+12+20+cp+20;cp+10,ypix2p+1+12+20
LET yq=INT(igawh1/aa)
LET xq=MOD(igawh1,aa)
LET id(yq,xq)=igaid
LET igaid=-1
CALL 画面21
LET x=xq
LET y=yq
MAT PLOT CELLS,IN celba*x+20,celba*y+20;celba*x+20+cp+20,celba*y+20+cp+20:cm
CALL 囲い
END SUB
SUB 画面12
SET LINE width 9
SET LINE COLOR 0
LET xccn=celba*x
LET yccn=celba*y
PLOT xccn+5,yccn+5;xccn+celba-5,yccn+5;xccn+celba-5,yccn+celba-5;xccn+5,yccn+celba-5;xccn+5,yccn+5
ASK PIXEL ARRAY(0,0)wh1
SET bitmap SIZE xpix2p+1+24,ypix2p+1+24+celba
SET WINDOW -12,xpix2p+12,ypix2p+12+celba,-12
MAT PLOT CELLS,IN -12,-12;xpix2p+12,ypix2p+12+celba:wh2
END SUB
SUB 画面21
ASK PIXEL ARRAY(-12,-12)wh2
SET bitmap SIZE xpix,ypix
SET WINDOW 0,xpix-1,ypix-1,0
mat plot cells,in 0,0;xpix-1,ypix-1:wh1
END SUBh
PICTURE 凸凹ロオテ(n)
SET AREA COLOR 0
FOR yd2=1 TO cp-1
FOR xd2=1 TO cp-1
SET LINE COLOR cs(n,yd2,xd2)
PLOT xd2-cp/2,yd2-cp/2
NEXT Xd2
NEXT Yd2
END PICTURE
END
EXTERNAL SUB 黒
SET COLOR Mode"regular"
SET COLOR MIX(0)0,0,0
SET COLOR MIX(1)1,1,1
CLEAR
SET COLOR Mode"native"
END SUB
|
|