BitMap=array[0..5759] of integer; { typical bit maps: 0..23 for med-res, 0..49 for hi-res }
LongString=string[255];
Cmap=array[0..31] of byte;
Smap=array[0..255] of byte;
procedure GraphicsOn; begin
Gmode:=Gmode or $80;
port[$53]:=$BF; { enable G.O. }
port[$51]:=Gmode;
if not DualMonitor then begin
port[$57]:=$0D;
port[$0A]:=$87 end end; { disable VT102 }
procedure GraphicsOff; begin
Gmode:=Gmode and $7F; { disable G.O. }
port[$53]:=$BF;
port[$51]:=Gmode;
port[$0A]:=$83 end; { enable VT102 }
procedure GPort (parm:LongString); var PP,QQ,RR,SS: integer; begin
QQ:=length(parm);
PP:=1; while PP<QQ do begin
RR:=ord(parm[PP+1])-48; if RR>15 then RR:=RR-7;
SS:=ord(parm[PP+2])-48; if SS>15 then SS:=SS-7;
port[ord(parm[PP])+32]:=(RR shl 4)+SS;
PP:=PP+3 end end;
procedure Gw56(word:integer); { port[$56]:=lo(word); port[$56]:=hi(word) }
begin inline($8B/$86/word/$E6/$56/$8A/$C4/$E6/$56) end;
procedure WaitForGDCNotBusy; begin
inline($E4/$56/$A8/$02/$74/$0B/$B9/$00/$80/$E4/$56/$A8/$02/$74/$02/$E2/
$F8/$B0/$0D/$E6/$57/$E4/$56/$A8/$02/$74/$0B/$B9/$00/$80/$E4/$56/
$A8/$02/$75/$02/$E2/$F8/$B8/$0D/$04/$E6/$57/$B9/$00/$80/$E4/$56/
$84/$E0/$75/$02/$E2/$F8);
{ for QQ:=0 to $8000 do if (port[$56] and $02)=0 then goto G1;
G1: port[$57]:=$4A;
for QQ:=0 to $8000 do if (port[$56] and $02)=0 then goto G2;
G2: for QQ:=0 to $8000 do if (port[$56] and $04)=4 then goto G3;
G3:}end;
procedure WaitForGDCIdle; label G4; var QQ: integer; begin
WaitForGDCNotBusy;
if not drawing then goto G4;
for QQ:=0 to $8000 do if (port[$56] and $0F)=4 then goto G4;
G4: end;
procedure LoadColorMap (var map: Cmap); begin
WaitForGDCIdle;
while (port[$56] and $20)<>0 do;{ wait for beginning of vertical retrace }
inline($FA);
while (port[$56] and $20)=0 do;
inline($8B/$B6/map/$B0/$DF/$E6/$53/$B9/$20/
$00/$AC/$F6/$D0/$E6/$51/$E2/$F9/$FB) end;
procedure LoadScrollMap (var map: Smap); begin
WaitForGDCIdle; { This routine is extremely timing sensitive.}
Gtemp:=Gmode and $DF; { It must start and end in the same vertical }
inline($FA); { retrace period, and barely does so. }
while (port[$56] and $20)<>0 do;
inline($B9/$40/$1F/$E4/$56/$A8/$20/$75/$02/$E2/$F8/
$B0/$BF/$E6/$53/$A0/Gtemp/$E6/$51/
$B0/$7F/$E6/$53/$B2/$51/$32/$F6/
$8B/$B6/map/$B9/$10/$00/
$AD/$EE/$8A/$C4/$EE/$AD/$EE/$8A/$C4/$EE/
$AD/$EE/$8A/$C4/$EE/$AD/$EE/$8A/$C4/$EE/
$AD/$EE/$8A/$C4/$EE/$AD/$EE/$8A/$C4/$EE/
$AD/$EE/$8A/$C4/$EE/$AD/$EE/$8A/$C4/$EE/
$E2/$D6/$B0/$BF/$E6/$53/$A0/Gmode/$E6/$51/$FB) end;
procedure Color (FG:integer); begin
GDCfg:=FG;
Gtemp:=(GDCfg shl 4)+(GDCbg and 15);
inline($B0/$F7/$E6/$53/$A0/Gtemp/$E6/$51) end;
procedure BackgroundColor (BG:integer); begin
GDCbg:=BG;
Gtemp:=(GDCfg shl 4)+(GDCbg and 15);
inline($B0/$F7/$E6/$53/$A0/Gtemp/$E6/$51) end;
procedure Operation (ALU,PlaneSelect: integer); begin
GDCalu:=ALU;
GDCps:=PlaneSelect;
WaitForGDCIdle;
port[$53]:=$EF;
port[$51]:=(GDCalu shl 4)+(GDCps and 15 xor 15);
end;
procedure Ginitialize; var PP,QQ: integer; begin
DualMonitor:=false;
ErrorPtr:=ofs(GraphicsOff); { <--- This will disable graphics on a run }
if HighResolution then begin { statement if it gets a compile error.}
Gmode:=$31;
maxX:=799; Yfix:=6;
GPort('7003BF1316126306646086036036F0640747640') end
else begin
Gmode:=$30;
maxX:=383; Yfix:=5;
GPort('7003BF1306126166616046026036F0640747620') end;
WaitForGDCNotBusy;
GPort('76B7466007227706006006FF60F7786FF6FF74B60060060076F06F');
Pattern(255,1);
Color(15);
BackgroundColor(0);
Operation(0,15);
GPort('400500');
WaitForGDCNotBusy;
GPort('3FE100');
for QQ:=0 to 15 do port[$52]:=$FF;
WaitForGDCNotBusy;
GPort('3FE10074960060074A6FF6FF74C6026FF63F7226FF6FF70D');
WaitForGDCIdle;
end;
procedure WriteRectangle(loX,hiX,loY,hiY: integer; var area: BitMap);
var PP,QQ,RR,SS,TT,ZZ,ZZ1,ZZ2,mask: integer;
begin
for PP:=(loX shr 4) to (hiX shr 4) do begin
TT:=PP shl 4;
ZZ := swap(PP) - TT;
mask:=$FFFF;
if TT+15>hiX then mask:=mask shl (TT+15-hiX);
if TT<loX then mask:=mask and ($FFFF shr (loX-TT));
SS:=loY;
while SS<=hiY do begin
RR:=SS;
SS:=SS+8;
if SS > hiY
then SS := hiY+1;
ZZ1 := ZZ+RR;
ZZ2 := ZZ+SS-1;
inline($E4/$56/$A8/$02/$74/$0B/$B9/$00/$80/$E4/$56/$A8/$02/$74/
$02/$E2/$F8/$B0/$0D/$E6/$57/$E4/$56/$A8/$02/$74/$0B/$B9/
$00/$80/$E4/$56/$A8/$02/$75/$02/$E2/$F8/$B8/$0D/$04/$E6/
$57/$B9/$00/$80/$E4/$56/$84/$E0/$75/$02/$E2/$F8);
for QQ:=ZZ1 to ZZ2 do begin
{$R-} Gtemp:= not area[QQ];
{$R+} inline($A1/Gtemp/$E6/$52/$8A/$C4/$E6/$52);
end;
if SS = hiY+1 then
for QQ:=hiy+1 to rr+7 do
inline($B0/$00/$E6/$52/$E6/$52);
Temp1:=PP+(RR shl Yfix);
Temp2 := not mask;
Temp3 := SS-RR-1;
inline($B0/$49/$E6/$57/$A1/Temp1/$E6/$56/$8A/$C4/$E6/$56/$A1/
Temp2/$E6/$54/$8A/$C4/$E6/$55/$B0/$4C/$E6/$57/$B0/$00/
$E6/$56/$A1/Temp3/$E6/$56/$8A/$C4/$E6/$56/$B0/$22/$E6/
$57/$B0/$FF/$E6/$56/$E6/$56);
end;
end;
end;
procedure InitGraphic;
var
p : integer;
begin { required initialization }
{ red --+ green --+ }
{ |+-- mono +--- blue }
{ || || }
ColorMap[00]:=$00; ColorMap[16]:=$00; { 0 black }
ColorMap[01]:=$0F; ColorMap[17]:=$F0; { 1 green }
ColorMap[02]:=$FD; ColorMap[18]:=$06; { 2 red }
ColorMap[03]:=$FB; ColorMap[19]:=$0F; { 3 red-violet }
ColorMap[04]:=$88; ColorMap[20]:=$0B; { 4 purple }
ColorMap[05]:=$B6; ColorMap[21]:=$75; { 5 brown }
ColorMap[06]:=$F4; ColorMap[22]:=$F0; { 6 yellow }
ColorMap[07]:=$FF; ColorMap[23]:=$FF; { 7 white }
ColorMap[08]:=$00; ColorMap[24]:=$00; { 8 switched1 }
ColorMap[09]:=$00; ColorMap[25]:=$00; { 9 switched2 }
ColorMap[10]:=$90; ColorMap[26]:=$02; { 10 dark red }
ColorMap[11]:=$F7; ColorMap[27]:=$70; { 11 orange }
ColorMap[12]:=$00; ColorMap[28]:=$0F; { 12 blue }
ColorMap[13]:=$0F; ColorMap[29]:=$FD; { 13 turquoise }
ColorMap[14]:=$B1; ColorMap[30]:=$16; { 14 burgandy }
ColorMap[15]:=$FB; ColorMap[31]:=$BB; { 15 pink }
{ Note. The colors of the table above have been selected so that:
* plane 0 turns on the green gun
* plane 1 turns on the red gun
* plane 2 turns on the blue gun
* plane 3 causes a darkening and reddening of the other colors
But any other criteria is allowed.}
for p := 0 to 255 do ScrollMap[p] := p;
HighResolution:=false; { Change to 'true' for high resolution demo }
Ginitialize; { Initialize }
DualMonitor:=false; { Dual CRTs }
{ end of required initialization }
LoadScrollMap(ScrollMap);
LoadColorMap(ColorMap); { Load color map }
Operation(0,15); { REPLACE write to all planes }
Pattern(255,4); { Draw all lines as solid lines }
fillchar(plane0,11520,0);
WriteRectangle(0,maxx,0,maxy,plane0);
end;
(* Keyboard Read Routine *)
type registers = record case integer of
1: (ax,bx,cx,dx,bp,si,di,ds,es,flags : integer);
2: (al,ah,bl,bh,cl,ch,dl,dh : byte);
end;
type KeyType = record { Returned by ReadKbd }
Chr_Key : char; { Character }
Fun_Key : F_Key_Type; { Function Key Value }
Ctrl_Key, { \ }
Shift_Key, { > True If On }
Lock_Key : boolean; { / }
end;
var
Keystroke : keytype;
TYPE
array1to4by1to4 = ARRAY [1..4,1..4] OF INTEGER;
string80 = string[80];
PROCEDURE ReadKbd (var Keys : KeyType);
VAR
regs : Registers;
begin { ReadKbd }
regs.di := $06; { set up to read keyboard }
intr ($18,regs); { lets read it }
if regs.al <= $65
then Keys.Fun_Key := F_Keys[regs.al]; { assign function key type name }
end; { ReadKbd }
PROCEDURE initialize;
VAR
i : INTEGER;
j : INTEGER;
BEGIN
FOR i := 1 TO 10 DO
FOR j := -2 TO 20 DO
gamearea [i,j] := 0;
newblock := TRUE;
score := 0;
scoreaddon := 0;
scorecarry := 0;
FOR i := 1 TO 160 DO
BEGIN
plane0[3*240+i] := $0400;
plane0[9*240+i] := $0040;
END;
FOR i := 4 to 8 DO
plane0[i*240+160] := $FFFF;
plane0[3*240+160] := $0700;
plane0[9*240+160] := $00C0;
color (white);
writerectangle (0,maxx,0,maxy,plane0);
END;
FUNCTION movepossible : BOOLEAN;
VAR
i : INTEGER;
j : INTEGER;
endoffall : BOOLEAN;
BEGIN
endoffall := blockpositiony > 16;
IF NOT endoffall
THEN BEGIN
FOR i := 1 TO 4 DO
FOR j := 1 TO 4 DO
IF (blockpositionx+i > 1) AND
(blockpositionx+i < 12) AND
(blockpositiony+j > 1)
THEN endoffall := endoffall OR
((gamearea[blockpositionx+i-1,blockpositiony+j-1] > 0) AND
(block[j,i] > 0))
END;
movepossible := NOT endoffall;
END;
PROCEDURE makeblock;
VAR
index : INTEGER;
blockrightnew : INTEGER;
blockleftnew : INTEGER;
blockold : array1to4by1to4;
BEGIN
IF (blockorientation > 0) AND (blockorientation < 5) AND
(blocktype > 0) AND (blocktype < 8)
THEN BEGIN
index := blocktype*4+blockorientation-4;
blockleftnew := blockpositionminx[index];
blockrightnew := blockpositionmaxx[index];
IF (blockpositionx >= 2-blockleftnew) AND
(blockpositionx <= 11-blockrightnew)
THEN BEGIN
blockold := block;
block := allblocks[index];
if movepossible
then begin
blockleft := blockleftnew;
blockright := blockrightnew;
end
else begin
block := blockold;
blockorientation := blockorientation-1;
IF blockorientation = 0
THEN blockorientation := 4;
end;
END
ELSE BEGIN
blockorientation := blockorientation-1;
IF blockorientation = 0
THEN blockorientation := 4;
END;
END;
END;
procedure initializedigits;
var
j : integer;
i : integer;
begin
for j := 0 to 9 do
for i := 0 to 10 do
begin
digit[i+2*11*j+11] :=
(digitarray[i+11*j] shl 11) or (digitarray[i+11*j] shr 5);
digit[i+2*11*j] := digitarray[i+11*j] shl 3;
end;
end;
procedure WriteDigitOfValue (ValueDigit, xkoord, digitcount : integer);
var
r : integer;
i : integer;
p : integer;
const
ystart : integer = 180;
yend : integer = 190;
begin
r := (ValueDigit shl 4)+(ValueDigit shl 2)+(ValueDigit shl 1);
p := ((xkoord and $FFF0) shl 4) - (xkoord and $FFF0);
if not odd(digitcount)
then begin
r := r+11;
for i := ystart to yend do
begin
plane0[p+i] := digit[r]; (* digit[r] Fehler ??? *)
r := r+1;
end;
color (white);
writerectangle (xkoord, xkoord+7, ystart, yend, plane0);
end
else begin
for i := ystart to yend do
begin
plane0[p+i] := digit[r]; (* digit[r] Fehler ??? *)
plane0[p+i+240] := plane0[p+i];
r := r+1;
end;
color (white);
writerectangle (xkoord, xkoord+8, ystart, yend, plane0);
end;
end;
procedure addscore (scorevalue : INTEGER);
begin
score := score+scorevalue;
while score >= 1000 do
begin
score := score-1000;
scoreaddon := scoreaddon+1;
if scoreaddon >= 100
then begin
scorecarry := (scoreaddon div 100)+scorecarry;
scoreaddon := scoreaddon mod 100;
WriteDigitOfValue (0, 84, 0);
end;
if score < 1000
then begin
displayvalue (scoreaddon, 84-(digitwidth shl 1)-digitwidth, 0);
WriteDigitOfValue (0, 100, 0);
WriteDigitOfValue (0, 108, 1);
end;
end;
displayvalue (score, 84, 1);
end;
PROCEDURE checkrowfull;
VAR
i : INTEGER;
i1 : INTEGER;
i2 : INTEGER;
j : INTEGER;
found : BOOLEAN;
scrollsave : INTEGER;
BEGIN
FOR i := 1 TO 20 DO
BEGIN
found := TRUE;
FOR j := 1 TO 10 DO
found := found AND (gamearea[j,i] > 0);
IF found
THEN BEGIN
write (chr(7));
level := level-1;
addscore ((1000-level) div 10);
FOR i1 := 1 TO i-1 DO
FOR j := 1 TO 10 DO
gamearea[j,i-i1+1] := gamearea[j,i-i1];
FOR j := 1 TO 10 DO
gamearea[j,1] := 0;
for j := 1 to 4 do
begin
scrollsave := scrollmap[i*4+3];
for i1 := 0 to i*4+2 do
ScrollMap[4*i+3-i1] := Scrollmap[4*i+2-i1];
scrollmap[0] := scrollsave;
for i1 := 8*i+6 to 8*i+7 do
for i2 := 0 to 23 do
plane0[i2*240+i1] := $0000;
writerectangle (0, maxx, 8*i+6, 8*i+7, plane0);
color (white);
plane0[3*240+1] := $0400;
plane0[9*240+1] := $0040;
plane0[3*240+2] := $0400;
plane0[9*240+2] := $0040;
writerectangle (0, maxx, 1, 2, plane0);
LoadScrollMap(ScrollMap);
end;
END;
END;
END;
PROCEDURE checkifgameover;
VAR
i : INTEGER;
BEGIN
FOR i := 1 to 4 DO
IF (block[4,i] > 0) AND (gamearea[3+i,1] > 0)
THEN blocktype := 0;
END;
PROCEDURE DisplaySquare (ykoord, xkoord, squarecolor : INTEGER);
VAR
i : INTEGER;
x : INTEGER;
x2 : INTEGER;
BEGIN
x := xkoord SHR 1;
x2 := x SHR 1;
FOR i := ykoord*8 TO ykoord*8+6 DO
IF squarecolor = -1
THEN BEGIN
IF ODD(x)
THEN plane0[x2*240+i] := plane0[x2*240+i] AND $00FE
ELSE plane0[x2*240+i] := plane0[x2*240+i] AND $FE00;
END
ELSE BEGIN
IF ODD(x)
THEN plane0[x2*240+i] := plane0[x2*240+i] OR $FE00
ELSE plane0[x2*240+i] := plane0[x2*240+i] OR $00FE;
END;
IF squarecolor <> -1
THEN BEGIN
color (squarecolor);
writerectangle (x*8, x*8+6, ykoord*8, ykoord*8+6, plane0);
END
ELSE IF (x > 7) AND (x < 18)
THEN IF gamearea[x-7,ykoord] = 0
THEN writerectangle (x*8, x*8+6, ykoord*8, ykoord*8+6, plane0);
END;
PROCEDURE displayblock;
VAR
i : INTEGER;
j : INTEGER;
temp : INTEGER;
BEGIN
FOR i := 1 TO 4 DO
FOR j := 1 TO 4 DO
BEGIN
IF blockpositiony+i-1 > 0
THEN BEGIN
IF block[i,j] = 0
THEN BEGIN
temp := blockpositionx+j-1;
IF (temp > 0) AND (temp < 11)
THEN
DisplaySquare (blockpositiony+i-1, 2*(blockpositionx+j)+12, -1);
END
ELSE
DisplaySquare (blockpositiony+i-1, 2*(blockpositionx+j)+12, block[i,j]);
END;
END;
END;
FUNCTION max (a, b : INTEGER) : INTEGER;
BEGIN
IF a > b
THEN max := a
ELSE max := b;
END;
PROCEDURE turnmoveblock;
VAR
i : INTEGER;
j : INTEGER;
z : INTEGER;
BEGIN
z := 0;
REPEAT
readkbd (Keystroke);
z := z+1;
IF (z AND $15) = 0
THEN i := random (100);
UNTIL (Keystroke.fun_key = _LeftArrow) OR
(Keystroke.fun_key = _RightArrow) OR
(Keystroke.fun_key = _DownArrow) OR
(Keystroke.fun_key = _UpArrow) OR
(z = level) OR
(Keystroke.fun_key = _Exit);
IF Keystroke.fun_key = _LeftArrow
THEN BEGIN
IF blockpositionx > 2-blockleft
THEN BEGIN
blockpositionx := blockpositionx-1;
IF movepossible
THEN FOR i := blockpositiony TO blockpositiony+3 DO
DisplaySquare (i, 2*(blockpositionx+4)+14, -1)
ELSE blockpositionx := blockpositionx+1;
END;
END
ELSE IF z = level
THEN BEGIN
blockpositiony := blockpositiony+1;
IF movepossible
THEN BEGIN
IF blockpositiony > 0
THEN FOR i := blockpositionx TO blockpositionx+3 DO
IF (i > 0) AND (i < 11)
THEN DisplaySquare (blockpositiony-1, 2*i+14, -1);
END
ELSE BEGIN
blockpositiony := blockpositiony-1;
FOR i := 1 TO 4 DO
FOR j := 1 TO 4 DO
IF block[j,i] > 0
THEN gamearea[blockpositionx+i-1,blockpositiony+j-1] :=
block[j,i];
newblock := TRUE;
addscore ((1000-level) div 50);
END;
END
ELSE IF Keystroke.fun_key = _RightArrow
THEN BEGIN
IF blockpositionx < 11-blockright
THEN BEGIN
blockpositionx := blockpositionx+1;
IF movepossible
THEN FOR i := blockpositiony TO blockpositiony+3 DO
DisplaySquare (i, 2*(blockpositionx)+12, -1)
ELSE blockpositionx := blockpositionx-1;
END;
END
ELSE BEGIN
IF Keystroke.fun_key = _Exit
THEN BEGIN
GraphicsOff;
HALT;
END
ELSE IF Keystroke.fun_key = _UpArrow
THEN BEGIN
blockpositiony := blockpositiony+1;
IF movepossible
THEN BEGIN
FOR i := blockpositionx TO blockpositionx+3 DO
IF (i > 0) AND (i < 11)
THEN FOR j := max (1, blockpositiony-1) TO blockpositiony+2 DO
DisplaySquare (j, 2*i+14, -1);
REPEAT
blockpositiony := blockpositiony+1;
UNTIL NOT movepossible;
blockpositiony := blockpositiony-1;
FOR i := 1 TO 4 DO
FOR j := 1 TO 4 DO
IF block[j,i] > 0
THEN gamearea[blockpositionx+i-1,blockpositiony+j-1] :=
block[j,i];
displayblock;
newblock := TRUE;
addscore ((1000-level) div 50);
END
ELSE BEGIN
blockpositiony := blockpositiony-1;
FOR i := 1 TO 4 DO
FOR j := 1 TO 4 DO
IF block[j,i] > 0
THEN gamearea[blockpositionx+i-1,blockpositiony+j-1] :=
block[j,i];
newblock := TRUE;
addscore ((1000-level) div 50);
END;
END
ELSE BEGIN
blockorientation := (blockorientation AND $3)+1;
makeblock;
END;
END;
END;
procedure GetEnvParam (EnvName : string80; var param : string80);
var
I : integer;
EnvSeg, { segment address of environment from PSP }
EnvIndex : integer; { index into environment }
TempName : string80; { current environment string name }
ch : char; { current character from environment }
found : boolean; { if true then environment name was found }
begin { GetEnvParam }
for I := 1 to length(EnvName) do
EnvName[I] := upcase(EnvName[I]);
EnvIndex := 0;
EnvSeg := MemW[CSeg:$2C]; { get address of environment from PSP }
found := false;
ch := chr(Mem[EnvSeg:EnvIndex]); { get first char from environment }
while (ch <> chr(0)) and (not found) do
begin
TempName := '';
while (ch <> '=') and (length(TempName) < 255) do
begin { get environment string name }
TempName := TempName + ch;
EnvIndex := EnvIndex + 1;
ch := chr(Mem[EnvSeg:EnvIndex])
end;
EnvIndex := EnvIndex + 1; { skip over the EQUALS }
param := '';
ch := chr(Mem[EnvSeg:EnvIndex]);
while ch <> chr(0) do { get environment string parameter }
begin
param := param + ch;
EnvIndex := EnvIndex + 1;
ch := chr(Mem[EnvSeg:EnvIndex])
end;
found := EnvName = TempName;
EnvIndex := EnvIndex + 1;
ch := chr(Mem[EnvSeg:EnvIndex])
end;
if not found then param := ''
end; { GetEnvParam }
procedure GetSystemDate;
var
regs : registers;
day : string[2];
month : string[2];
year : string[4];
begin
with regs do
begin
ah := $2A;
msdos (regs);
str (dl:2, day);
str (dh:2, month);
str (cx:4, year);
ScoreDate := day+'.'+month+'.'+year[3]+year[4];
end;
end;
procedure printtopten;
VAR
i : INTEGER;
begin
writeln (^[, '[H', ^[, '[J');
writeln;
writeln (^[, '#3 Tetris TopTen Liste');
writeln (^[, '#4 Tetris TopTen Liste');
writeln;
writeln;
writeln (' Name Punkte Datum');
writeln;
for i := 0 to 9 do
begin
move (TopTenRecord[32*i+1], name, 20);
move (TopTenRecord[32*i+21], Pointshi, 2);
move (TopTenRecord[32*i+23], Pointslo, 2);
move (TopTenRecord[32*i+25], ScoreDate, 8);
if TopTenRecord[32*i+1] > 0
then begin
if i = lines-1
then write (^[, '[5m');
write (' ',name, ' ');
if Pointshi = 0
then write (' ')
else write (Pointshi:5);
if Pointshi > 0
then begin
if Pointslo = 0
then writeln ('0000 ', ScoreDate)
else if Pointslo < 10
then writeln ('00', Pointslo*10:2, ' ', ScoreDate)
else if Pointslo < 100
then writeln ('0', Pointslo*10:3, ' ', ScoreDate)
else writeln (Pointslo*10:4, ' ', ScoreDate);
end
else writeln (Pointslo*10:4, ' ', ScoreDate);
if i = lines-1
then write (^[, '[0m');
end
else writeln;
end;
writeln;
writeln;
end;
procedure TopTen;
begin
writeln (^[, '[H', ^[, '[J', ^[, '[0m');
GraphicsOff;
GetEnvParam ('TETRIS', parameter);
if parameter = ''
then parameter := 'tetris.tmp';
assign (TopTenFile, parameter);
{$I-}
reset (TopTenFile);
{$I+}
if IOResult <> 0
then CreateNewTopTenFile;
blockread (TopTenFile, TopTenRecord, 3);
lines := 0;
scoreaddon := scoreaddon+100*scorecarry;
inserted := false;
repeat
move (TopTenRecord[32*lines+21], Pointshi, 2);
move (TopTenRecord[32*lines+23], Pointslo, 2);
if (Pointshi < scoreaddon) or
((Pointshi = scoreaddon) and (Pointslo < score))
then begin
write ('Ihr werter Name : ');
readln (name);
GetSystemDate;
move (TopTenRecord[32*lines+1], TopTenRecord[32*lines+33], 352-32*lines);
move (name, TopTenRecord[32*lines+1], 20);
move (scoreaddon, TopTenRecord[32*lines+21], 2);
move (score, TopTenRecord[32*lines+23], 2);
move (ScoreDate, TopTenRecord[32*lines+25], 8);
inserted := true;
end;
lines := lines+1;
until (lines = 10) or inserted;
if inserted
then begin
seek (TopTenFile, 0);
blockwrite (TopTenFile, TopTenRecord, 3);
end
else lines := 11;
close (TopTenFile);
printtopten;
end;
PROCEDURE filltoHeight;
VAR
i : INTEGER;
j : INTEGER;
index : INTEGER;
blockleftnew : INTEGER;
blockrightnew : INTEGER;
BEGIN
REPEAT
blocktype := RANDOM(7)+1;
blockorientation := RANDOM(4)+1;
blockpositiony := -2;
index := blocktype*4+blockorientation-4;
blockleftnew := blockpositionminx[index];
blockrightnew := blockpositionmaxx[index];
REPEAT
blockpositionx := RANDOM(18)-3;
UNTIL (blockpositionx >= 2-blockleftnew) AND
(blockpositionx <= 11-blockrightnew);
makeblock;
blockpositiony := blockpositiony+1;
IF movepossible
THEN BEGIN
FOR i := blockpositionx TO blockpositionx+3 DO
IF (i > 0) AND (i < 11)
THEN FOR j := max (1, blockpositiony-1) TO blockpositiony+2 DO
DisplaySquare (j, 2*i+14, -1);
REPEAT
blockpositiony := blockpositiony+1;
UNTIL NOT movepossible;
blockpositiony := blockpositiony-1;
FOR i := 1 TO 4 DO
FOR j := 1 TO 4 DO
IF block[j,i] > 0
THEN gamearea[blockpositionx+i-1,blockpositiony+j-1] :=
block[j,i];
displayblock;
END
ELSE BEGIN
blockpositiony := blockpositiony-1;
FOR i := 1 TO 4 DO
FOR j := 1 TO 4 DO
IF block[j,i] > 0
THEN gamearea[blockpositionx+i-1,blockpositiony+j-1] :=
block[j,i];
END;
UNTIL blockpositiony+blockpositionmaxy[index]-2 <= 18-Height;
END;
