CGTRIS.PAS

{
 MIT License

Copyright (c) 2020 Viacheslav Komenda

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
}
{$I-,R-,S-,F-,Q-,G-,A+,E-,D-,L-}
{$M 1024,0,0}
procedure GraphMode;assembler;
asm
        mov        ax, 4
        int        $10
end;

procedure TextMode;assembler;
asm
        mov        ax, 3
        int        $10
end;

function GetKey:word;assembler;
asm
        xor        ax, ax
        int        $16
end;

function HasKey:boolean;assembler;
asm
        mov        ah, 1
        int        $16
        jnz        @has
        xor        al, al
        jmp        @end
@has:
        mov        al, 1
@end:
end;

procedure sound(hz : word); Assembler;
asm
        mov    bx, hz
        mov    ax, $34DD
        mov    dx, $0012
        cmp    dx, bx
        jnb    @j1
        div    bx
        mov    bx, ax
        IN     al, $61
        test   al, $03
        jnz    @j2
        or     al, $03
        out    $61, al
        mov    al, $B6
        out    $43, al
@j2:
        mov    al, bl
        out    $42, al
        mov    al, bh
        out    $42, al
@j1:
end;

procedure nosound; Assembler;
asm
        in     al, $61
        and    al, $FC
        out    $61, al
end;

procedure Draw(var buf; var spr);assembler;
asm
        PUSH  DS
        PUSH  ES
        PUSH  BP
        LES   DI, spr
        LDS   SI, buf
        MOV   DH, 25
        XOR   BX, BX
        MOV   BP,$B800
        CLD
@drawrow:
        PUSH  BX
        MOV   DL, 40
@drawcol:
        PUSH  DI
        PUSH  BX
        PUSH  DS
        LODSB
        XOR   AH, AH
        MOV   CL, 4
        SHL   AX, CL
        ADD   DI, AX
        MOV   DS, BP
        MOV   CL, 4
@drawchar:
        MOV   AX, ES:[DI]
        MOV   [BX], AX
        ADD   DI, 2
        MOV   AX, ES:[DI]
        MOV   [BX+$2000], AX
        ADD   DI, 2
        ADD   BX, 80
        DEC   CL
        JNZ   @drawchar
        POP   DS
        POP   BX
        POP   DI
        ADD   BX, 2
        DEC   DL
        JNZ   @drawcol
        POP   BX
        ADD   BX, 320
        DEC   DH
        JNZ   @drawrow
        POP   BP
        POP   ES
        POP   DS
end;

function Ticks:word;assembler;
asm
        push ds
        xor  ax, ax
        mov  ds, ax
        mov  ax, [$46C]
        pop  ds
end;

function TicksFrom(i : word):word;assembler;
asm
        push ds
        xor  ax, ax
        mov  ds, ax
        mov  ax, [$46C]
        pop  ds
        mov  bx, i
        cmp  ax, bx
        jge  @great
        neg  ax
        add  ax, bx
        jmp  @end
@great:
        sub ax, bx
@end:
end;

const
 spr : array [0..9, 0..15] of char = (
         (#00,#0,#0,#0,#0,#0,#0,#0,#0,#0,#0,#0,#0,#0,#0,#0)
         ,(#$FF,#$FF,#$ea,#$aa,#$ea,#$aa,#$ea,#$aa
           ,#$ea,#$aa,#$ea,#$aa,#$ea,#$aa,#$ea,#$aa)
         ,(#$FF,#$FF,#$D5,#$55,#$D5,#$55,#$D5,#$55,#$D5,#$55,#$D5,#$55,#$D5,#$55,#$D5,#$55)
         ,(#0,#0,#$3F,#$FF,#$3F,#$FF,#$3F,#$FF,#$3F,#$FF,#$3F,#$FF,#$3F,#$FF,#$3F,#$FF)
         ,(#00,#0,#0,#0,#1,#0,#0,#0,#0,#0,#0,#0,#0,#0,#0,#0)
         ,(#$03,#$30,#$03,#$30,#$03,#$30,#$03,#$30,#$03,#$30,#$03,#$30,#$03,#$30,#$03,#$30)
         ,(#$00,#$00,#$00,#$00,#$FF,#$FF,#$00,#$00,#$FF,#$FF,#$00,#$00,#$00,#$00,#$00,#$00)
         ,(#$03,#$30,#$03,#$30,#$03,#$3F,#$03,#$00,#$03,#$FF,#$00,#$00,#$00,#$00,#$00,#$00)
         ,(#$03,#$30,#$03,#$30,#$FF,#$30,#$00,#$30,#$FF,#$F0,#$00,#$00,#$00,#$00,#$00,#$00)
         ,(#$FF,#$FF,#$FF,#$FF,#$FF,#$FF,#$FF,#$FF,#$FF,#$FF,#$FF,#$FF,#$FF,#$FF,#$FF,#$FF)
         );
 figures : array[0..7] of string[12] = (
         '  *  ***    ',
         ' ***  *     ',
         '****        ',
         ' **   **    ',
         '**   **     ',
         '**  **      ',
         '    ***   * ',
         '  * ***     '
         );

CH_VL    = #5;
CH_HL    = #6;
CH_LC    = #7;
CH_RC    = #8;
CH_DOT   = #4;
CH_EMPTY = #0;
CH_RB    = #1;
CH_GB    = #2;
CH_FULL  = #9;

var
        screen       : array [0..24, 0..39] of char;
        field        : array [0..19, 0..9] of char;
        figure_field : array[0..3, 0..3] of char;
        fig_i, fig_n : integer;
        fig_x, fig_y : integer;
        fig_a        : integer;
        fig_w, fig_h : integer;
        pause        : integer;
        lines        : integer;
        muted        : boolean;

function is_fig_line_empty(line : integer):boolean;
var x : integer;
begin
        for x := 0 to 3 do if figure_field[line, x] <> CH_EMPTY then begin is_fig_line_empty := false; exit; end;
        is_fig_line_empty := true;
end;

function is_fig_col_empty(col : integer):boolean;
var y : integer;
begin
        for y := 0 to 3 do if figure_field[y, col] <> CH_EMPTY then begin is_fig_col_empty := false; exit; end;
        is_fig_col_empty := true;
end;

procedure LoadFigure;
var figure : string[12];
    x, y   : integer;
begin
        fillchar(figure_field, 16, CH_EMPTY);
        figure := figures[fig_i];
        if fig_a = 0 then begin
                for y := 0 to 2 do for x := 0 to 3 do begin
                        if figure[1 + y * 4 + x] <> ' ' then figure_field[y, x] := CH_RB;
                end;
        end else if fig_a = 1 then begin
                for y := 0 to 2 do for x := 0 to 3 do begin
                        if figure[1 + y * 4 + x] <> ' ' then figure_field[3 - x, y] := CH_RB;
                end;
        end else if fig_a = 2 then begin
                for y := 0 to 2 do for x := 0 to 3 do begin
                        if figure[1 + y * 4 + x] <> ' ' then figure_field[3 - y, 3 - x] := CH_RB;
                end;
        end else if fig_a = 3 then begin
                for y := 0 to 2 do for x := 0 to 3 do begin
                        if figure[1 + y * 4 + x] <> ' ' then figure_field[x, 3 - y] := CH_RB;
                end;
        end;

        while is_fig_line_empty(0) do begin
                for y := 1 to 3 do move(figure_field[y, 0], figure_field[y - 1, 0], 4);
                fillchar(figure_field[3, 0], 4, CH_EMPTY);
        end;
        while is_fig_col_empty(0) do begin
                for y := 0 to 3 do move(figure_field[y, 1], figure_field[y, 0], 4);
                for y := 0 to 3 do figure_field[y, 3] := CH_EMPTY;
        end;
        fig_w := 4;
        while (fig_w > 0) and (is_fig_col_empty(fig_w - 1)) do fig_w := fig_w - 1;
        fig_h := 4;
        while (fig_h > 0) and (is_fig_line_empty(fig_h - 1)) do fig_h := fig_h - 1;
        if fig_w + fig_x > 10 then fig_x := 10 - fig_w;
end;

procedure ReDraw;
var figure : string[12];
    x, y   : integer;
    c      : char;
begin
        fillchar(screen, 25 * 40, CH_EMPTY);
        for y := 1 to 21 do begin
                screen[y, 15] := CH_VL;
                screen[y, 26] := CH_VL;
        end;
        fillchar(screen[21, 15], 12, CH_HL);
        screen[21, 15] := CH_LC;
        screen[21, 26] := CH_RC;
        for y := 0 to 19 do for x := 0 to 9 do begin
                fillchar(screen[y + 1, 16], 10, CH_DOT);
                for x := 0 to 9 do begin
                        c := field[y, x];
                        if c <> CH_EMPTY then screen[y + 1, x + 16] := c;
                end;
        end;
        for y := 0 to 3 do
                for x := 0 to 3 do begin
                        c := figure_field[y, x];
                        if c <> CH_EMPTY then screen[1 + fig_y + y, 16 + fig_x + x] := c;
                end;
        figure := figures[fig_n];
        for y := 0 to 2 do
                for x := 0 to 3 do
                        if figure[y * 4 + x + 1] <> ' ' then screen[y + 1, x + 29] := CH_GB;
        Draw(screen, spr);
end;

function Can_move_left : boolean;
var x, y : integer;
begin
        if fig_x = 0 then begin Can_move_left := false; exit; end;
        for y := 0 to 3 do
                for x := 0 to 3 do
                        if (figure_field[y, x] <> CH_EMPTY)
                                and (field[fig_y + y, fig_x + x - 1] <> CH_EMPTY) then begin
                                Can_move_left := false;
                                exit;
                        end;
        Can_move_left := true;
end;

function Can_move_right : boolean;
var x, y : integer;
begin
        if fig_x + fig_w >= 10 then begin Can_move_right := false; exit; end;
        for y := 0 to 3 do
                for x := 0 to 3 do
                        if (figure_field[y, x] <> CH_EMPTY)
                                and (field[fig_y + y, fig_x + x + 1] <> CH_EMPTY) then begin
                                Can_move_right := false;
                                exit;
                        end;
        Can_move_right := true;
end;

function Can_do_step_down : boolean;
var x, y : integer;
begin
        for y := 0 to 3 do
                for x := 0 to 3 do
                        if (figure_field[y, x] <> CH_EMPTY)
                                and (field[fig_y + y + 1, fig_x + x] <> CH_EMPTY) then begin
                                Can_do_step_down := false;
                                exit;
                        end;
        Can_do_step_down := true;
end;

procedure Figure_Merge;
var x, y : integer;
begin
        for y := 0 to 3 do
                for x := 0 to 3 do if figure_field[y, x] <> CH_EMPTY then field[fig_y + y, fig_x + x] := CH_GB;
end;

procedure Remove_Rows;
var x, y   : integer;
    candel : boolean;
    time   : integer;
begin
        y := 19;
        while y > 0 do begin
                candel := true;
                for x := 0 to 9 do if field[y, x] = CH_EMPTY then candel := false;
                if candel then begin
                        Fillchar(field[y, 0], 10, CH_FULL);
                        ReDraw;
                        if not muted then sound(100);
                        time := Ticks;
                        while TicksFrom(time) < 4 do ;
                        move(field, field[1, 0], (y) * 10);
                        fillchar(field, 10, CH_EMPTY);
                        lines := lines + 1;
                        if (lines mod 20) = 19 then pause := pause - 1;
                        if not muted then nosound;
                end else y := y - 1;
        end;
end;

procedure Next_Figure;
var time : integer;
begin
        if not muted then sound(60);
        time := Ticks;
        fig_a := 0;
        fig_x := 4;
        fig_y := 0;
        fig_i := fig_n;
        fig_n := random(8);
        while TicksFrom(time) < 1 do ;
        LoadFigure;
        if not muted then nosound;
end;

function Figure_is_down:boolean;
begin
        Figure_is_down := (fig_y + fig_h - 1) = 19;
end;

procedure Game;
var key         : integer;
    key_scan    : integer;
    need_redraw : boolean;
    time        : integer;
    steps       : integer;
    fall        : boolean;
begin
        fillchar(field, 20 * 10, CH_EMPTY);
        muted := false;
        fig_n := random(8);
        Next_Figure;
        lines := 0;
        pause := 7;
        need_redraw := true;
        time := Ticks;
        steps := 0;
        fall := false;
        while true do begin
                if need_redraw then begin
                        ReDraw;
                        need_redraw := false;
                end;
                if HasKey then begin
                        key := GetKey;
                        key_scan := hi(key);
                        if key_scan = 1 then exit
                        else if (key_scan = $4b) and Can_move_left then begin
                                fig_x := fig_x - 1;
                                need_redraw := true;
                        end else if (key_scan = $4d) and Can_move_right then begin
                                fig_x := fig_x + 1;
                                need_redraw := true;
                        end else if key_scan = $48 then begin
                                fig_a := (fig_a + 1) and 3;
                                LoadFigure;
                                need_redraw := true;
                        end else if key_scan = $50 then begin
                                fig_a := (fig_a - 1) and 3;
                                LoadFigure;
                                need_redraw := true;
                        end else if key_scan = $19 then begin
                                key := GetKey;
                        end else if key_scan = $39 then begin
                                fall := true;
                        end else if key_scan = $32 then begin
                                muted := not muted;
                        end;
                end else if (not Can_do_step_down)
                        or Figure_is_down then begin
                        if steps = 0 then exit;
                        Figure_Merge;
                        Next_Figure;
                        Remove_Rows;
                        steps := 0;
                        fall := false;
                        need_redraw := true;
                end else if fall then begin
                        if not muted then sound(80);
                        fig_y := fig_y + 1;
                        need_redraw := true;
                        time := Ticks;
                        steps := steps + 1;
                        if not muted then Nosound;
                end else if TicksFrom(time) > pause then begin
                        if not muted then sound(80);
                        fig_y := fig_y + 1;
                        need_redraw := true;
                        time := Ticks;
                        steps := steps + 1;
                        if not muted then Nosound;
                end;
        end;
end;

procedure WaitKey;
var key : integer;
begin
        while HasKey do key := GetKey;
        key := GetKey;
end;

begin
        Randomize;
        GraphMode;
        Game;
        WaitKey;
        TextMode;
end.