十進BASICプログラミングについての質問や研究成果の公開にご利用ください。
メッセージ入力枠は右下をドラッグして拡大できます。 画像，URLは省略可能です。
編集/削除キーを入力しなくてもエラーにはなりませんが，何か適当な半角英数字4～8文字を指定してください。
特に，長文投稿の場合，プレビューで最後の行を確認しても，実際には途中で切れてしまうことがあるので，投稿後の確認が必要です。
スライドパズル - しばっち
2025/03/16 (Sun) 07:48:48
スライドパズル
https://ja.wikipedia.org/wiki/15パズル
https://mathlog.info/articles/JUlYR5o0T6S7UcVZkfB9
https://manabitimes.jp/math/979
4*4マスによる15パズルゲームです。
空マス(青マス)をテンキーの2,4,6,8キー又は矢印キーで動かして数字を順に揃えるゲームです。
シャッフル回数を入れるとゲーム開始です。
数字を順に揃えればゲームクリアです。(サンプル画像参照)
時間制限はありません。
Gキーを押すとギブアップです。解答を表示して終わります。
Rキーで再スタートします。(リトライ)
変数SPC値を書き換えると空白マスの位置を変更できます。
DECLARE FUNCTION STICK
DECLARE FUNCTION CHECK
RANDOMIZE
DIM M(4,4),ANSWER(50),MM(4,4)
CALL GINIT(600,600)
SET TEXT HEIGHT 50
SET TEXT JUSTIFY "CENTER","HALF"
SET TEXT COLOR 7
SET LINE COLOR 2
LET SPC=16 ! 1～16まで
FOR J=1 TO 4
FOR I=1 TO 4
LET M(I,J)=4*(J-1)+I
NEXT I
NEXT J
CALL DISPLAY
INPUT PROMPT "シャッフル回数(5-50)=":N
CALL SHUFFLE(N)
MAT MM=M
FOR J=1 TO 4
FOR I=1 TO 4
IF M(I,J)=SPC THEN
LET XT=I
LET YT=J
END IF
NEXT I
NEXT J
DO
DO
DO
LET S=STICK
IF GETKEYSTATE(ORD("G"))<0 OR GETKEYSTATE(ORD("g"))<0 THEN ! ギブアップ
MAT M=MM
LET X,XS=XT
LET Y,YS=YT
CALL DISPLAY
WAIT DELAY .5
FOR I=N TO 1 STEP -1
LET SS=ANSWER(I)
LET P=MOVE(SS)
CALL DISPLAY
WAIT DELAY .5
NEXT I
SET TEXT HEIGHT 50
SET TEXT COLOR 2
PLOT TEXT ,AT 300,300:"Game Over!!"
STOP
END IF
IF GETKEYSTATE(ORD("R"))<0 OR GETKEYSTATE(ORD("r"))<0 THEN ! リスタート(リトライ)
MAT M=MM
LET X,XS=XT
LET Y,YS=YT
CALL DISPLAY
END IF
LOOP WHILE S=-1
DO
LET SS=STICK
LOOP WHILE SS>0
LET P=MOVE(S) ! マス移動
LOOP WHILE P=0
CALL DISPLAY
IF CHECK=1 THEN EXIT DO !揃ったら
LOOP
SET TEXT HEIGHT 50
SET TEXT COLOR 2
PLOT TEXT ,AT 300,300:"Congratulations"
SUB DISPLAY ! 表示
FOR YY=1 TO 4
FOR XX=1 TO 4
LET C=M(XX,YY)
IF C<>SPC THEN
CALL BOXFULL(150*(XX-1),150*(YY-1),150*(XX-1)+150,150*(YY-1)+150,4)
PLOT TEXT ,AT 150*(XX-1)+75,150*(YY-1)+75:STR$(C)
ELSE
CALL BOXFULL(150*(XX-1),150*(YY-1),150*(XX-1)+150,150*(YY-1)+150,1)
END IF
NEXT XX
NEXT YY
FOR XX=1 TO 3
PLOT LINES:150*XX,0;150*XX,600
NEXT XX
FOR YY=1 TO 3
PLOT LINES:0,150*YY;600,150*YY
NEXT YY
END SUB
SUB SHUFFLE(N) ! シャッフル
LET S=0
LET X=MOD(SPC-1,4)+1
LET Y=INT((SPC-1)/4)+1
LET XS=X
LET YS=Y
FOR I=1 TO N
DO
DO
LET S=INT(RND*4+1)*2
LOOP WHILE I>1 AND S=ANSWER(I-1) ! 右に行って左や上に行って下等のムダな動きを省く
LOOP WHILE MOVE(S)=0 ! 壁を越えたらやり直し
LET ANSWER(I)=10-S
CALL DISPLAY
WAIT DELAY 1/10
NEXT I
END SUB
FUNCTION MOVE(S) ! マス移動
LET MV=0
SELECT CASE S
CASE 2
IF Y<4 THEN
LET YS=Y+1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 4
IF X>1 THEN
LET XS=X-1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 6
IF X<4 THEN
LET XS=X+1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 8
IF Y>1 THEN
LET YS=Y-1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE ELSE
END SELECT
LET MOVE=MV
END FUNCTION
FUNCTION CHECK ! 揃ったか?
FOR I=0 TO 14
LET XA=MOD(I,4)+1
LET YA=INT(I/4)+1
IF M(XA,YA)<>I+1 THEN
LET CHECK=0
EXIT FUNCTION
END IF
NEXT I
LET CHECK=1
END FUNCTION
FUNCTION STICK !'キー入力
LET STICK=-1
IF GETKEYSTATE(37)<0 THEN LET STICK=4
IF GETKEYSTATE(38)<0 THEN LET STICK=8
IF GETKEYSTATE(39)<0 THEN LET STICK=6
IF GETKEYSTATE(40)<0 THEN LET STICK=2
FOR I=49 TO 57
IF GETKEYSTATE(I)<0 THEN
LET STICK=I-48
EXIT FUNCTION
END IF
NEXT I
FOR I=97 TO 105
IF GETKEYSTATE(I)<0 THEN
LET STICK=I-96
EXIT FUNCTION
END IF
NEXT I
END FUNCTION
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
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
Re: スライドパズル - しばっち
2025/03/16 (Sun) 07:50:05
15ゲームを拡張した5*5の24ゲームです。
DECLARE FUNCTION STICK
DECLARE FUNCTION CHECK
RANDOMIZE
DIM M(5,5),ANSWER(100),MM(5,5)
CALL GINIT(600,600)
SET TEXT HEIGHT 40
SET TEXT JUSTIFY "CENTER","HALF"
SET TEXT COLOR 7
SET LINE COLOR 2
LET SPC=25
FOR J=1 TO 5
FOR I=1 TO 5
LET M(I,J)=5*(J-1)+I
NEXT I
NEXT J
CALL DISPLAY
INPUT PROMPT "シャッフル回数(5-100)=":N
CALL SHUFFLE(N)
MAT MM=M
FOR J=1 TO 5
FOR I=1 TO 5
IF M(I,J)=SPC THEN
LET XT=I
LET YT=J
END IF
NEXT I
NEXT J
DO
DO
DO
LET S=STICK
IF GETKEYSTATE(ORD("G"))<0 OR GETKEYSTATE(ORD("g"))<0 THEN ! ギブアップ
MAT M=MM
LET X,XS=XT
LET Y,YS=YT
CALL DISPLAY
WAIT DELAY .5
FOR I=N TO 1 STEP -1
LET SS=ANSWER(I)
LET P=MOVE(SS)
CALL DISPLAY
WAIT DELAY .5
NEXT I
SET TEXT HEIGHT 50
SET TEXT COLOR 2
PLOT TEXT ,AT 300,300:"Game Over!!"
STOP
END IF
IF GETKEYSTATE(ORD("R"))<0 OR GETKEYSTATE(ORD("r"))<0 THEN ! リスタート
MAT M=MM
LET X,XS=XT
LET Y,YS=YT
CALL DISPLAY
END IF
LOOP WHILE S=-1
DO
LET SS=STICK
LOOP WHILE SS>0
LET P=MOVE(S) ! マス移動
LOOP WHILE P=0
CALL DISPLAY
IF CHECK=1 THEN EXIT DO !揃ったら
LOOP
SET TEXT HEIGHT 50
SET TEXT COLOR 2
PLOT TEXT ,AT 300,300:"Congratulations"
SUB DISPLAY ! 表示
FOR YY=1 TO 5
FOR XX=1 TO 5
LET C=M(XX,YY)
IF C<>SPC THEN
CALL BOXFULL(120*(XX-1),120*(YY-1),120*(XX-1)+120,120*(YY-1)+120,4)
PLOT TEXT ,AT 120*(XX-1)+60,120*(YY-1)+60:STR$(C)
ELSE
CALL BOXFULL(120*(XX-1),120*(YY-1),120*(XX-1)+120,120*(YY-1)+120,1)
END IF
NEXT XX
NEXT YY
FOR XX=1 TO 4
PLOT LINES:120*XX,0;120*XX,600
NEXT XX
FOR YY=1 TO 4
PLOT LINES:0,120*YY;600,120*YY
NEXT YY
END SUB
SUB SHUFFLE(N) ! シャッフル
LET S=0
LET X=MOD(SPC-1,5)+1
LET Y=INT((SPC-1)/5)+1
LET XS=X
LET YS=Y
FOR I=1 TO N
DO
DO
LET S=INT(RND*4+1)*2
LOOP WHILE I>1 AND S=ANSWER(I-1)
LOOP WHILE MOVE(S)=0
LET ANSWER(I)=10-S
CALL DISPLAY
WAIT DELAY 1/10
NEXT I
END SUB
FUNCTION MOVE(S) ! マス移動
LET MV=0
SELECT CASE S
CASE 2
IF Y<5 THEN
LET YS=Y+1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 4
IF X>1 THEN
LET XS=X-1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 6
IF X<5 THEN
LET XS=X+1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 8
IF Y>1 THEN
LET YS=Y-1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE ELSE
END SELECT
LET MOVE=MV
END FUNCTION
FUNCTION CHECK ! 揃ったか?
FOR I=0 TO 24
LET XA=MOD(I,5)+1
LET YA=INT(I/5)+1
IF M(XA,YA)<>I+1 THEN
LET CHECK=0
EXIT FUNCTION
END IF
NEXT I
LET CHECK=1
END FUNCTION
FUNCTION STICK !'キー入力
LET STICK=-1
IF GETKEYSTATE(37)<0 THEN LET STICK=4
IF GETKEYSTATE(38)<0 THEN LET STICK=8
IF GETKEYSTATE(39)<0 THEN LET STICK=6
IF GETKEYSTATE(40)<0 THEN LET STICK=2
FOR I=49 TO 57
IF GETKEYSTATE(I)<0 THEN
LET STICK=I-48
EXIT FUNCTION
END IF
NEXT I
FOR I=97 TO 105
IF GETKEYSTATE(I)<0 THEN
LET STICK=I-96
EXIT FUNCTION
END IF
NEXT I
END FUNCTION
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
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
FUNCTION CHECK ! 揃ったか?
FOR I=0 TO 24
LET XA=MOD(I,5)+1
LET YA=INT(I/5)+1
IF M(XA,YA)<>I+1 THEN
LET CHECK=0
EXIT FUNCTION
END IF
NEXT I
LET CHECK=1
END FUNCTION
FUNCTION STICK !'キー入力
LET STICK=-1
IF GETKEYSTATE(37)<0 THEN LET STICK=4
IF GETKEYSTATE(38)<0 THEN LET STICK=8
IF GETKEYSTATE(39)<0 THEN LET STICK=6
IF GETKEYSTATE(40)<0 THEN LET STICK=2
FOR I=49 TO 57
IF GETKEYSTATE(I)<0 THEN
LET STICK=I-48
EXIT FUNCTION
END IF
NEXT I
FOR I=97 TO 105
IF GETKEYSTATE(I)<0 THEN
LET STICK=I-96
EXIT FUNCTION
END IF
NEXT I
END FUNCTION
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
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
Re: スライドパズル - しばっち
2025/03/16 (Sun) 07:51:32
6*6マスによる35パズルです。
DECLARE FUNCTION STICK
DECLARE FUNCTION CHECK
RANDOMIZE
DIM M(6,6),ANSWER(100),MM(6,6)
CALL GINIT(600,600)
SET TEXT HEIGHT 30
SET TEXT JUSTIFY "CENTER","HALF"
SET TEXT COLOR 7
SET LINE COLOR 2
LET SPC=36
FOR J=1 TO 6
FOR I=1 TO 6
LET M(I,J)=6*(J-1)+I
NEXT I
NEXT J
CALL DISPLAY
INPUT PROMPT "シャッフル回数(5-100)=":N
CALL SHUFFLE(N)
MAT MM=M
FOR J=1 TO 6
FOR I=1 TO 6
IF M(I,J)=SPC THEN
LET XT=I
LET YT=J
END IF
NEXT I
NEXT J
DO
DO
DO
LET S=STICK
IF GETKEYSTATE(ORD("G"))<0 OR GETKEYSTATE(ORD("g"))<0 THEN ! ギブアップ
MAT M=MM
LET X,XS=XT
LET Y,YS=YT
CALL DISPLAY
WAIT DELAY .5
FOR I=N TO 1 STEP -1
LET SS=ANSWER(I)
LET P=MOVE(SS)
CALL DISPLAY
WAIT DELAY .5
NEXT I
SET TEXT HEIGHT 50
SET TEXT COLOR 2
PLOT TEXT ,AT 300,300:"Game Over!!"
STOP
END IF
IF GETKEYSTATE(ORD("R"))<0 OR GETKEYSTATE(ORD("r"))<0 THEN ! リスタート
MAT M=MM
LET X,XS=XT
LET Y,YS=YT
CALL DISPLAY
END IF
LOOP WHILE S=-1
DO
LET SS=STICK
LOOP WHILE SS>0
LET P=MOVE(S) ! マス移動
LOOP WHILE P=0
CALL DISPLAY
IF CHECK=1 THEN EXIT DO !揃ったら
LOOP
SET TEXT HEIGHT 50
SET TEXT COLOR 2
PLOT TEXT ,AT 300,300:"Congratulations"
SUB DISPLAY ! 表示
FOR YY=1 TO 6
FOR XX=1 TO 6
LET C=M(XX,YY)
IF C<>SPC THEN
CALL BOXFULL(100*(XX-1),100*(YY-1),100*(XX-1)+100,100*(YY-1)+100,4)
PLOT TEXT ,AT 100*(XX-1)+50,100*(YY-1)+50:STR$(C)
ELSE
CALL BOXFULL(100*(XX-1),100*(YY-1),100*(XX-1)+100,100*(YY-1)+100,1)
END IF
NEXT XX
NEXT YY
FOR XX=1 TO 5
PLOT LINES:100*XX,0;100*XX,600
NEXT XX
FOR YY=1 TO 5
PLOT LINES:0,100*YY;600,100*YY
NEXT YY
END SUB
SUB SHUFFLE(N) ! シャッフル
LET S=0
LET X=MOD(SPC-1,6)+1
LET Y=INT((SPC-1)/6)+1
LET XS=X
LET YS=Y
FOR I=1 TO N
DO
DO
LET S=INT(RND*4+1)*2
LOOP WHILE I>1 AND S=ANSWER(I-1)
LOOP WHILE MOVE(S)=0
LET ANSWER(I)=10-S
CALL DISPLAY
WAIT DELAY 1/10
NEXT I
END SUB
FUNCTION MOVE(S) ! マス移動
LET MV=0
SELECT CASE S
CASE 2
IF Y<6 THEN
LET YS=Y+1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 4
IF X>1 THEN
LET XS=X-1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 6
IF X<6 THEN
LET XS=X+1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 8
IF Y>1 THEN
LET YS=Y-1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE ELSE
END SELECT
LET MOVE=MV
END FUNCTION
FUNCTION CHECK ! 揃ったか?
FOR I=0 TO 35
LET XA=MOD(I,6)+1
LET YA=INT(I/6)+1
IF M(XA,YA)<>I+1 THEN
LET CHECK=0
EXIT FUNCTION
END IF
NEXT I
LET CHECK=1
END FUNCTION
FUNCTION STICK !'キー入力
LET STICK=-1
IF GETKEYSTATE(37)<0 THEN LET STICK=4
IF GETKEYSTATE(38)<0 THEN LET STICK=8
IF GETKEYSTATE(39)<0 THEN LET STICK=6
IF GETKEYSTATE(40)<0 THEN LET STICK=2
FOR I=49 TO 57
IF GETKEYSTATE(I)<0 THEN
LET STICK=I-48
EXIT FUNCTION
END IF
NEXT I
FOR I=97 TO 105
IF GETKEYSTATE(I)<0 THEN
LET STICK=I-96
EXIT FUNCTION
END IF
NEXT I
END FUNCTION
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
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
Re: スライドパズル - しばっち
2025/03/16 (Sun) 07:52:41
3*3の8パズル
DECLARE FUNCTION STICK
DECLARE FUNCTION CHECK
RANDOMIZE
DIM M(3,3),ANSWER(50),MM(3,3)
CALL GINIT(600,600)
SET TEXT HEIGHT 50
SET TEXT JUSTIFY "CENTER","HALF"
SET TEXT COLOR 7
SET LINE COLOR 2
LET SPC=9
FOR J=1 TO 3
FOR I=1 TO 3
LET M(I,J)=3*(J-1)+I
NEXT I
NEXT J
CALL DISPLAY
INPUT PROMPT "シャッフル回数(5-50)=":N
CALL SHUFFLE(N)
MAT MM=M
FOR J=1 TO 3
FOR I=1 TO 3
IF M(I,J)=SPC THEN
LET XT=I
LET YT=J
END IF
NEXT I
NEXT J
DO
DO
DO
LET S=STICK
IF GETKEYSTATE(ORD("G"))<0 OR GETKEYSTATE(ORD("g"))<0 THEN ! ギブアップ
MAT M=MM
LET X,XS=XT
LET Y,YS=YT
CALL DISPLAY
WAIT DELAY .5
FOR I=N TO 1 STEP -1
LET SS=ANSWER(I)
LET P=MOVE(SS)
CALL DISPLAY
WAIT DELAY .5
NEXT I
SET TEXT HEIGHT 50
SET TEXT COLOR 2
PLOT TEXT ,AT 300,300:"Game Over!!"
STOP
END IF
IF GETKEYSTATE(ORD("R"))<0 OR GETKEYSTATE(ORD("r"))<0 THEN ! リスタート
MAT M=MM
LET X,XS=XT
LET Y,YS=YT
CALL DISPLAY
END IF
LOOP WHILE S=-1
DO
LET SS=STICK
LOOP WHILE SS>0
LET P=MOVE(S) ! マス移動
LOOP WHILE P=0
CALL DISPLAY
IF CHECK=1 THEN EXIT DO !揃ったら
LOOP
SET TEXT HEIGHT 50
SET TEXT COLOR 2
PLOT TEXT ,AT 300,300:"Congratulations"
SUB DISPLAY ! 表示
FOR YY=1 TO 3
FOR XX=1 TO 3
LET C=M(XX,YY)
IF C<>SPC THEN
CALL BOXFULL(200*(XX-1),200*(YY-1),200*(XX-1)+200,200*(YY-1)+200,4)
PLOT TEXT ,AT 200*(XX-1)+100,200*(YY-1)+100:STR$(C)
ELSE
CALL BOXFULL(200*(XX-1),200*(YY-1),200*(XX-1)+200,200*(YY-1)+200,1)
END IF
NEXT XX
NEXT YY
FOR XX=1 TO 2
PLOT LINES:200*XX,0;200*XX,600
NEXT XX
FOR YY=1 TO 2
PLOT LINES:0,200*YY;600,200*YY
NEXT YY
END SUB
SUB SHUFFLE(N) ! シャッフル
LET S=0
LET X=MOD(SPC-1,3)+1
LET Y=INT((SPC-1)/3)+1
LET XS=X
LET YS=Y
FOR I=1 TO N
DO
DO
LET S=INT(RND*4+1)*2
LOOP WHILE I>1 AND S=ANSWER(I-1)
LOOP WHILE MOVE(S)=0
LET ANSWER(I)=10-S
CALL DISPLAY
WAIT DELAY 1/10
NEXT I
END SUB
FUNCTION MOVE(S) ! マス移動
LET MV=0
SELECT CASE S
CASE 2
IF Y<3 THEN
LET YS=Y+1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 4
IF X>1 THEN
LET XS=X-1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 6
IF X<3 THEN
LET XS=X+1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 8
IF Y>1 THEN
LET YS=Y-1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE ELSE
END SELECT
LET MOVE=MV
END FUNCTION
FUNCTION CHECK ! 揃ったか?
FOR I=0 TO 8
LET XA=MOD(I,3)+1
LET YA=INT(I/3)+1
IF M(XA,YA)<>I+1 THEN
LET CHECK=0
EXIT FUNCTION
END IF
NEXT I
LET CHECK=1
END FUNCTION
FUNCTION STICK !'キー入力
LET STICK=-1
IF GETKEYSTATE(37)<0 THEN LET STICK=4
IF GETKEYSTATE(38)<0 THEN LET STICK=8
IF GETKEYSTATE(39)<0 THEN LET STICK=6
IF GETKEYSTATE(40)<0 THEN LET STICK=2
FOR I=49 TO 57
IF GETKEYSTATE(I)<0 THEN
LET STICK=I-48
EXIT FUNCTION
END IF
NEXT I
FOR I=97 TO 105
IF GETKEYSTATE(I)<0 THEN
LET STICK=I-96
EXIT FUNCTION
END IF
NEXT I
END FUNCTION
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
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
Re: スライドパズル - しばっち
2025/03/16 (Sun) 07:54:20
数字の代わりに画像ファイルを使ったn*mパズルです。
実際の15パズルではありえない斜め方向への移動もさせるので
テンキー又は数字キーで操作してください。
DECLARE FUNCTION STICK
DECLARE FUNCTION CHECK
RANDOMIZE
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
LET NX=INT(RND*6+3)
LET NY=INT(RND*6+3)
LET SPC=INT(RND*NX*NY+1)
! INPUT PROMPT "分割数 NX,NY=":NX,NY
! INPUT PROMPT "スペースの位置 (1-"&STR$(NX*NY)&")=":SPC
DIM M(NX,NY),ANSWER(100),MM(NX,NY),MT(NX,NY)
DIM TEMP(XSIZE/NX,YSIZE/NY),IMG(NX*NY,XSIZE/NX,YSIZE/NY)
SET TEXT JUSTIFY "CENTER","HALF"
FOR Y=0 TO YSIZE-1 STEP YSIZE/NY
FOR X=0 TO XSIZE-1 STEP XSIZE/NX
LET N=N+1
ASK PIXEL ARRAY(X,Y) TEMP
FOR YY=1 TO YSIZE/NY
FOR XX=1 TO XSIZE/NX
LET IMG(N,XX,YY)=TEMP(XX,YY)
NEXT XX
NEXT YY
NEXT X
NEXT Y
FOR J=1 TO NY
FOR I=1 TO NX
LET M(I,J)=NX*(J-1)+I
NEXT I
NEXT J
CALL DISPLAY
INPUT PROMPT "シャッフル回数(5-100)=":N
CALL SHUFFLE(N)
MAT MM=M
FOR J=1 TO NY
FOR I=1 TO NX
IF M(I,J)=SPC THEN
LET XT=I
LET YT=J
END IF
NEXT I
NEXT J
DO
DO
DO
LET S=STICK
IF GETKEYSTATE(ORD("G"))<0 THEN ! ギブアップ ("g"とテンキーの"7"が同一コード)
MAT M=MM
MAT MT=ZER
LET X,XS=XT
LET Y,YS=YT
CALL DISPLAY
WAIT DELAY .5
FOR I=N TO 1 STEP -1
LET SS=ANSWER(I)
LET P=MOVE(SS)
CALL DISPLAY
WAIT DELAY .5
NEXT I
SET TEXT HEIGHT MIN(XSIZE/12,YSIZE/12)
SET TEXT COLOR COLORINDEX(1,0,0)
PLOT TEXT ,AT XSIZE/2,YSIZE/2:"Game Over!!"
STOP
END IF
IF GETKEYSTATE(ORD("R"))<0 OR GETKEYSTATE(ORD("r"))<0 THEN ! リスタート
MAT M=MM
MAT MT=ZER
LET X,XS=XT
LET Y,YS=YT
CALL DISPLAY
END IF
IF GETKEYSTATE(ORD("S"))<0 OR GETKEYSTATE(ORD("s"))<0 THEN ! 補助
SET TEXT HEIGHT MIN(XSIZE/NX/3,YSIZE/NY/3)
SET TEXT COLOR COLORINDEX(0,1,0)
FOR YY=1 TO NY
FOR XX=1 TO NX
LET C=M(XX,YY)
IF C<>SPC THEN
PLOT TEXT ,AT XSIZE/NX*(XX-1)+XSIZE/NX/2,YSIZE/NY*(YY-1)+YSIZE/NY/2:STR$(C)
END IF
NEXT XX
NEXT YY
DO
LOOP WHILE GETKEYSTATE(ORD("S"))<0 OR GETKEYSTATE(ORD("s"))<0
MAT MT=ZER
CALL DISPLAY
END IF
LOOP WHILE S=-1
DO
LET SS=STICK
LOOP WHILE SS>0
LET P=MOVE(S) ! マス移動
LOOP WHILE P=0
CALL DISPLAY
IF CHECK=1 THEN EXIT DO !揃ったら
LOOP
SET TEXT HEIGHT MIN(XSIZE/12,YSIZE/12)
SET TEXT COLOR COLORINDEX(1,0,0)
PLOT TEXT ,AT XSIZE/2,YSIZE/2:"Congratulations"
SUB DISPLAY ! 表示
FOR YY=1 TO NY
FOR XX=1 TO NX
LET C=M(XX,YY)
IF MT(XX,YY)<>C THEN
IF C<>SPC THEN
FOR YC=1 TO YSIZE/NY
FOR XC=1 TO XSIZE/NX
LET TEMP(XC,YC)=IMG(M(XX,YY),XC,YC)
NEXT XC
NEXT YC
MAT PLOT CELLS ,IN XSIZE/NX*(XX-1),YSIZE/NY*(YY-1);XSIZE/NX*(XX-1)+XSIZE/NX,YSIZE/NY*(YY-1)+YSIZE/NY:TEMP
ELSE
CALL BOXFULL(XSIZE/NX*(XX-1),YSIZE/NY*(YY-1),XSIZE/NX*(XX-1)+XSIZE/NX,YSIZE/NY*(YY-1)+YSIZE/NY,0,0,255)
END IF
END IF
NEXT XX
NEXT YY
MAT MT=M
SET LINE COLOR COLORINDEX(0,1,0)
FOR XX=1 TO NX-1
PLOT LINES:XSIZE/NX*XX,0;XSIZE/NX*XX,YSIZE
NEXT XX
FOR YY=1 TO NY-1
PLOT LINES:0,YSIZE/NY*YY;XSIZE,YSIZE/NY*YY
NEXT YY
END SUB
SUB SHUFFLE(N) ! シャッフル
LET S=0
LET X=MOD(SPC-1,NX)+1
LET Y=INT((SPC-1)/NX)+1
LET XS=X
LET YS=Y
FOR I=1 TO N
DO
DO
LET S=INT(RND*9+1)
LOOP WHILE I>1 AND S=ANSWER(I-1)
LOOP WHILE MOVE(S)=0
LET ANSWER(I)=10-S
CALL DISPLAY
WAIT DELAY 1/10
NEXT I
END SUB
FUNCTION MOVE(S) ! マス移動
LET MV=0
SELECT CASE S
CASE 1
IF Y<NY AND X>1 THEN
LET YS=Y+1
LET XS=X-1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 2
IF Y<NY THEN
LET YS=Y+1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 3
IF Y<NY AND X<NX THEN
LET YS=Y+1
LET XS=X+1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 4
IF X>1 THEN
LET XS=X-1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 6
IF X<NX THEN
LET XS=X+1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 7
IF X>1 AND Y>1 THEN
LET XS=X-1
LET YS=Y-1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 8
IF Y>1 THEN
LET YS=Y-1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE 9
IF X<NX AND Y>1 THEN
LET XS=X+1
LET YS=Y-1
SWAP M(XS,YS),M(X,Y)
LET X=XS
LET Y=YS
LET MV=1
END IF
CASE ELSE
END SELECT
LET MOVE=MV
END FUNCTION
FUNCTION CHECK ! 揃ったか?
FOR I=0 TO NX*NY-1
LET XA=MOD(I,NX)+1
LET YA=INT(I/NX)+1
IF M(XA,YA)<>I+1 THEN
LET CHECK=0
EXIT FUNCTION
END IF
NEXT I
LET CHECK=1
END FUNCTION
FUNCTION STICK !'キー入力
LET STICK=-1
IF GETKEYSTATE(37)<0 THEN LET STICK=4
IF GETKEYSTATE(38)<0 THEN LET STICK=8
IF GETKEYSTATE(39)<0 THEN LET STICK=6
IF GETKEYSTATE(40)<0 THEN LET STICK=2
FOR I=49 TO 57
IF GETKEYSTATE(I)<0 THEN
LET STICK=I-48
EXIT FUNCTION
END IF
NEXT I
FOR I=97 TO 105
IF GETKEYSTATE(I)<0 THEN
LET STICK=I-96
EXIT FUNCTION
END IF
NEXT I
!RESTORE
!DATA Z,X,C,A,5,D,Q,W,E
!DATA J,K,L,U,I,O,7,8,9
!FOR I=1 TO 9
! READ A$
! IF GETKEYSTATE(ORD(A$))<0 OR GETKEYSTATE(ORD(LCASE$(A$)))<0 THEN LET STICK=I
!NEXT I
END FUNCTION
END
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
EXTERNAL SUB BOXFULL(X0,Y0,X1,Y1,R,G,B)
SET COLOR COLORINDEX(R/255,G/255,B/255)
PLOT AREA:X0,Y0;X1,Y0;X1,Y1;X0,Y1;X0,Y0
END SUB