LoginSignup
1
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 1 year has passed since last update.

@ohisama@github

win16 apiを叩きたい。 その6

Last updated at Posted at 2024-01-29

概要

win16 apiを叩きたい。
pc98エミュレーターに、ms-dos入れて、windows3.1入れて、turbo pascal入れて、窓を表示する。
テトリス見つけたので、やってみた。
私の環境では、break;が無い。（どうすんだい。）

サンプルコード


Program TetrisW;
Uses WinCrt, WinTypes, WinProcs;
Const
	kbNoKey = 0;
	kbEsc = $011B;
	kbUp = $4800;
	kbLeft = $4B00;
	kbKeypad5 = $4CF0;
	kbRight = $4D00;
	kbDn = $5000;
Type
	TetrisGame = Record
	Mode: (tmNone,tmStart,tmPlay,tmGameOver);
	Level: Byte;
	Score: LongInt; 
	Bar, SLevel: Word;
	Tbl: Array[0..20, 0..9] of Boolean;
	Form, _Move, X, Y, Sleep: Byte;
	Touch, Ok: Boolean;
	SleepDelay: Byte;
	FBar: Word;
	UpDate: Boolean;
End;
Function TetrisInit(Var Q: TetrisGame): Boolean; Forward;
Procedure TetrisStart(Var Q: TetrisGame); Forward;
Procedure TetrisRefresh(Var Q: TetrisGame); Forward;
Function TetrisPlay(Var Q: TetrisGame): Word; Forward;
Const
	HomeX = 15;
	HomeY = 2;
Procedure Delay(Millisecond: Integer);
Var
	EndTime: LongInt;
Begin
	EndTime := GetTickCount + (Millisecond);
	Repeat
	Until GetTickCount >= EndTime;
End;
Procedure WaitRetrace; 
Begin
	Delay(1000 div 60);
End;
Procedure MoveRight(Var Source; Var Dest; Len: LongInt);
Begin
	Move(Source, Dest, Len);
End;
Procedure TextAttr(Attr: Byte);
Begin
End;
Procedure BarSpcHor(X1, Y, X2: Byte);
Var
	I: Byte;
Begin
	GotoXY(X1, Y);
	For I := X1 to X2 do 
	Begin
		Write(' ');
	End;
End;
Function TetrisInit(Var Q: TetrisGame): Boolean;
Begin
	FillChar(Q, SizeOf(Q), 0);
	Q.Level := 1;
	Q.Mode := tmStart;
End;
Procedure TetrisStart(Var Q: TetrisGame);
Var
	I: Byte;
Begin
	FillChar(Q.Tbl, SizeOf(Q.Tbl), 0);
	FillChar(Q.Tbl[20], SizeOf(Q.Tbl[20]), Byte(True));
	Q.Score := 0;
	Q.Bar := 0;
	Q.SleepDelay := 25;
	Q.Level := Q.SLevel;
	For I := 0to(Q.SLevel) do 
		If Q.SleepDelay > 6 Then 
			Dec(Q.SleepDelay, 2);
	Q.FBar := Q.Level shl 4;
	Q.Mode := tmStart;
End;
Procedure TetrisRefresh(Var Q: TetrisGame);
Var
	I, J: Byte;
Begin
	ClrScr;
	GotoXY(3, 2);
	Write('Niveau:');
	GotoXY(4, 3);
	Write(Q.Level);
	GotoXY(3, 5);
	Write('Pointage:');
	GotoXY(4, 6);
	Write('0');
	GotoXY(3, 8);
	Write('Ligne:');
	GotoXY(4, 9);
	Write(Q.Bar);
	For J := 0 to 19 do 
	Begin
		GotoXY(HomeX - 1, HomeY + J);
		Write('|');
		GotoXY(HomeX + 10, HomeY + J);
		Write('|');
	End;
	GotoXY(HomeX - 1, HomeY + 20);
	Write('+----------+');
	If (Q.Mode) in[tmPlay, tmGameOver] Then 
	Begin
		For J := 0 to 19 do 
			For I := 0 to 9 do 
				If Q.Tbl[J, I] Then 
				Begin
					GotoXY(HomeX + I, HomeY + J);
					Write('*');
				End;
	End;
End;
Function TetrisPlay(Var Q: TetrisGame): Word;
Label _Exit;
Const
	BlkHeight: Array[0..6, 0..3] of Byte = ((4,1,4,1), { Barre }
						(2,2,2,2), { Boîte }
						(3,2,3,2), { V }
						(3,2,3,2), { L gauche }
						(3,2,3,2), { L droite }
						(3,2,3,2), { Serpent romain }
						(3,2,3,2));{ Serpent arabe }
	BlkLength: Array[0..6, 0..3] of Byte = ( {Largeur des objets:}
						(1,4,1,4), { Barre }
						(2,2,2,2), { Boîte }
						(2,3,2,3), { V }
						(2,3,2,3), { L gauche }
						(2,3,2,3), { L droite }
						(2,3,2,3), { Serpent romain }
						(2,3,2,3));{ Serpent arabe }
	BlkFormat: Array[0..6, 0..3, 0..3] of Record X, Y: Byte; End = (
						(((X:0;Y:0),(X:0;Y:1),(X:0;Y:2),(X:0;Y:3)),		{ þþþþ }
						((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:3;Y:0)),
						((X:0;Y:0),(X:0;Y:1),(X:0;Y:2),(X:0;Y:3)),
						((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:3;Y:0))),
						(((X:0;Y:0),(X:1;Y:0),(X:0;Y:1),(X:1;Y:1)),		{ þþ }
						((X:0;Y:0),(X:1;Y:0),(X:0;Y:1),(X:1;Y:1)),		{ þþ }
						((X:0;Y:0),(X:1;Y:0),(X:0;Y:1),(X:1;Y:1)),
						((X:0;Y:0),(X:1;Y:0),(X:0;Y:1),(X:1;Y:1))),
						(((X:1;Y:0),(X:0;Y:1),(X:1;Y:1),(X:1;Y:2)),		{ þþþ }
						((X:1;Y:0),(X:0;Y:1),(X:1;Y:1),(X:2;Y:1)),		{ þ }
						((X:0;Y:0),(X:0;Y:1),(X:1;Y:1),(X:0;Y:2)),
						((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:1;Y:1))),
						(((X:0;Y:0),(X:0;Y:1),(X:0;Y:2),(X:1;Y:2)),
						((X:0;Y:1),(X:1;Y:1),(X:2;Y:1),(X:2;Y:0)),		{ þ }
						((X:0;Y:0),(X:1;Y:0),(X:1;Y:1),(X:1;Y:2)),		{ þ }
						((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:0;Y:1))),	{ þþ }
						(((X:1;Y:0),(X:1;Y:1),(X:1;Y:2),(X:0;Y:2)),
						((X:0;Y:1),(X:1;Y:1),(X:2;Y:1),(X:0;Y:0)),		{ þ }
						((X:1;Y:0),(X:0;Y:0),(X:0;Y:1),(X:0;Y:2)),		{ þ }
						((X:0;Y:0),(X:1;Y:0),(X:2;Y:0),(X:2;Y:1))),	{ þþ }
						(((X:0;Y:0),(X:0;Y:1),(X:1;Y:1),(X:1;Y:2)),
						((X:1;Y:0),(X:2;Y:0),(X:0;Y:1),(X:1;Y:1)),
						((X:0;Y:0),(X:0;Y:1),(X:1;Y:1),(X:1;Y:2)),
						((X:1;Y:0),(X:2;Y:0),(X:0;Y:1),(X:1;Y:1))),
						(((X:1;Y:0),(X:0;Y:1),(X:1;Y:1),(X:0;Y:2)),
						((X:0;Y:0),(X:1;Y:0),(X:1;Y:1),(X:2;Y:1)),
						((X:1;Y:0),(X:0;Y:1),(X:1;Y:1),(X:0;Y:2)),		{þþ }
						((X:0;Y:0),(X:1;Y:0),(X:1;Y:1),(X:2;Y:1)))); { þþ }
Var
	I, J, H, XT: Byte;
	XJ, YJ, K: Word;
	Touch, Ok, NoAction: Boolean;
Procedure PutForm(Clr: Boolean);
Var
	Character: Char;
	I, Attr, X, Y: Byte;
Begin
	X := HomeX + Q.X;
	Y := HomeY + Q.Y;
	If (Clr) Then 
	Begin
		Character := ' ';
		Attr := 7;
	End
		Else
	Begin
		Character := '*';
		Attr := $71 + Q.Form;
	End;
	For I := 0 to 3 do 
	Begin
		GotoXY(HomeX + Q.X + BlkFormat[Q.Form, Q._Move, I].X, HomeY + Q.Y + BlkFormat[Q.Form, Q._Move, I].Y);
		TextAttr(Attr);
		Write(Character);
		TextAttr(7);
	End;
End;
Procedure Init;
Begin
	Q.Form := Random(6);
	If Q.Form = 5 Then 
		Inc(Q.Form, Random(2));
	Q.X := 5;
	Q.Y := 0;
	Q._Move := 0;
	Q.Sleep := 0;
	PutForm(False);
End;
Function UpDateData: Boolean;
Var
	H, I, J, JK: Byte;
	Bonus: Byte;
	LnChk: Boolean;
Begin
	UpDateData := True;
	Q.Sleep := 0;
	PutForm(False);
	Touch := False;
	Ok := False;
	PutForm(True);
	Inc(Q.Y);
	For I := 0to 3do 
	Begin
		Touch := Touch or Q.Tbl[Q.Y + BlkFormat[Q.Form, Q._Move, I].Y, Q.X + BlkFormat[Q.Form, Q._Move, I].X];
	End;
	If (Touch) Then 
		Dec(Q.Y);
	PutForm(False);
	If (Touch) Then 
	Begin
		While(Q.Sleep > Q.SleepDelay) do 
			Dec(Q.Sleep);
		Q.Sleep := 0;
		Ok := True;
		For I := 0 to 3 do
		 	Q.Tbl[Q.Y + BlkFormat[Q.Form, Q._Move, I].Y, Q.X + BlkFormat[Q.Form, Q._Move, I].X] := True;
		If Q.Level > 7 Then 
		Begin
			Inc(Q.Score, LongInt(5) * Q.Level);
			GotoXY(4, 6);
			Write(Q.Score);
		End;
		Bonus := 0;
		For J := 0 to 19 do 
		Begin
			Touch := True;
			For I := 0 to 9 do 
				Touch := Touch and Q.Tbl[J, I];
			If (Touch) Then 
				Inc(Bonus);
		End;
		If Bonus > 0 Then 
			Dec(Bonus);
		Touch := False;
		For JK := 0 to 7 do 
		Begin
			For J := 0 to 19 do 
			Begin
				LnChk := True;
				For I := 0 to 9 do 
					LnChk := LnChk and Q.Tbl[J, I];
				If (LnChk) Then 
				Begin
					If Not(Touch) Then 
					Begin
						Touch := True;
					End;
					If JK and 1 = 0 Then 
						TextAttr($FF)
					Else 
						TextAttr(7);
					BarSpcHor(HomeX, HomeY + J, HomeX + 9);
				End;
			End;
		End;
		For J := 0 to 19 do 
		Begin
			Touch := True;
			For I := 0 to 9 do 
				Touch := Touch and Q.Tbl[J, I];
			If (Touch) Then 
				Begin
			MoveRight(Q.Tbl[0, 0], Q.Tbl[1, 0], 10 * J);
			FillChar(Q.Tbl[0, 0], 10, 0);
			TetrisRefresh(Q);
			Inc(Q.Score, LongInt(5) + (Bonus * 4) * (Q.Level + 1) + 10 * Q.Level); 
			Inc(Q.Bar);
			GotoXY(4, 6);
			Write(Q.Score);
			GotoXY(4, 9);
			Write(Q.Bar);
			I := (Q.Bar + Q.FBar) shr 4;
			If (Q.Level <> I) Then 
			Begin
				Q.Level := I;
				GotoXY(4, 3);
				Write(Q.Level + 1);
				If Q.SleepDelay > 6 Then 
					Dec(Q.SleepDelay, 2);
			End;
		End;
		End;
		If Q.Y <= 1 Then 
		Begin
			UpDateData := False;
		Exit;
		End;
		Init;
	End;
End;
Function GameOver: Word;
Begin
	GotoXY(10, 7);
	Write('Partie Terminer');
	If (Q.UpDate) Then 
	Begin
		Q.UpDate := False;
	End;
	GameOver:= kbEsc;
End;
Begin
	TetrisRefresh(Q);
	K := 0;
	Repeat
	Case(Q.Mode) of
	tmStart:
	Begin
		TetrisStart(Q);
		TetrisRefresh(Q);
		Init;
		Q.Mode := tmPlay;
		Q.UpDate := True;
		End;
		tmPlay:
		Repeat
		Begin
			Repeat
			If (Q.Sleep > Q.SleepDelay) Then 
				If Not(UpDateData) Then 
				Begin
					Q.Mode := tmGameOver;
					Goto _Exit;
				End;
			WaitRetrace;
			Inc(Q.Sleep);
			Until KeyPressed;
			K := Byte(ReadKey);
			If K = 0 Then 
				K := K or (Byte(ReadKey) shl 8);
		End;
		If Chr(K) = '2' Then 
			K := kbDn;
		If Chr(K) = '4' Then 
			K := kbLeft;
		If Chr(K) = '6' Then 
			K := kbRight;
		NoAction := False;
		Case(K) of
		kbLeft:
			If Q.X > 0 Then 
			Begin
				Touch := False;
				For I := 0 to 3 do 
					Touch := Touch or Q.Tbl[Q.Y + BlkFormat[Q.Form, Q._Move, I].Y, Q.X + BlkFormat[Q.Form, Q._Move, I].X - 1];
				If Not(Touch)Then 
				Begin
					PutForm(True);
					Dec(Q.X);
					PutForm(False);
				End;
			End;
			kbRight:
				If Q.X + BlkLength[Q.Form, Q._Move] - 1 < 9 Then 
				Begin
					Touch := False;
					For I := 0 to 3 do 
						Touch := Touch or Q.Tbl[Q.Y + BlkFormat[Q.Form, Q._Move, I].Y, Q.X + BlkFormat[Q.Form, Q._Move,I].X + 1];
					If Not(Touch) Then 
					Begin
						PutForm(True);
						Inc(Q.X);
						PutForm(False);
					End;
				End;
			kbDn:
				While (True) do 
				Begin
					If Not(UpDateData)Then 
					Begin
						Q.Mode := tmGameOver;
						Goto _Exit;
					End;
				{	If (Ok) Then 
						Break;}
				End;
			Else NoAction := True;
		End;
		If (NoAction) Then 
		Begin
			If (K = kbKeyPad5) or (Char(K) in [' ', '5']) Then 
			Begin
				Touch := False;
				For I := 0 to 3 do 
				Begin
					XT := Q.X + BlkFormat[Q.Form, (Q._Move + 1) and 3, I].X; 
					Touch := Touch or (XT > 9);
					Touch := Touch or Q.Tbl[Q.Y + BlkFormat[Q.Form, (Q._Move + 1) and 3, I].Y, XT];
				End;
				If Not(Touch) Then 
				Begin
					PutForm(True);
					Q._Move := (Q._Move + 1) and 3;
					PutForm(False)
				End
				Else
			Begin
				Touch := False;
				For I := 0 to 3 do 
				Begin
					XT := Q.X;
					If XT > 0 Then 
						Dec(XT);
					Inc(XT, BlkFormat[Q.Form, (Q._Move + 1) and 3, I].X); 
					Touch := Touch or (XT > 9);
					Touch := Touch or Q.Tbl[Q.Y + BlkFormat[Q.Form, (Q._Move + 1) and 3, I].Y, XT];
				End;
				If Not(Touch) Then 
				Begin
					PutForm(True);
					Dec(Q.X); 
					Q._Move := (Q._Move + 1) and 3;
					PutForm(False);
				End;
			End;
		End
		Else
		{	Break;}
		End;
		Until(K = kbEsc) or (Chr(K) = 'Q');
		tmGameOver:K := GameOver;
	End;
_Exit:
	{If K <> 0 Then 
		Break;}
	Until False;
	TetrisPlay := K;
End;
Var
	Game: TetrisGame;
BEGIN
	TetrisInit(Game);
	TetrisPlay(Game);
END.

以上。

1
0
1

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
1
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?