paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-14 00:46:04 +02:00
Code Issues Packages Projects Releases Wiki Activity
8baf3100ca
fpc/install/demo/fpctris.pp
peter 469745aae7 * updates from marco
1999-06-01 19:24:32 +00:00

1019 lines
27 KiB
ObjectPascal
Raw Blame History

{
$Id$
This program is both available in XTDFPC as in the FPC demoes.
Copyright (C) 1999 by Marco van de Voort
FPCTris implements a simple Crt driven Tetrisish game to demonstrate the
Crt unit. (KeyPressed, ReadKey, GotoXY, Delay,TextColor,TextBackground)
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
PROGRAM FPCTris;
{ Trying to make a tetris from zero as a demo for FPC.
Coordinate system:
0 -> TheWidth-1 A figure is coded in a LONGINT like this:
---------
0 | * | ..*. 00100000 MSB
| | ** | ..*. 00100000
V | * | .**. 01100000
| | .... 00000000 LSB
|+ ++ ++|
|++ ++++++| so 00100000001000000110000000000000b
|+++++++++|
---------
TheHeight-1
}
Uses Crt,Dos,GameUnit;
{$dEFINE DoubleCache} {Try to write as less characters to console as possible}
CONST TheWidth = 11; {Watch out, also correct RowMask!}
TheHeight = 20;
PosXField = 10; { Upper X,Y coordinates of playfield}
PosYField = 3;
MaxFigures= 16; {Maximum # figures place is reserved for.}
NrLevels = 12; {Number of levels currenty defined}
FieldSpace= 177;
TYPE TetrisFieldType = ARRAY [0..25] OF LONGINT;
LevelInfoType = ARRAY [0..NrLevels-1] OF LONGINT;
FigureType = LONGINT; { actually array[0..3][0..3] of bit rounded up to a longint}
CHARSET = SET OF CHAR;
{The figures: }
CONST GraphFigures : ARRAY[0..4] OF String[80] =(
'.*... .*... .*... ..*.. .*... .*... **... **... ..**. .**.. ..*.. *....',
'.*... .*... .**.. .**.. .*... .**.. **... .*... ..*.. .**.. ..*.. **...',
'**... .**.. ..*.. .*... .*... .*... ..... .*... ..*.. .**.. **.** .**..',
'..... ..... ..... ..... .*... ..... ..... .***. ***.. .**.. ..*.. ..**.',
'..... ..... ..... ..... ..... ..... ..... ..... ..... .**.. ..*.. .....');
{Their relative occurance : }
FigureChance : ARRAY[0..MaxFigures-1] OF LONGINT =(
8, 8, 8, 8, 8, 8, 10, 1, 1, 1, 1, 1,0,0,0,0 );
{Scores per figure. Not necessarily used. Just for future use}
FigureScore : ARRAY[0..MaxFigures-1] OF LONGINT =(
2, 2, 4, 4, 1, 2, 2, 10, 10, 10, 20, 10,0,0,0,0 );
{Diverse AND/OR masks to manipulate graphics}
{general table to mask out a bit 31=msb 0=lsb}
AndTable : ARRAY[0..31] OF LONGINT=($80000000,$40000000,$20000000,$10000000,
$8000000,$4000000,$2000000,$1000000,$800000,$400000,$200000,$100000,
$80000,$40000,$20000,$10000,$8000,$4000,$2000,$1000,$800,$400,$200,$100,
$80,$40,$20,$10,8,4,2,1);
{Mask to isolate a row of a (FigureType)}
MagicMasks : ARRAY[0..4] OF LONGINT = ($F8000000,$07C00000,$003E0000,$0001F000,$00000F80);
{Mask to check if a line is full; a bit for every column aligned to left.}
RowMask = $FFE00000;
{Masks to calculate if the left or rightside is partially empty, write them
in binary, and put 5 bits on a row. }
LeftMask : ARRAY[0..4] OF LONGINT = ($84210800,$C6318C00,$E739CE00,$F7BDEF00,$FFFFFFE0);
RightMask: ARRAY[0..4] OF LONGINT = ($08421080,$18C63180,$39CE7380,$7BDEF780,$FFFFFF80);
{Allowed characters entering highscores}
{This constant/parameter is used to detect a certain bug. The bug was fixed, but
I use the constant to remind where the bug was, and what is related to eachother.}
Tune=-1;
{First array is a table to find the level for a given number of dissappeared lines
the second and third are the delaytime and iterationlevel per level. }
LevelBorders : LevelInfoType = ( 10, 20, 30, 45, 60, 80,100,130,160,200,240,280);
DelayLevel : LevelInfoType = (100, 90, 80, 70, 60, 60, 50, 40, 40, 20, 20,10);
IterationLevel: LevelInfoType = ( 5, 5, 5, 5, 5, 4, 4, 4, 3, 3, 2, 2);
{Some frequently used chars in high-ascii and low-ascii. UseColor selects between
them}
ColorString = #196#179#192#217#219;
DumbTermStr = '-|..*';
{ A multiplication factor to reward killing more then one line with one figure}
ProgressiveFactor : ARRAY[1..5] OF LONGINT = (10,12,16,22,30);
VAR
TopX,TopY : LONGINT; {Coordinates figure relative
to left top of playfield}
FigureNr : LONGINT; {Nr in Figure cache, second
index in Figures}
{$IFDEF DoubleCache}
BackField, {Copy of the screen for faster matching}
{$ENDIF}
MainField : TetrisFieldType; {The screen grid}
ColorField : ARRAY[0..TheHeight-1,0..TheWidth-1] OF LONGINT; {The color info}
DelayTime : LONGINT; {Delay time, can be used for
implementing levels}
IterationPerDelay : LONGINT; {Iterations of mainloop (incl delay)
before the piece falls down a row}
TotalChance : LONGINT; {Sum of FigureChange array}
Lines : LONGINT; {Completed lines}
NrFigures : LONGINT; {# Figures currently used}
RightSizeArray, {Nunber of empty columns to the left }
LeftSizeArray, {or right of the figure/piece}
Figures : ARRAY[0..MaxFigures-1,0..3] OF LONGINT; {All bitmap info of figures}
NrFiguresLoaded : LONGINT; {Total figures available in GraphFigures}
CurrentCol : LONGINT; {Color of current falling piece}
UseColor : BOOLEAN; {Color/Mono mode}
Level : LONGINT; {The current level number}
Style : String; {Contains all chars to create the field}
nonupdatemode : BOOLEAN; {Helpmode/highscore screen or game mode}
HelpMode : BOOLEAN;
NextFigure : LONGINT; {Next figure to fall}
Score : LONGINT; {The score}
FUNCTION RRotate(Figure:FigureType;ColumnsToDo:LONGINT):FigureType;
{Rotate a figure to the right (=clockwise).
This new (v0.06) routine performs a ColumnsTodo x ColumnsToDo rotation,
instead of always a 4x4 (v0.04) or 5x5 (v0.05) rotation.
This avoids weird, jumpy behaviour when rotating small pieces.}
VAR I,J, NewFig:LONGINT;
BEGIN
NewFig:=0;
FOR I:=0 TO ColumnsToDo-1 DO
FOR J:=0 TO ColumnsToDo-1 DO
IF Figure AND AndTable[I*5+J]<>0 THEN
NewFig:=NewFig OR AndTable[(ColumnsToDo-1-I)+5*(J)]; {}
RRotate:=NewFig;
END;
{ LeftSize and RightSize count the number of empty lines to the left and
right of the character. On the below character LeftSize will return 2 and
RightSize will return 1.
..*.
..*.
..*.
..*.
}
FUNCTION RightSize(Fig:FigureType):LONGINT;
VAR I : LONGINT;
BEGIN
I:=0;
WHILE ((Fig AND RightMask[I])=0) AND (I<5) DO
INC(I);
IF I>4 THEN
HALT;
Rightsize:=I;
END;
FUNCTION Leftsize(Fig:FigureType):LONGINT;
VAR I : LONGINT;
BEGIN
I:=0;
WHILE ((Fig AND LeftMask[I])=0) AND (I<5) DO
INC(I);
IF I>4 THEN
HALT;
Leftsize:=I;
END;
FUNCTION FigSym(Figure:LONGINT;RightSizeFig:LONGINT):LONGINT;
{Try to find the "symmetry" of a figure, the smallest square (1x1,2x2,3x3 etc)
in which the figure fits. This requires all figures designed to be aligned to
topleft.}
VAR ColumnsToDo : LONGINT;
BEGIN
{Determine which bottom rows aren't used}
ColumnsToDo:=5;
WHILE ((Figure AND MagicMasks[ColumnsToDo-1])=0) AND (ColumnsToDo>1) DO
DEC(ColumnsToDo);
{Compare with columns used, already calculated, and take the biggest}
IF ColumnsToDo<(5-RightSizeFig) THEN
ColumnsToDo:=5-RightSizeFig;
FigSym:=ColumnsToDo;
END;
PROCEDURE CreateFiguresArray;
{Reads figures from ASCII representation into binary form, and creates the
rotated representations, and the number of empty columns to the right and
left per figure. }
VAR I,J,K,L,Symmetry : LONGINT;
BEGIN
NrFigures:=0; K:=1;
WHILE K<Length(GraphFigures[0]) DO
BEGIN
IF GraphFigures[0][K]=' ' THEN
INC(K);
L:=0;
FOR I:=0 TO 4 DO {Rows}
FOR J:=0 TO 4 DO {Columns}
IF GraphFigures[I][K+J]='*' THEN
L:=L OR AndTable[I*5+J];
Figures[NrFigures][0]:=L;
INC(NrFigures);
INC(K,5);
END;
NrFiguresLoaded:=NrFigures;
FOR I:= 0 TO NrFigures-1 DO
BEGIN
RightSizeArray[I][0]:=RightSize(Figures[I][0]);
LeftSizeArray[I][0]:=LeftSize(Figures[I][0]);
Symmetry:=FigSym(Figures[I][0],RightSizeArray[I][0]);
FOR J:=0 TO 2 DO {Create the other 3 by rotating}
BEGIN
Figures[I][J+1]:=RRotate(Figures[I][J],Symmetry);
RightSizeArray[I][J+1]:=RightSize(Figures[I][J+1]);
LeftSizeArray[I][J+1]:=LeftSize(Figures[I][J+1]);
END;
END;
{Clear main grid}
FillChar(MainField,SIZEOF(TetrisFieldType),0);
END;
PROCEDURE CalculateTotalChance;
{Called after a change in the the number of figures, normally 7 (standard)
or NrFiguresLoaded (10 right now) to recalculate the total of the chance table}
VAR Temp:LONGINT;
BEGIN
TotalChance:=0;
FOR Temp:=0 TO NrFigures-1 DO INC(TotalChance,FigureChance[Temp]);
END;
FUNCTION MatchPosition(Fig:FigureType;X,Y:LONGINT): BOOLEAN;
{Most important routine. Tries to position the figure on the position
IF it returns FALSE then the piece overlaps something on the background,
or the lower limit of the playfield
}
VAR I,J,K : LONGINT;
Match: BOOLEAN;
BEGIN
Match:=TRUE;
FOR I:=0 TO 4 DO
BEGIN
K:=Fig;
K:=K AND MagicMasks[I];
IF K<>0 THEN
BEGIN
J:=5*(I)-X+Tune;
IF J>0 THEN
K:=K SHL J
ELSE
IF J<0 THEN
K:=K SHR -J;
IF (MainField[Y+I] AND K)<>0 THEN
Match:=FALSE;
END;
END;
I:=4;
IF (Fig AND MagicMasks[4])=0 THEN
DEC(I);
IF (Fig AND MagicMasks[3])=0 THEN
DEC(I);
IF (Fig AND MagicMasks[2])=0 THEN
DEC(I);
IF (Y+I)>=TheHeight THEN
Match:=FALSE;
MatchPosition:=Match;
END;
PROCEDURE FixFigureInField(Fig:FigureType;X,Y:LONGINT;Clear:BOOLEAN);
{Blends the figure into the background, or erases the figure from the
background}
VAR I,J,K : LONGINT;
BEGIN
FOR I:=0 TO 4 DO
BEGIN
K:=Fig;
K:=K AND MagicMasks[I];
IF K<>0 THEN
BEGIN
J:=5*I-X+Tune;
IF J>0 THEN
K:=K SHL J
ELSE
IF J<0 THEN
K:=K SHR (-J);
IF Clear THEN
BEGIN
K:=K XOR -1;
MainField[Y+I]:= MainField[Y+I] AND K;
END
ELSE
MainField[Y+I]:= MainField[Y+I] OR K;
END;
END;
END;
PROCEDURE FixColField(ThisFig:LONGINT);
{Puts color info of a figure into the colorgrid, simplified
FixFigureInField on byte instead of bit manipulation basis.}
VAR I,J,K : LONGINT;
BEGIN
FOR I:=0 TO 4 DO
BEGIN
K:=Figures[ThisFig][FigureNr];
IF (I+TopY)<=TheHeight THEN
FOR J:=0 TO 4 DO
BEGIN
IF (K AND AndTable[J+5*I])<>0 THEN
ColorField[TopY+I,TopX-Tune+J]:=CurrentCol;
END;
END;
END;
PROCEDURE DisplMainFieldTextMono;
{Displays the grid with a simple buffering algoritm, depending on
conditional DoubleBuffer}
VAR Row,Column,Difference,StartRow,EndRow : LONGINT;
S : String;
BEGIN
FOR Row:=0 TO TheHeight-1 DO
BEGIN
{$IFDEF DoubleCache}
IF BackField[Row]<>MainField[Row] THEN
BEGIN
{$ENDIF}
FillChar(S[1],2*TheWidth,#32);
StartRow:=0;
EndRow:=TheWidth-1;
{$IFDEF DoubleCache}
Difference:=MainField[Row] XOR BackField[Row]; {Calc differences in line}
{Search for first and last bit changed}
WHILE ((Difference AND AndTable[StartRow])=0) AND (StartRow<(TheWidth-1)) DO
INC(StartRow);
WHILE ((Difference AND AndTable[EndRow])=0) AND (EndRow>0) DO
DEC(EndRow);
{$ENDIF}
{Prepare a string}
GotoXY(PosXField+2*StartRow,PosYField+Row);
S[0]:=CHR(2*(EndRow-StartRow+1));
FOR Column:=0 TO EndRow-StartRow DO
BEGIN
IF (MainField[Row] AND AndTable[StartRow+Column])<>0 THEN
BEGIN
S[Column*2+1]:=Style[5];
S[Column*2+2]:=Style[5];
END;
END;
{Write the string}
Write(S);
{$IFDEF DoubleCache}
END;
{$ENDIF}
END;
{$IFDEF DoubleCache}
BackField:=MainField; {Keep a copy of the screen for faster updates
of terminals, for next DisplMainFieldText.}
{$ENDIF}
END;
PROCEDURE DisplMainFieldTextColor;
{Same as above, but also use ColorField to output colors,
the buffering is the same, but the colors make it less efficient.}
VAR Row,Column,Difference,StartRow,EndRow,
L : LONGINT;
S : String;
LastCol : LONGINT;
BEGIN
LastCol:=255;
FOR Row:=0 TO TheHeight-1 DO
BEGIN
{$IFDEF DoubleCache}
IF BackField[Row]<>MainField[Row] THEN
BEGIN
{$ENDIF}
FillChar(S[1],2*TheWidth,#32);
StartRow:=0;
EndRow:=TheWidth-1;
{$IFDEF DoubleCache}
Difference:=MainField[Row] XOR BackField[Row]; {Calc differences in line}
WHILE ((Difference AND AndTable[StartRow])=0) AND (StartRow<(TheWidth-1)) DO
INC(StartRow);
WHILE ((Difference AND AndTable[EndRow])=0) AND (EndRow>0) DO
DEC(EndRow);
{$ENDIF}
GotoXY(PosXField+2*StartRow,PosYField+Row);
FOR Column:=0 TO EndRow-StartRow DO
BEGIN
IF (MainField[Row] AND AndTable[StartRow+Column])<>0 THEN
BEGIN
L:=ColorField[Row,StartRow+Column];
IF L=0 THEN
L:=CurrentCol;
IF L<>LastCol THEN
BEGIN
TextColor(L);
Write(Style[5],Style[5]);
END;
END
ELSE
Write(' ');
END;
{$IFDEF DoubleCache}
END;
{$ENDIF}
END;
{$IFDEF DoubleCache}
BackField:=MainField; {Keep a copy of the screen for faster updates
of terminals, for next DisplMainFieldText.}
{$ENDIF}
END;
PROCEDURE DisplMainFieldText;
{Main redraw routine; Check in what mode we are and call appropriate routine}
BEGIN
IF UseColor THEN
DisplMainFieldTextColor
ELSE
DisplMainFieldTextMono;
END;
PROCEDURE RedrawScreen;
{Frustrates the caching system so that the entire screen is redrawn}
VAR I : LONGINT;
BEGIN
FOR I:=0 TO TheHeight-1 DO
BackField[I]:=MainField[I] XOR -1; {backup copy is opposite of MainField}
END;
FUNCTION GetNextFigure:LONGINT;
VAR IndTotal,Temp,TheFigure : LONGINT;
BEGIN
Temp:=RANDOM(TotalChance);
IndTotal:=0;
TheFigure:=0;
WHILE Temp>=IndTotal DO
BEGIN
INC(IndTotal,FigureChance[TheFigure]);
INC(TheFigure);
END;
dec(thefigure);
GetNextFigure:=TheFigure;
END;
PROCEDURE ShowNextFigure(ThisFig:LONGINT);
VAR I,J,K : LONGINT;
S : String[8];
BEGIN
IF UseColor THEN
TextColor(White);
IF NOT nonupdatemode THEN
BEGIN
FOR I:=0 TO 4 DO
BEGIN
FillChar(S,9,' ');
S[0]:=#8;
K:=Figures[ThisFig][FigureNr];
IF (I+TopY)<=TheHeight THEN
FOR J:=0 TO 4 DO
BEGIN
IF (K AND AndTable[J+5*I])<>0 THEN
BEGIN
S[J*2+1]:=Style[5];
S[J*2+2]:=Style[5];
END
END;
GotoXY(50,11+I); Write(S);
END;
END;
END;
PROCEDURE FixScores;
BEGIN
IF UseColor THEN
SetDefaultColor;
GotoXY(40,18);
Write('Score :',Score);
END;
PROCEDURE ShowLines;
BEGIN
IF NOT nonupdatemode THEN
BEGIN
IF UseColor THEN
TextColor(Yellow);
GotoXY(40,16); Write('Lines: ',Lines:4,' Level: ',Level);
END;
END;
FUNCTION InitAFigure(VAR TheFigure:LONGINT) : BOOLEAN;
{A new figure appears in the top of the screen. If return value=FALSE then
the piece couldn't be created (when it is overlapping with the background.
That's the game-over condition)}
VAR Temp : LONGINT;
BEGIN
TopX:=(TheWidth-4) DIV 2; { Middle of Screen}
TopY:=0;
FigureNr:=1;
IF TheFigure<>-1 THEN
INC(Score,FigureScore[TheFigure]);
IF NOT NonUpdateMode THEN
FixScores;
Temp:=GetNextFigure; {Determine next char (after the one this
initafigure created has got down)}
TheFigure:=NextFigure; {Previous NextFigure becomes active now.}
NextFigure:=Temp;
InitAFigure:=MatchPosition(Figures[TheFigure][0],TopX,TopY);
ShowNextFigure(NextFigure);
CurrentCol:=RANDOM(14)+1;
END;
{
PROCEDURE ShowHighScore;
VAR I : LONGINT;
BEGIN
GotoXY(50,9); Write('The Highscores');
FOR I:=0 TO 9 DO
BEGIN
GotoXY(40,20-I);
Write(HighScore[I].Name,' ':(13-Length(HighScore[I].Name)),' ',HighScore[I].Score:5);
END;
END;
}
PROCEDURE ShowGameMode;
BEGIN
IF NOT nonupdatemode THEN
BEGIN
GotoXY(61,13);
IF NrFigures<>7 THEN
write('Extended')
ELSE
write('Standard');
END;
END;
PROCEDURE CreateFrame;
{Used once to print the "background" of the screen (not the background grid,
but the text, and the cadre around the playfield}
VAR I : LONGINT;
BEGIN
SetDefaultColor;
GotoXY(40,4);
Write('FPCTris v0.07, (C) by the FPC team.');
GotoXY(40,6);
Write('A demo of the FPC Crt unit, and');
GotoXY(40,7);
Write(' its portability');
FOR I:=9 TO 24 DO
BEGIN
GotoXY(40,I);
Write(' ':38);
END;
ShowGameMode;
IF nonupdatemode THEN
BEGIN
IF HelpMode THEN
BEGIN
GotoXY(40,9);
Write('Arrow left/right to move, down to drop');
GotoXY(40,10);
Write('arrow-up to rotate the piece');
GotoXY(40,11);
Write('"P" to pause');
GotoXY(40,12);
Write('"E" Mode (standard or extended)');
GotoXY(40,13);
Write('"C" switches between color/mono mode');
GotoXY(40,14);
Write('Escape to quit');
GotoXY(40,15);
Write('"S" to show the highscores');
{$IFDEF Linux}
GotoXY(40,16);
Write('"i" try to switch to IBM character set');
{$ENDIF}
END
ELSE
ShowHighScore;
END
ELSE
BEGIN
GotoXY(40,9);
Write('"h" to display the helpscreen');
END;
FOR I :=0 TO TheHeight-1 DO
BEGIN
GotoXY(PosXField-1 ,PosYField+I); Write(Style[2]);
GotoXY(PosXField+2*TheWidth ,PosYField+I); Write(Style[2]);
END;
GotoXY(PosXField-1,PosYField+TheHeight);
Write(Style[3]);
FOR I:=0 TO (2*TheWidth)-1 DO
Write(Style[1]);
Write(Style[4]);
END;
PROCEDURE FixLevel(Lines:LONGINT);
BEGIN
Level:=0;
WHILE (Lines>LevelBorders[Level]) AND (Level<HIGH(LevelBorders)) DO
INC(Level);
DelayTime:=DelayLevel[Level];
IterationPerDelay:=IterationLevel[Level];
END;
PROCEDURE FixMainFieldLines;
{Deletes full horizontal lines from the playfield will also get some
score-keeping code in the future.}
VAR I,LocalLines : LONGINT;
BEGIN
I:=TheHeight-1;
LocalLines:=0;
WHILE I>=0 DO
BEGIN
IF (MainField[I] XOR RowMask)=0 THEN
BEGIN
Move(MainField[0],MainField[1],I*4);
Move(ColorField[0,0],ColorField[1,0],4*I*TheWidth);
MainField[0]:=0;
FillChar(ColorField[0,0],0,TheWidth);
INC(LocalLines);
END
ELSE
DEC(I);
END;
INC(Lines,LocalLines);
INC(Score,ProgressiveFactor[LocalLines]*LocalLines);
I:=Level;
FixLevel(Lines);
IF LocalLines<>0 THEN
ShowLines;
{$IFDEF DoubleCache}
IF UseColor THEN
RedrawScreen;
{$ENDIF}
END;
PROCEDURE DoFPCTris;
{The main routine. Initialisation, keyboard loop}
VAR EndGame : BOOLEAN;
FixHickup : LONGINT;
Counter : LONGINT;
Temp,Key : LONGINT;
TheFigure : LONGINT; {Current first index in Figures}
PROCEDURE TurnFigure;
{Erases a figure from the grid, turns it if possible, and puts it back on
again}
BEGIN
FixFigureInField(Figures[TheFigure][FigureNr],TopX,TopY,TRUE);
IF MatchPosition(Figures[TheFigure][Temp],TopX,TopY) THEN
FigureNr:=Temp;
FixFigureInField(Figures[TheFigure][FigureNr],TopX,TopY,FALSE);
END;
PROCEDURE FixHighScores;
VAR I,J : LONGINT;
S : String;
BEGIN
FOR J:=9 TO 22 DO
BEGIN
GotoXY(40,J);
Write(' ':38);
END;
IF UseColor THEN
TextColor(White);
GotoXY(40,23);
Writeln('Game Over, score = ',Score);
I:=SlipInScore(Score);
IF I<>0 THEN
BEGIN
NonUpdateMode:=TRUE;
HelpMode:=FALSE;
ShowHighScore;
InputStr(S,40,21-I,10,FALSE,AlfaBeta);
HighScore[I-1].Name:=S;
END;
ShowHighScore;
END;
{$IFNDEF FPC}
PROCEDURE SetCursorSize(CurDat:WORD);ASSEMBLER;
ASM
mov ah,1
mov cx,CurDat
int $10
END;
{The two procedures below are standard (and os-independant) in FPC's Crt}
PROCEDURE CursorOn;
BEGIN
SetCursorSize($090A);
END;
PROCEDURE CursorOff;
BEGIN
SetCursorSize($FFFF);
END;
{$ENDIF}
BEGIN
{Here should be some terminal-detection for Linux}
nonupdatemode:=FALSE;
HelpMode :=TRUE;
{$IFDEF Linux}
UseColor:=FALSE;
{$ELSE}
UseColor:=TRUE;
{$ENDIF}
ClrScr;
CursorOff;
RANDOMIZE;
HighX:=40;
HighY:=9;
CreateFiguresArray; { Load and precalculate a lot of stuff}
IF UseColor THEN
Style:= ColorString
ELSE
Style:=DumbTermStr;
NrFigures:=7; {Default standard tetris mode, only use
the first 7 standard figures}
CalculateTotalChance; {Calculated the total of all weightfactors}
EndGame:=FALSE; {When TRUE, end of game has been detected}
FixHickup:=0; {Used to avoid unnecessary pauses with the "down key"}
CreateFrame; {Draws all background garbadge}
TheFigure:=-1;
NextFigure:=GetNextFigure; {Two figures have to be inited. The first
figure starts dropping, and that is this
one}
InitAFigure(TheFigure); {The second figure is the figure to be
displayed as NEXT. That's this char :-)}
DisplMainFieldText; {Display/update the grid}
Counter:=0; {counts up to IterationPerDelay}
DelayTime:=100; {Time of delay}
IterationPerDelay:=5; {= # Delays per shift down of figure}
Lines:=0; {Lines that have disappeared}
Score:=0;
ShowLines;
REPEAT
IF KeyPressed THEN {The function name says it all}
BEGIN
Key:=ORD(READKEY);
IF Key=0 THEN {Function key?}
Key:=ORD(READKEY) SHL 8;
CASE Key OF {Check for all keys}
ArrU : BEGIN
Temp:=(FigureNr+3) AND 3;
IF ((TopX+LeftSizeArray[TheFigure][FigureNr])<0) THEN
BEGIN
IF (LeftSizeArray[TheFigure][FigureNr]<=LeftSizeArray[TheFigure][Temp]) THEN
TurnFigure;
END
ELSE
IF (TopX+7-RightSizeArray[TheFigure][FigureNr])>TheWidth THEN
BEGIN
IF (RightSizeArray[TheFigure][FigureNr]<=RightSizeArray[TheFigure][Temp]) THEN
TurnFigure;
END
ELSE
TurnFigure;
END;
ArrL : BEGIN
IF (TopX+LeftSizeArray[TheFigure][FigureNr])>=0 THEN
BEGIN
Temp:=TopX+1-LeftSizeArray[TheFigure][FigureNr];
FixFigureInField(Figures[TheFigure][FigureNr],TopX,TopY,TRUE);
IF MatchPosition(Figures[TheFigure][FigureNr],TopX-1,TopY) THEN
DEC(TopX);
FixFigureInField(Figures[TheFigure][FigureNr],TopX,TopY,FALSE);
END;
END;
ArrR : BEGIN
IF (TopX+7-RightSizeArray[TheFigure][FigureNr])<=TheWidth THEN
BEGIN
FixFigureInField(Figures[TheFigure][FigureNr],TopX,TopY,TRUE);
IF MatchPosition(Figures[TheFigure][FigureNr],TopX+1,TopY) THEN
INC(TopX);
FixFigureInField(Figures[TheFigure][FigureNr],TopX,TopY,FALSE);
END;
END;
ArrD : BEGIN
IF FixHickup=0 THEN
BEGIN
FixFigureInField(Figures[TheFigure][FigureNr],TopX,TopY,TRUE);
Temp:=TopY;
WHILE MatchPosition(Figures[TheFigure][FigureNr],TopX,TopY+1) DO
INC(TopY);
Temp:=TopY-Temp;
INC(Score,Temp DIV 2);
FixFigureInField(Figures[TheFigure][FigureNr],TopX,TopY,FALSE);
FixHickUp:=4;
END;
END;
ORD('q'),
ESC : BEGIN
SetDefaultColor;
GotoXY(1,25);
EndGame:=TRUE;
END;
ORD('C'),
ORD('c') : BEGIN
UseColor:=NOT UseColor;
IF UseColor THEN
Style:= ColorString
ELSE
BEGIN
SetDefaultColor;
Style:=DumbTermStr;
END;
CreateFrame;
RedrawScreen;
DisplMainFieldText;
END;
ORD('H'),
ORD('h') : BEGIN
nonupdatemode:=NOT nonupdatemode;
CreateFrame;
ShowLines;
ShowNextFigure(NextFigure);
END;
ORD('S'),
ORD('s') : BEGIN
IF NOT nonupdatemode THEN
BEGIN
NonUpdateMode:=TRUE;
helpmode:=NOT helpmode;
END
ELSE
HelpMode:=NOT helpmode;
CreateFrame;
ShowLines;
ShowNextFigure(NextFigure);
END;
ORD('E'),
ORD('e'): BEGIN {Extra figures on/off}
IF NrFigures<>NrFiguresLoaded THEN
NrFigures:=NrFiguresLoaded {Extra figures}
ELSE
NrFigures:=7; {Standard Tetris figures}
CalculateTotalChance; {Recalculate weight-totals}
IF UseColor THEN
SetDefaultColor;
ShowGameMode;
END;
ORD('p') : BEGIN {"p" : Pause}
Key:=ORD(ReadKey);
IF Key=0 THEN
Key:=ORD(ReadKey);
END;
{$IFDEF Linux}
ORD('i') : write(#27+'(K');
{$ENDIF}
END; {END OF Key CASE}
END { OF If KeyPressed}
ELSE
BEGIN
{$IFDEF Linux}
GotoXY(50,10); {Get cursor out of the way, CursorOn/Off
doesn't work on telnet-terminals}
{$ENDIF}
Delay(DelayTime);
END;
INC(Counter);
IF (Counter=IterationPerDelay) OR (FixHickup=1) THEN
BEGIN
IF FixHickup=1 THEN
Counter:=IterationPerDelay-1
ELSE
Counter:=0;
FixFigureInField(Figures[TheFigure][FigureNr],TopX,TopY,TRUE);
FixHickup:=0;
IF MatchPosition(Figures[TheFigure][FigureNr],TopX,TopY+1) THEN
BEGIN
INC(TopY);
FixFigureInField(Figures[TheFigure][FigureNr],TopX,TopY,FALSE);
END
ELSE
BEGIN
FixFigureInField(Figures[TheFigure][FigureNr],TopX,TopY,FALSE);
FixColField(TheFigure);
IF InitAFigure(TheFigure) THEN
BEGIN
FixMainFieldLines;
FixFigureInField(Figures[TheFigure][FigureNr],TopX,TopY,FALSE);
DisplMainFieldText;
Delay(DelayTime*IterationPerDelay);
END
ELSE
BEGIN
FixFigureInField(Figures[TheFigure][FigureNr],TopX,TopY,FALSE);
EndGame:=TRUE;
END;
END;
END
ELSE
IF FixHickup>1 THEN
DEC(FixHickup);
DisplMainFieldText;
UNTIL EndGame;
FixHighScores;
CursorOn;
SetDefaultColor;
GotoXY(1,25);
END;
CONST FileName='fpctris.scr';
VAR I : LONGINT;
BEGIN
FOR I:=0 TO 9 DO
HighScore[I].Score:=(I+1)*750;
LoadHighScore(FileName);
DoFpcTris;
SaveHighScore;
END.
{
$Log$
Revision 1.2 1999-06-01 19:24:32 peter
* updates from marco
Revision 1.1 1999/05/27 21:36:33 peter
* new demo's
* fixed mandel for linux
}
Reference in New Issue View Git Blame Copy Permalink