PROGRAM TETRIS;
{$R+}

(* GRAPHIC ROUTINES by Ken Nist *)

type

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;

var

HighResolution,VectorMode,drawing,DualMonitor: boolean;
Gmode,Yfix,GDCpat,GDCmult,GDCfg,GDCbg,GDCalu,GDCps: byte;
CharHPitch,CharVPitch,TopMargin,BottomMargin,LeftMargin,RightMargin: byte;
Temp1,Temp2,Temp3,Gtemp,maxX: integer;

VAR

plane0          : BitMap;
plane2          : BitMap;
plane1          : BitMap;
plane3          : BitMap;
ColorMap        : Cmap;
ScrollMap       : Smap;

CONST

black:   byte=0;   green:     byte=1;   red:       byte=2;   redviolet: byte=3;
purple:  byte=4;   brown:     byte=5;   yellow:    byte=6;   white:     byte=7;
switch1: byte=8;   switch2:   byte=9;   switch3:   byte=10;  orange:    byte=11;
blue:    byte=12;  turquoise: byte=13;  burgandy:  byte=14;  pink:      byte=15;

const

maxY: integer=239;

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 Pattern (pat,mult:integer); begin
    GDCpat:=pat;
    GDCmult:=mult;
    WaitForGDCIdle;
    port[$53]:=$FD;  port[$51]:=16-GDCmult;
    port[$53]:=$FB;  port[$51]:=GDCpat 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    F_Key_Type = (
        _Help, _Do, _Compose, _PrintScreen, _Char, _F4, _nl2, _Interrupt,
        _nl3, _Resume, _nl4, _Cancel, _nl5, _MainScreen, _nl6, _Exit, _nl7,
        _AddtlnOptions, _nl8, _F17, _nl9, _F18, _nl10, _F19, _nl11, _F20,
        _nl12, _Find, _nl13, _InsertHere, _nl14, _Remove, _nl15, _Select,
        _nl16, _PrevScreen, _nl17, _NextScreen, _nl18, _UpArrow, _nl19,
        _DownArrow, _nl20, _RightArrow, _nl21, _LeftArrow, _nl22, _KP0,
        _nl23, _nl24, _KP1, _nl25, _nl26, _KP2, _nl27, _nl28, _KP3, _nl29,
        _nl30, _KP4, _nl31, _nl32, _KP5, _nl33, _nl34, _KP6, _nl35, _nl36,
        _KP7, _nl37, _nl38, _KP8, _nl39, _nl40, _KP9, _nl41, _nl42, _KPMinus,
        _nl43, _nl44, _KPComma, _nl45, _nl46, _KPPeriod, _nl47, _nl48,
        _KPEnter, _nl49, _nl50, _PF1, _nl51, _nl52, _PF2, _nl53, _nl54, _PF3,
        _nl55, _nl56, _PF4, _nl57, _nl58, _Break);

const   F_Keys : array [$0..$65] of F_Key_Type = (
        _Help, _Do, _Compose, _PrintScreen, _Char, _F4, _nl2, _Interrupt,
        _nl3, _Resume, _nl4, _Cancel, _nl5, _MainScreen, _nl6, _Exit, _nl7,
        _AddtlnOptions, _nl8, _F17, _nl9, _F18, _nl10, _F19, _nl11, _F20,
        _nl12, _Find, _nl13, _InsertHere, _nl14, _Remove, _nl15, _Select,
        _nl16, _PrevScreen, _nl17, _NextScreen, _nl18, _UpArrow, _nl19,
        _DownArrow, _nl20, _RightArrow, _nl21, _LeftArrow, _nl22, _KP0,
        _nl23, _nl24, _KP1, _nl25, _nl26, _KP2, _nl27, _nl28, _KP3, _nl29,
        _nl30, _KP4, _nl31, _nl32, _KP5, _nl33, _nl34, _KP6, _nl35, _nl36,
        _KP7, _nl37, _nl38, _KP8, _nl39, _nl40, _KP9, _nl41, _nl42, _KPMinus,
        _nl43, _nl44, _KPComma, _nl45, _nl46, _KPPeriod, _nl47, _nl48,
        _KPEnter, _nl49, _nl50, _PF1, _nl51, _nl52, _PF2, _nl53, _nl54, _PF3,
        _nl55, _nl56, _PF4, _nl57, _nl58, _Break);

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];

VAR

    parameter         : string80;
    TopTenFile        : file;
    name              : array [1..20] of char;
    ScoreDate         : string[8];
    Pointshi          : integer;
    Pointslo          : integer;
    lines             : integer;
    TopTenRecord      : array [1..384] of byte;
    inserted          : boolean;
    digit             : array [0..219] of integer;
    score             : INTEGER;
    scoreaddon        : INTEGER;
    scorecarry        : INTEGER;
    level             : INTEGER;
    Height            : INTEGER;
    gamearea          : ARRAY [1..10,-2..20] OF INTEGER;
    block             : array1to4by1to4;
    blocktype         : INTEGER;
    blockorientation  : INTEGER;
    blockpositionx    : INTEGER;
    blockpositiony    : INTEGER;
    blockright        : INTEGER;
    blockleft         : INTEGER;
    newblock          : BOOLEAN;

CONST
    digitarray        : array [0..109] of integer = (
           $00FE,$0082,$0082,$0082,$0082,$0082,$0082,$0082,$0082,$0082,$00FE,
           $0002,$0002,$0002,$0002,$0002,$0002,$0002,$0002,$0002,$0002,$0002,
           $00FE,$0002,$0002,$0002,$0002,$00FE,$0080,$0080,$0080,$0080,$00FE,
           $00FE,$0002,$0002,$0002,$0002,$00FE,$0002,$0002,$0002,$0002,$00FE,
           $0082,$0082,$0082,$0082,$0082,$00FE,$0002,$0002,$0002,$0002,$0002,
           $00FE,$0080,$0080,$0080,$0080,$00FE,$0002,$0002,$0002,$0002,$00FE,
           $0080,$0080,$0080,$0080,$0080,$00FE,$0082,$0082,$0082,$0082,$00FE,
           $00FE,$0002,$0002,$0002,$0002,$0002,$0002,$0002,$0002,$0002,$0002,
           $00FE,$0082,$0082,$0082,$0082,$00FE,$0082,$0082,$0082,$0082,$00FE,
           $00FE,$0082,$0082,$0082,$0082,$00FE,$0002,$0002,$0002,$0002,$0002);
    digitwidth        : integer = 8;
    blockpositionmaxx : ARRAY [1..28] OF INTEGER =
                     (4,3,4,3,3,3,3,3,4,4,4,3,4,3,4,3,4,3,4,3,4,3,4,3,4,3,4,3);
    blockpositionminx : ARRAY [1..28] OF INTEGER =
                     (1,3,1,3,2,2,2,2,2,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2);
    blockpositionmaxy : ARRAY [1..28] OF INTEGER =
                     (4,1,4,1,3,3,3,3,3,2,3,2,3,2,3,2,3,2,3,2,3,2,3,2,3,2,3,2);
    allblocks         : ARRAY [1..28] OF array1to4by1to4 =
                         (((0,0,0,0),(0,0,0,0),(0,0,0,0),(1,1,1,1)),
                          ((0,0,1,0),(0,0,1,0),(0,0,1,0),(0,0,1,0)),
                          ((0,0,0,0),(0,0,0,0),(0,0,0,0),(1,1,1,1)),
                          ((0,0,1,0),(0,0,1,0),(0,0,1,0),(0,0,1,0)),
                          ((0,0,0,0),(0,0,0,0),(0,2,2,0),(0,2,2,0)),
                          ((0,0,0,0),(0,0,0,0),(0,2,2,0),(0,2,2,0)),
                          ((0,0,0,0),(0,0,0,0),(0,2,2,0),(0,2,2,0)),
                          ((0,0,0,0),(0,0,0,0),(0,2,2,0),(0,2,2,0)),
                          ((0,0,0,0),(0,0,0,0),(0,3,3,3),(0,0,3,0)),
                          ((0,0,0,0),(0,0,3,0),(0,0,3,3),(0,0,3,0)),
                          ((0,0,0,0),(0,0,0,0),(0,0,3,0),(0,3,3,3)),
                          ((0,0,0,0),(0,0,3,0),(0,3,3,0),(0,0,3,0)),
                          ((0,0,0,0),(0,0,0,0),(0,4,4,4),(0,4,0,0)),
                          ((0,0,0,0),(0,4,0,0),(0,4,0,0),(0,4,4,0)),
                          ((0,0,0,0),(0,0,0,0),(0,0,0,4),(0,4,4,4)),
                          ((0,0,0,0),(0,4,4,0),(0,0,4,0),(0,0,4,0)),
                          ((0,0,0,0),(0,0,0,0),(0,5,5,5),(0,0,0,5)),
                          ((0,0,0,0),(0,5,5,0),(0,5,0,0),(0,5,0,0)),
                          ((0,0,0,0),(0,0,0,0),(0,5,0,0),(0,5,5,5)),
                          ((0,0,0,0),(0,0,5,0),(0,0,5,0),(0,5,5,0)),
                          ((0,0,0,0),(0,0,0,0),(0,0,6,6),(0,6,6,0)),
                          ((0,0,0,0),(0,6,0,0),(0,6,6,0),(0,0,6,0)),
                          ((0,0,0,0),(0,0,0,0),(0,0,6,6),(0,6,6,0)),
                          ((0,0,0,0),(0,6,0,0),(0,6,6,0),(0,0,6,0)),
                          ((0,0,0,0),(0,0,0,0),(0,7,7,0),(0,0,7,7)),
                          ((0,0,0,0),(0,0,7,0),(0,7,7,0),(0,7,0,0)),
                          ((0,0,0,0),(0,0,0,0),(0,7,7,0),(0,0,7,7)),
                          ((0,0,0,0),(0,0,7,0),(0,7,7,0),(0,7,0,0)));

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 displayvalue (displayval, digitplace, digitstart : integer);
var
    ValueDigit  : integer;
    scorexkoord : integer;
    digitcount  : integer;
begin
    scorexkoord := digitplace+(digitwidth shl 2);
    digitcount := digitstart;
    repeat
        digitcount := digitcount+1;
        ValueDigit := displayval mod 10;
        displayval := displayval div 10;
        WriteDigitOfValue (ValueDigit, scorexkoord, digitcount);
        scorexkoord := scorexkoord-digitwidth;
    until displayval = 0;
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 createblock;
BEGIN
    checkrowfull;
    blocktype := RANDOM(7)+1;
    blockorientation := 1;
    blockpositionx := 4;
    blockpositiony := -2;
    makeblock;
    checkifgameover;
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 CreateNewTopTenFile;
begin
    rewrite (TopTenFile);
    fillchar (TopTenRecord, 384, 0);
    blockwrite (TopTenFile, TopTenRecord, 3);
    seek (TopTenFile, 0);
end;

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 displaytext;
BEGIN
    (* SCORE *)
    plane0[5*240+195] := $FE00;
    plane0[6*240+195] := $FEFE;
    plane0[7*240+195] := $FEFE;
    plane0[5*240+196] := $8000;
    plane0[6*240+196] := $8280;
    plane0[7*240+196] := $8082;
    plane0[5*240+197] := $8000;
    plane0[6*240+197] := $8280;
    plane0[7*240+197] := $8082;
    plane0[5*240+198] := $8000;
    plane0[6*240+198] := $8280;
    plane0[7*240+198] := $8082;
    plane0[5*240+199] := $8000;
    plane0[6*240+199] := $8280;
    plane0[7*240+199] := $8082;
    plane0[5*240+200] := $FE00;
    plane0[6*240+200] := $8280;
    plane0[7*240+200] := $FEFE;
    plane0[5*240+201] := $0200;
    plane0[6*240+201] := $8280;
    plane0[7*240+201] := $80C0;
    plane0[5*240+202] := $0200;
    plane0[6*240+202] := $8280;
    plane0[7*240+202] := $80A0;
    plane0[5*240+203] := $0200;
    plane0[6*240+203] := $8280;
    plane0[7*240+203] := $8090;
    plane0[5*240+204] := $0200;
    plane0[6*240+204] := $8280;
    plane0[7*240+204] := $8088;
    plane0[5*240+205] := $FE00;
    plane0[6*240+205] := $FEFE;
    plane0[7*240+205] := $FE84;
    (* LEVEL *)
    plane0[14*240+195] := $8000;
    plane0[15*240+195] := $82FE;
    plane0[16*240+195] := $80FE;
    plane0[14*240+196] := $8000;
    plane0[15*240+196] := $8280;
    plane0[16*240+196] := $8080;
    plane0[14*240+197] := $8000;
    plane0[15*240+197] := $4480;
    plane0[16*240+197] := $8080;
    plane0[14*240+198] := $8000;
    plane0[15*240+198] := $4480;
    plane0[16*240+198] := $8080;
    plane0[14*240+199] := $8000;
    plane0[15*240+199] := $4480;
    plane0[16*240+199] := $8080;
    plane0[14*240+200] := $8000;
    plane0[15*240+200] := $28FE;
    plane0[16*240+200] := $80FE;
    plane0[14*240+201] := $8000;
    plane0[15*240+201] := $2880;
    plane0[16*240+201] := $8080;
    plane0[14*240+202] := $8000;
    plane0[15*240+202] := $2880;
    plane0[16*240+202] := $8080;
    plane0[14*240+203] := $8000;
    plane0[15*240+203] := $1080;
    plane0[16*240+203] := $8080;
    plane0[14*240+204] := $8000;
    plane0[15*240+204] := $1080;
    plane0[16*240+204] := $8080;
    plane0[14*240+205] := $FE00;
    plane0[15*240+205] := $10FE;
    plane0[16*240+205] := $FEFE;
    (* HEIGHT *)
    plane0[20*240+195] := $FE82;
    plane0[21*240+195] := $FEFE;
    plane0[22*240+195] := $FE82;
    plane0[20*240+196] := $8082;
    plane0[21*240+196] := $8010;
    plane0[22*240+196] := $1082;
    plane0[20*240+197] := $8082;
    plane0[21*240+197] := $8010;
    plane0[22*240+197] := $1082;
    plane0[20*240+198] := $8082;
    plane0[21*240+198] := $8010;
    plane0[22*240+198] := $1082;
    plane0[20*240+199] := $8082;
    plane0[21*240+199] := $8010;
    plane0[22*240+199] := $1082;
    plane0[20*240+200] := $FEFE;
    plane0[21*240+200] := $8E10;
    plane0[22*240+200] := $10FE;
    plane0[20*240+201] := $8082;
    plane0[21*240+201] := $8210;
    plane0[22*240+201] := $1082;
    plane0[20*240+202] := $8082;
    plane0[21*240+202] := $8210;
    plane0[22*240+202] := $1082;
    plane0[20*240+203] := $8082;
    plane0[21*240+203] := $8210;
    plane0[22*240+203] := $1082;
    plane0[20*240+204] := $8082;
    plane0[21*240+204] := $8210;
    plane0[22*240+204] := $1082;
    plane0[20*240+205] := $FE82;
    plane0[21*240+205] := $FEFE;
    plane0[22*240+205] := $1082;
    color (white);
    writerectangle (0, maxx, 195, 205, plane0);
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;

BEGIN
    initializedigits;
    REPEAT
        WRITE ('Level  ( 1 = easy    10 = tough ) : ');
        READLN (level);
    UNTIL (level > 0) AND (level < 11);
    REPEAT
        WRITE ('Height ( 0 = easy    15 = tough ) : ');
        READLN (Height);
    UNTIL (Height >= 0) AND (Height < 16);
    InitGraphic;
    initialize;
    displayvalue (0, 92, 0);
    displayvalue (level, 220, 0);
    level := 80*(10-level)+20;
    displayvalue (Height, 308, 1);
    displaytext;
    if Height > 0
    THEN filltoHeight;
    GraphicsOn;
    createblock;
    REPEAT
        newblock := FALSE;
        REPEAT
            displayblock;
            turnmoveblock;
        UNTIL newblock;
        createblock;
    UNTIL blocktype = 0;
    delay (3000);
    TopTen;
END.