path: root/tetris.pas

program TetrisGame;
uses crt, figure, tetree;

const
    StartingDuration = 800;
    FastDuration = 300;
    LeftArrow = -75;
    RightArrow = -77;
    UpArrow = -72;
    DownArrow = -80;
    esc = 27;
    WhiteSpace = 32;
    LimitTurns = 3;
    MaxPoints = 100000;
type
    GameStatus = record
        GoOut, pause: boolean;
        IsUserInput: boolean;
        TurnsCount: byte;
        fall: boolean;
        CurPoints: longword;
        IsWin: boolean
    end;

procedure GetKey(var code: integer);
var
    ch: char;
begin
    ch := ReadKey;
    if ch = #0 then
    begin
        ch := ReadKey;
        code := -ord(ch);
        exit
    end;
    code := ord(ch)
end;

procedure ClrBuf();
var
    ch: integer;
begin
    while KeyPressed do
        GetKey(ch)
end;

function CompareArrow(ChCode: integer): direction;
begin
    case ChCode of
        LeftArrow: CompareArrow := left;
        RightArrow: CompareArrow := right;
        UpArrow: CompareArrow := turning;
        DownArrow: CompareArrow := down
    end
end;

procedure SetUserDirection(var shape: ShapeList; var status: GameStatus);
var
    key: integer;
begin
    GetKey(key);
    case key of
        LeftArrow: begin
            if status.TurnsCount < LimitTurns then
            begin
                shape.CurDir := CompareArrow(key);
                status.TurnsCount := status.TurnsCount + 1;
                status.IsUserInput := true
            end
        end;
        RightArrow: begin
            if status.TurnsCount < LimitTurns then
            begin
                shape.CurDir := CompareArrow(key);
                status.TurnsCount := status.TurnsCount + 1;
                status.IsUserInput := true
            end
        end;
        UpArrow: begin
            if status.TurnsCount < LimitTurns then
            begin
                if not shape.IsSquare then
                begin
                    shape.CurDir := CompareArrow(key);
                    status.TurnsCount := status.TurnsCount + 1;
                    status.IsUserInput := true
                end
                else
                    shape.CurDir := down
            end
        end;
        DownArrow: begin
            if status.TurnsCount < LimitTurns then
            begin
                status.fall := true;
                shape.CurDir := down
            end
        end;
        esc: status.GoOut := true;
        WhiteSpace: status.pause := true
    end;
    {for press sequence}
    if KeyPressed then
    begin
        GetKey(key);
        case key of
            esc: status.GoOut := true;
            WhiteSpace: status.pause := true
        end
    end;
    ClrBuf
end;

procedure PrintTurnsCount(TurnsCount: byte);
begin
    GotoXY(36,14);
    TextColor(White);
    write('Movement counter: ', TurnsCount);
    if TurnsCount = LimitTurns then
    begin
        GotoXY(36, 15);
        write('LIMIT');
        GotoXY(1, 1);
    end
    else
    begin
        GotoXY(36, 15);
        write('           ');
        GotoXY(1, 1)
    end
end;

procedure NewTetramino(var shape, NextShape: ShapeList; CurBorders: borders;
                       var status: GameStatus);
begin
    if NextShape.first = nil then
    begin
        shape.first := nil;
        shape.last := nil;
        FigureInitial(shape, CurBorders)
    end
    else
        shape := NextShape;
    status.fall := false;
    shape.IsSquare := FindSquareShape(shape);
    shape.CanTurn := true;
    if FigureInVision(shape, CurBorders) then
        FindCenterFigure(shape);
    NextShape.first := nil;
    NextShape.last := nil;
    FigureInitial(NextShape, CurBorders);
    PrintPreviewShape(NextShape);
    PrintAndHideShape(shape, CurBorders, false, false);
    status.TurnsCount := 0;
    PrintTurnsCount(status.TurnsCount);
    delay(StartingDuration);
    if FigureInVision(shape, CurBorders) and KeyPressed then
    begin
        {PrintTurnsCount(status.TurnsCount);}
        SetUserDirection(shape, status);
        PrintTurnsCount(status.TurnsCount)
    end
end;

procedure MakePause(var status: GameStatus);
var
    key: integer;
begin
    GotoXY(36, 3);
    TextColor(White);
    write('PAUSE');
    GetKey(key);
    while true do
    begin
        case key of
            WhiteSpace: begin
                status.pause := false;
                GotoXY(36, 3);
                write('         ');
                GotoXY(1, 1);
                break
            end
            else
                GetKey(key)
        end
    end
end;

procedure GameIsOvers(status: GameStatus);
const
    WinMsg = 'YOU WIN';
    LoseMsg = 'YOU LOSE';
var
    MsgX, MsgY: integer;
begin
    clrscr;
    TextColor(White);
    MsgY := ScreenHeight div 2;
    if status.IsWin then
    begin
        MsgX := (ScreenWidth - Length(WinMsg)) div 2;
        GotoXY(MsgX, MsgY);
        write(WinMsg)
    end
    else
    begin
        MsgX := (ScreenWidth - Length(LoseMsg)) div 2;
        GotoXY(MsgX, MsgY);
        write(LoseMsg)
    end
end;

procedure PrintRules;
const
    RulesTotal = 11;
    MaxLength = 50;
    MaxLengthIdx = 10;
    ControlLines = 7;
type
    LinesType = array [1..RulesTotal] of string[MaxLength];
var
    lines: LinesType =
    (
        'Control keys:', 'moving left - <-', 'moving right - ->',
        'figure turn - ^', 'fall down - (down arrow)', 'pause - whitespace',
        'exit - esc', 'Scoring system:', '50 points for completing 1 row',
        'combo X2, X3 and X4 to the current points',
        'You need to score 100 000 points'
    );
    i, x, y: integer;
begin
    TextColor(White);
    x := ScreenWidth - length(lines[MaxLengthIdx]) + 1;
    y := 1;
    GotoXY(x, y);
    for i := 1 to ControlLines do
    begin
        write(lines[i]);
        y := y + 1;
        GotoXY(x, y)
    end;
    y := y + 1;
    GotoXY(x, y);
    for i := ControlLines + 1 to RulesTotal do
    begin
        write(lines[i]);
        y := y + 1;
        GotoXY(x, y)
    end
end;

procedure PrintPoints(DropCount: byte; status: GameStatus);
begin
    TextColor(White);
    GotoXY(36, 13);
    if DropCount = 1 then
        write('50 points')
    else
        write('COMBO X', DropCount);
    delay(FastDuration);
    GotoXY(36, 13);
    write('             ');
    GotoXY(36, 12);
    write('                      ');
    GotoXY(36, 12);
    write('Current points: ', status.CurPoints);
end;

procedure PreviewBorderDrawing;
const
    x = 36;
    y = 6;
    width = 8;
    height = 5;
var
    i, j: integer;
begin
    for i := y to y+height do
        for j := x to x+width do
        begin
            if ((j = x) or (j = x+width)) and (i >=  y + 1) and
                (i <= y + height - 1) then
            begin
                GotoXY(j, i);
                write('|')
            end
            else if (i = y) or (i = y+height) then
            begin
                GotoXY(j, i);
                write('-')
            end
        end
end;

procedure FieldDrawing(CurBorders: borders);
var
    i, j: integer;
begin
    for i := CurBorders.up to CurBorders.down do
        for j := CurBorders.left to CurBorders.right+1 do
            if (j = CurBorders.left) or
                (j = CurBorders.right+1) then
            begin
                GotoXY(j, i);
                write('|')
            end;
    GotoXY(CurBorders.left, CurBorders.down+1);
    for i := CurBorders.left to CurBorders.right+1 do
        write('-')
end;

procedure SetParamsGame(var status: GameStatus; var arr: WayFinding;
                        GoOut: boolean; CurBorders: borders);
begin
    status.GoOut := GoOut;
    if not GoOut then
    begin
        FieldDrawing(CurBorders);
        PreviewBorderDrawing;
        InitMassive(arr);
        GotoXY(36, 12);
        write('Current points: ', 0);
        PrintRules
    end;
    status.TurnsCount := 0;
    status.IsUserInput := false;
    status.fall := false;
    status.CurPoints := 0;
    status.IsWin := false;
end;

procedure ReloadGame(var arr: WayFinding; var status: GameStatus;
                     CurBorders: borders);
const
    Msg = 'Reload Game? Y/N';
var
    MsgX, MsgY: integer;
    ch, i: integer;
begin
    MsgX := (ScreenWidth - Length(Msg)) div 2;
    MsgY := (ScreenHeight div 2) + 1;
    GotoXY(MsgX, MsgY);
    TextColor(White);
    write(Msg);
    GetKey(ch);
    while true do
    begin
        case chr(ch) of
            'y', 'Y': begin
                clrscr;
                for i := 1 to MaxLine do
                    ClearSquaresAndTree(arr[i].root);
                SetParamsGame(status, arr, false, CurBorders)
            end;
            'n', 'N': begin
                clrscr;
                for i := 1 to MaxLine do
                    ClearSquaresAndTree(arr[i].root);
                SetParamsGame(status, arr, true, CurBorders)
            end
            else
            begin
                GetKey(ch);
                continue
            end;
        end;
        exit
    end
end;

procedure CheckFillLine(var arr: WayFinding; var shape: ShapeList;
                        CurBorders: borders; var status: GameStatus);
var
    PosFillLine: integer;
    DropCount: byte = 0;
begin
    PosFillLine := SearchFillViaShape(arr, shape);
    while PosFillLine <> 0 do
    begin
        DropLine(arr, PosFillLine, CurBorders);
        DropCount := DropCount + 1;
        if DropCount = 1 then
            status.CurPoints := status.CurPoints + 50
        else
            status.CurPoints := status.CurPoints * DropCount;
        PrintPoints(DropCount, status);
        if status.CurPoints >= MaxPoints then
        begin
            status.IsWin := true;
            GameIsOvers(status);
            ReloadGame(arr, status, CurBorders);
            exit
        end;
        PosFillLine := SearchOtherFill(arr, PosFillLine)
    end
end;

procedure StayAtBottom(var shape, ChangedShape, NextShape: ShapeList;
                       var arr: WayFinding; CurBorders: borders;
                       var status: GameStatus);
begin
    ClearShape(ChangedShape.first);
    ChangedShape.first := nil;
    ChangedShape.last := nil;
    PrintAndHideShape(shape, CurBorders, false, true);
    shape.cx := -1;
    shape.cy := -1;
    AddInTree(shape, arr);
    CheckFillLine(arr, shape, CurBorders, status);
    if status.GoOut then
        exit
    else
        NewTetramino(shape, NextShape, CurBorders, status)
end;

procedure SolveBorderProblem(var shape, ChangedShape: ShapeList;
                             CurBorders: borders; var status: GameStatus);
begin
    ClearShape(ChangedShape.first);
    ChangedShape.first := nil;
    ChangedShape.last := nil;
    if status.TurnsCount >= LimitTurns then
    begin
        {Print previous place}
        PrintAndHideShape(shape, CurBorders, false, false);
        delay(FastDuration);
        shape.CurDir := down;
        status.IsUserInput := false;
        status.TurnsCount := 0
    end
    else if status.TurnsCount < LimitTurns then
    begin
        PrintAndHideShape(shape, CurBorders, false, false);
        delay(FastDuration);
        if KeyPressed then
        begin
            SetUserDirection(shape, status);
            if status.pause then
            begin
                MakePause(status);
                delay(FastDuration);
                if KeyPressed then
                    SetUserDirection(shape, status)
                else
                begin
                    shape.CurDir := down;
                    status.IsUserInput := false;
                    status.TurnsCount := 0
                end
            end;
            PrintTurnsCount(status.TurnsCount)
        end
        else
        begin
        {default direction}
            shape.CurDir := down;
            status.IsUserInput := false;
            status.TurnsCount := 0
        end
    end
end;

procedure SolveTetraminoCollision(var shape, ChangedShape, NextShape: ShapeList;
                                  var arr: WayFinding; CurBorders: borders;
                                  var status: GameStatus);
begin
    ClearShape(ChangedShape.first);
    ChangedShape.first := nil;
    ChangedShape.last := nil;
    if IsHighestFigure(shape) then
    begin
        PrintAndHideShape(shape, CurBorders, false, true);
        GameIsOvers(status);
        ReloadGame(arr, status, CurBorders);
        if status.GoOut then
            exit
        else
            NewTetramino(shape, NextShape, CurBorders, status);
        exit
    end;
    if status.TurnsCount >= LimitTurns then
    begin
        PrintAndHideShape(shape, CurBorders, false, false);
        shape.CurDir := down;
        status.IsUserInput := false;
        status.TurnsCount := 0;
        delay(FastDuration)
    end
    {stop above some shape}
    else if shape.CurDir = down then
    begin
        PrintAndHideShape(shape, CurBorders, false, true);
        AddInTree(shape, arr);
        CheckFillLine(arr, shape, CurBorders, status);
        if status.GoOut then
            exit
        else
            NewTetramino(shape, NextShape, CurBorders, status)
    end
    else if status.TurnsCount < LimitTurns then
    begin
        PrintAndHideShape(shape, CurBorders, false, false);
        delay(FastDuration);
        if KeyPressed then
        begin
            SetUserDirection(shape, status);
            if status.pause then
            begin
                MakePause(status);
                delay(FastDuration);
                if KeyPressed then
                    SetUserDirection(shape, status)
                else
                begin
                    shape.CurDir := down;
                    status.IsUserInput := false;
                    status.TurnsCount := 0
                end
            end;
            PrintTurnsCount(status.TurnsCount)
        end
        else
        begin
        {default direction}
            shape.CurDir := down;
            status.IsUserInput := false;
            status.TurnsCount := 0
        end
    end
end;

procedure RepositionTetramino(var shape, ChangedShape: ShapeList;
                              CurBorders: borders; var status: GameStatus);
const
    FallDown = 50;
begin
    if not shape.CanTurn and (shape.CurDir = turning) and not status.fall then
    begin
        if status.TurnsCount >= LimitTurns then
            shape.CurDir := down;
        ClearShape(ChangedShape.first);
        ChangedShape.first := nil;
        ChangedShape.last := nil;
        {Print previous place}
        PrintAndHideShape(shape, CurBorders, false, false);
        delay(FastDuration);
        if KeyPressed and (status.TurnsCount < LimitTurns) then
        begin
            SetUserDirection(shape, status);
            if status.pause then
            begin
                MakePause(status);
                delay(FastDuration);
                if KeyPressed then
                    SetUserDirection(shape, status)
                else
                    shape.CurDir := down
            end;
            PrintTurnsCount(status.TurnsCount)
        end
        else if status.TurnsCount < LimitTurns then
            shape.CurDir := down;
        shape.CanTurn := true
    end
    else
    begin
        {Making Move or Turn}
        ClearShape(shape.first);
        {shape's center of figure has been got from ChangedShape}
        shape := ChangedShape;
        shape.CanTurn := true;
        ChangedShape.first := nil;
        ChangedShape.last := nil;
        if shape.CurDir = down then
        begin
            status.TurnsCount := 0;
            status.IsUserInput := false;
            PrintTurnsCount(status.TurnsCount)
        end;
        {Print previous place}
        PrintAndHideShape(shape, CurBorders, false, false);
        if status.fall then
            delay(FallDown)
        else if not status.IsUserInput then
            delay(StartingDuration)
        else if status.IsUserInput then
            delay(FastDuration);
        {select next direction from user}
        if not status.fall then
        begin
            if (status.TurnsCount < LimitTurns) and
                FigureInVision(shape, CurBorders) and KeyPressed then
            begin
                SetUserDirection(shape, status);
                if status.pause then
                begin
                    MakePause(status);
                    delay(FastDuration);
                    if KeyPressed then
                        SetUserDirection(shape, status)
                    else
                    begin
                        shape.CurDir := down;
                        status.IsUserInput := false;
                        status.TurnsCount := 0
                    end
                end;
                PrintTurnsCount(status.TurnsCount)
            end
            else if status.TurnsCount = LimitTurns then
            begin
                {only for pause or exit}
                if KeyPressed then
                    SetUserDirection(shape, status);
                if status.pause then
                begin
                    MakePause(status);
                    delay(FastDuration)
                end;
                shape.CurDir := down;
                status.IsUserInput := false;
                status.TurnsCount := 0;
                PrintTurnsCount(status.TurnsCount);
            end
            {default direction}
            else
                shape.CurDir := down
        end
    end
end;

function CheckResolutionDisplay: boolean;
const
    width = 101;
    height = 31;
    msg1 = 'Your display is smaller than required. Sorry!';
    msg2 = 'Please press any key...';
var
    x, y: integer;
begin
    if (ScreenWidth < width) or (ScreenHeight < height) then
    begin
        x := 1;
        y := ScreenHeight div 2;
        GotoXY(x ,y);
        write(msg1);
        GotoXY(x, y + 1);
        write(msg2);
        while true do
        begin
            if KeyPressed then
            begin
                ClrBuf;
                break
            end
        end;
        CheckResolutionDisplay := false;
        exit
    end;
    CheckResolutionDisplay := true
end;

var
    SaveTextAttr: integer;
    shape, ChangedShape, NextShape: ShapeList;
    CurBorders: borders;
    arr: WayFinding;
    IsObstacle: boolean;
    key: integer;
    status: GameStatus;
begin
    clrscr;
    if not CheckResolutionDisplay then
    begin
        writeln;
        halt(1)
    end;
    randomize;
    SaveTextAttr := TextAttr;
    SetBorders(CurBorders, 1, CupWidth, BeginCup, CupHeight);
    SetParamsGame(status, arr, false, CurBorders);
    NextShape.first := nil;
    NewTetramino(shape, NextShape, CurBorders, status);
    while true do
    begin
        PrintAndHideShape(shape, CurBorders, true, true);
        {expected movement}
        {IsObstacle's init in CheckBorders each time}
        CheckBorders(shape, ChangedShape, CurBorders, IsObstacle);
        if IsObstacle and (shape.CurDir = down) then
            StayAtBottom(shape, ChangedShape, NextShape, arr, CurBorders,
                         status)
        else if IsObstacle then
            SolveBorderProblem(shape, ChangedShape, CurBorders, status)
        else
        begin
            LineInspection(shape, ChangedShape, arr, IsObstacle);
            if IsObstacle then
                SolveTetraminoCollision(shape, ChangedShape, NextShape, arr,
                                        CurBorders, status)
            else
                RepositionTetramino(shape, ChangedShape, CurBorders, status)
        end;
        if KeyPressed then
        begin
            GetKey(key);
            case key of
                esc: break;
                WhiteSpace: continue
                else
                    ClrBuf
            end
        end
        else
        begin
            if status.GoOut then
                break;
            if status.pause then
                continue
        end
    end;
    TextAttr := SaveTextAttr;
    clrscr
end.