back to scratko.xyz
aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--figure.pp1135
-rw-r--r--tetree.pp358
-rw-r--r--tetris.pas725
3 files changed, 2218 insertions, 0 deletions
diff --git a/figure.pp b/figure.pp
new file mode 100644
index 0000000..dd88668
--- /dev/null
+++ b/figure.pp
@@ -0,0 +1,1135 @@
+unit figure;
+interface
+
+const
+ CupWidth = 31;
+ CupHeight = 30;
+ BeginCup = 1;
+ WidthSquare = 3;
+ HeightSquare = 2;
+type
+ direction = (left, right, up, down, turning, center);
+ borders = record
+ left, right,
+ up, down: integer
+ end;
+ SquareItemPtr = ^SquareItem;
+ SquareItem = record
+ x: integer;
+ y: integer;
+ next: SquareItemPtr;
+ {for define center of figure}
+ CurDir: direction;
+ color: word;
+ end;
+ ShapeList = record
+ first: SquareItemPtr;
+ last: SquareItemPtr;
+ {for define moving of figure}
+ CurDir: direction;
+ cx, cy: integer;
+ IsSquare: boolean;
+ CanTurn: boolean;
+ end;
+ ExpectedPlace = record
+ FromX: integer;
+ FromY: integer;
+ CurSide: direction;
+ end;
+ TempSquareItemPtr = ^TempSquareItem;
+ TempSquareItem = record
+ OldX: integer;
+ OldY: integer;
+ ActualSquare: SquareItemPtr;
+ next: TempSquareItemPtr;
+ end;
+ ProcValuesType = record
+ first: TempSquareItemPtr;
+ last: TempSquareItemPtr;
+ end;
+ EdgeType = record
+ x, y: integer;
+ end;
+
+function IsHighestFigure(shape: ShapeList): boolean;
+function FigureInVision(shape: ShapeList; CurBorders: borders): boolean;
+function FindSquareShape(shape: ShapeList): boolean;
+function IsAboveTop(square: SquareItemPtr; CurBorders: borders): boolean;
+procedure SetBorders(var CurBorders: borders; left, right, up, down: integer);
+procedure CreateSquare(var shape: ShapeList; color: word);
+procedure PrintAndHideShape(shape: ShapeList; CurBorders: borders;
+ HideShape, HideCenter: boolean);
+procedure CheckBorders(var shape, ChangedShape: ShapeList; CurBorders: borders;
+ var IsObstacle: boolean);
+procedure FigureInitial(var shape: ShapeList; CurBorders: borders);
+procedure CalculateNewXY(shape: ShapeList; var ChangedShape: ShapeList);
+procedure FindCenterFigure(var shape: ShapeList);
+procedure ComputeTurn(var ChangedShape: ShapeList);
+procedure ClearShape(var square: SquareItemPtr);
+procedure InitEdges(var LeftEdge, RightEdge, UpEdge, DownEdge: EdgeType;
+ shape: ShapeList);
+procedure PrintPreviewShape(NextShape: ShapeList);
+
+implementation
+uses crt;
+
+const
+ MaxSquaresFromCenter = 3;
+type
+ MadeTurn = record
+ x: integer;
+ y: integer;
+ end;
+ ArrTurn = array [1..MaxSquaresFromCenter] of MadeTurn;
+ AllTurnsType = record
+ left, right: ArrTurn;
+ up, down: ArrTurn;
+ end;
+ TypeSort = (increase, decrease);
+
+function FindSquareShape(shape: ShapeList): boolean;
+const
+ SquareSide = 2;
+ UpperBorder = -1;
+type
+ SidesType = record
+ x1, x2: integer;
+ CountX1, CountX2: integer;
+ end;
+var
+ sides: SidesType;
+ square: SquareItemPtr;
+begin
+ square := shape.first;
+ sides.x1 := square^.x;
+ sides.CountX1 := 1;
+ sides.x2 := 0;
+ sides.CountX2 := 0;
+ square := square^.next;
+ while square <> nil do
+ begin
+ if square^.y >= UpperBorder then
+ begin
+ if (square^.x = sides.x1) then
+ sides.CountX1 := sides.CountX1 + 1
+ else if (square^.x = sides.x2) then
+ sides.CountX2 := sides.CountX2 + 1
+ else if sides.x2 = 0 then
+ begin
+ sides.CountX2 := 1;
+ sides.x2 := square^.x
+ end
+ end;
+ square := square^.next
+ end;
+ FindSquareShape := (sides.CountX1 = SquareSide) and
+ (sides.CountX2 = SquareSide)
+end;
+
+function IsHighestFigure(shape: ShapeList): boolean;
+var
+ square: SquareItemPtr;
+begin
+ square := shape.first;
+ while square <> nil do
+ begin
+ if square^.y < 1 then
+ begin
+ IsHighestFigure := true;
+ exit
+ end;
+ square := square^.next
+ end;
+ IsHighestFigure := false
+end;
+
+procedure SetBorders(var CurBorders: borders; left, right, up, down: integer);
+begin
+ CurBorders.left := left;
+ CurBorders.right := right;
+ CurBorders.up := up;
+ CurBorders.down := down
+end;
+
+function IsPlaceTaken(x, y: integer; shape: ShapeList): boolean;
+var
+ square: SquareItemPtr;
+begin
+ square := shape.first;
+ while square <> nil do
+ begin
+ if (square^.x = x) and (square^.y = y) then
+ begin
+ IsPlaceTaken := true;
+ exit
+ end
+ else
+ square := square^.next
+ end;
+ IsPlaceTaken := false
+end;
+
+function CorrectPos(place: ExpectedPlace; shape: ShapeList) : boolean;
+var
+ CurX, CurY: integer;
+begin
+ CurX := place.FromX;
+ CurY := place.FromY;
+ case place.CurSide of
+ left: CorrectPos := not IsPlaceTaken(CurX - WidthSquare, CurY, shape);
+ right: CorrectPos := not IsPlaceTaken(CurX + WidthSquare, CurY, shape);
+ up: CorrectPos := not IsPlaceTaken(CurX, CurY - HeightSquare, shape);
+ down: CorrectPos := not IsPlaceTaken(CurX, CurY + HeightSquare, shape)
+ end
+end;
+
+procedure SetLastSquare(var shape: ShapeList; x, y: integer; CurDir: direction);
+begin
+ shape.last^.x := x;
+ shape.last^.y := y;
+ shape.last^.CurDir := CurDir
+end;
+
+procedure SelectPos(var shape: ShapeList; TotalSquares: integer);
+const
+ sides = 4;
+var
+ place: ExpectedPlace;
+ tmp: SquareItemPtr;
+ IdxSquare, i: integer;
+begin
+ tmp := shape.first;
+ IdxSquare := random(TotalSquares);
+ for i:= 1 to IdxSquare do
+ tmp := tmp^.next;
+ place.FromX := tmp^.x;
+ place.FromY := tmp^.y;
+ place.CurSide := direction(random(sides));
+ while not CorrectPos(place, shape) or
+ ((place.CurSide = down) and ((place.FromY + HeightSquare) > 1)) do
+ place.CurSide := direction(random(sides));
+ case place.CurSide of
+ left: SetLastSquare(shape, place.FromX - WidthSquare, place.FromY,
+ left);
+ right: SetLastSquare(shape, place.FromX + WidthSquare, place.FromY,
+ right);
+ up: SetLastSquare(shape, place.FromX, place.FromY - HeightSquare,
+ up);
+ down: SetLastSquare(shape, place.FromX, place.FromY + HeightSquare,
+ down)
+ end;
+end;
+
+procedure ClearShape(var square: SquareItemPtr);
+begin
+ if square = nil then
+ exit;
+ ClearShape(square^.next);
+ dispose(square)
+end;
+
+procedure CreateLineShape(var shape: ShapeList; color: word);
+var
+ x, y: integer;
+begin
+ if shape.first = nil then
+ begin
+ new(shape.first);
+ shape.last := shape.first
+ end
+ else
+ begin
+ x := shape.last^.x;
+ y := shape.last^.y - HeightSquare;
+ new(shape.last^.next);
+ shape.last := shape.last^.next;
+ shape.last^.x := x;
+ shape.last^.y := y;
+ shape.last^.CurDir := up;
+ end;
+ shape.last^.next := nil;
+ shape.last^.color := color
+end;
+
+procedure CreateSquare(var shape: ShapeList; color: word);
+begin
+ if shape.first = nil then
+ begin
+ new(shape.first);
+ shape.last := shape.first
+ end
+ else
+ begin
+ new(shape.last^.next);
+ shape.last := shape.last^.next
+ end;
+ shape.last^.next := nil;
+ shape.last^.color := color
+end;
+
+function IsOnBorders(ChangedShape: ShapeList; CurBorders: borders): boolean;
+var
+ square: SquareItemPtr;
+begin
+ square := ChangedShape.first;
+ while square <> nil do
+ begin
+ if (square^.x < CurBorders.left) or
+ (square^.x + WidthSquare - 1 > CurBorders.right) or
+ (square^.y + HeightSquare - 1 > CurBorders.down) then
+ begin
+ IsOnBorders := true;
+ exit
+ end;
+ square := square^.next
+ end;
+ IsOnBorders := false
+end;
+
+function IsAboveTop(square: SquareItemPtr; CurBorders: borders): boolean;
+begin
+ IsAboveTop := square^.y < CurBorders.up
+end;
+
+function FigureInVision(shape: ShapeList; CurBorders: borders): boolean;
+var
+ square: SquareItemPtr;
+begin
+ square := shape.first;
+ while square <> nil do
+ begin
+ if IsAboveTop(square, CurBorders) then
+ begin
+ FigureInVision := false;
+ exit
+ end;
+ square := square^.next
+ end;
+ FigureInVision := true
+end;
+
+procedure ClearPreview;
+const
+ PrX = 37;
+ PrY = 7;
+ MaxHeight = 4;
+ MaxWidth = 7;
+var
+ i, j: integer;
+begin
+ for i := 0 to MaxHeight-1 do
+ begin
+ for j := 0 to MaxWidth-1 do
+ begin
+ GotoXY(PrX+j, PrY+i);
+ write(' ')
+ end;
+ writeln
+ end
+end;
+
+procedure PrintPreviewShape(NextShape: ShapeList);
+const
+ PrX = 40;
+ PrY = 10;
+type
+ FindOutPos = record
+ square: SquareItemPtr;
+ px, py: integer;
+ end;
+var
+ PosArr: array [1..4] of FindOutPos;
+ square: SquareItemPtr;
+ i, j: integer;
+ dx, dy: integer;
+begin
+ ClearPreview;
+ i := 1;
+ square := NextShape.first;
+ PosArr[i].square := square;
+ PosArr[i].px := PrX;
+ PosArr[i].py := PrY;
+ GotoXY(PosArr[i].px, PosArr[i].py);
+ TextColor(NextShape.first^.color);
+ write('*');
+ square := square^.next;
+ while square <> nil do
+ begin
+ i := i + 1;
+ PosArr[i].square := square;
+ case square^.CurDir of
+ left: begin
+ dx := WidthSquare;
+ dy := 0
+ end;
+ right: begin
+ dx := -WidthSquare;
+ dy := 0
+ end;
+ up: begin
+ dx := 0;
+ dy := HeightSquare
+ end;
+ down: begin
+ dx := 0;
+ dy := -HeightSquare
+ end
+ end;
+ for j := i-1 downto 1 do
+ begin
+ if (PosArr[j].square^.x = square^.x + dx) and
+ (PosArr[j].square^.y = square^.y + dy) then
+ begin
+ case square^.CurDir of
+ left: begin
+ PosArr[i].px := PosArr[j].px - 1;
+ PosArr[i].py := PosArr[j].py
+ end;
+ right: begin
+ PosArr[i].px := PosArr[j].px + 1;
+ PosArr[i].py := PosArr[j].py
+ end;
+ up: begin
+ PosArr[i].px := PosArr[j].px;
+ PosArr[i].py := PosArr[j].py - 1
+ end;
+ down: begin
+ PosArr[i].px := PosArr[j].px;
+ PosArr[i].py := PosArr[j].py + 1
+ end
+ else
+ continue
+ end
+ end
+ else
+ continue;
+ GotoXY(PosArr[i].px, PosArr[i].py);
+ write('*')
+ end;
+ square := square^.next
+ end
+end;
+
+procedure PrintAndHideShape(shape: ShapeList; CurBorders: borders;
+ HideShape, HideCenter: boolean);
+var
+ square: SquareItemPtr;
+ i, j: integer;
+ IsCenter: boolean = false;
+begin
+ square := shape.first;
+ while square <> nil do
+ begin
+ for i := 0 to HeightSquare-1 do
+ begin
+ for j := 0 to WidthSquare-1 do
+ begin
+ if not IsAboveTop(square, CurBorders) then
+ begin
+ if not shape.IsSquare and (square^.x+j = shape.cx)
+ and (square^.y+i = shape.cy) and not HideShape and
+ not HideCenter then
+ IsCenter := true;
+ if IsCenter then
+ TextColor(Red)
+ else if not HideShape then
+ TextColor(square^.color);
+ GotoXY(square^.x+j, square^.y+i);
+ if not HideShape then
+ write('*')
+ else
+ write(' ')
+ end
+ end;
+ writeln
+ end;
+ IsCenter := false;
+ square := square^.next
+ end;
+ GotoXY(1, 1)
+end;
+
+procedure FindCenterFigure(var shape: ShapeList);
+var
+ square: SquareItemPtr;
+ TempSquare: SquareItemPtr;
+begin
+ {square shape don't have any center}
+ if shape.IsSquare then
+ exit;
+ {centers were initialized}
+ if (shape.cx <> - 1) and (shape.cy <> -1) then
+ exit;
+ shape.cx := shape.first^.x;
+ shape.cy := shape.first^.y;
+ square := shape.first;
+ while square <> nil do
+ begin
+ TempSquare := shape.first;
+ while TempSquare <> nil do
+ begin
+ if (square <> TempSquare) and
+ (square^.CurDir = TempSquare^.CurDir) then
+ begin
+ shape.cx := square^.x;
+ shape.cy := square^.y;
+ exit
+ end;
+ TempSquare := TempSquare^.next;
+ end;
+ square := square^.next;
+ end
+end;
+
+procedure InitEdges(var LeftEdge, RightEdge, UpEdge, DownEdge: EdgeType;
+ shape: ShapeList);
+var
+ square: SquareItemPtr;
+begin
+ LeftEdge.x := 0;
+ LeftEdge.y := 0;
+ RightEdge.x := 0;
+ RightEdge.y := 0;
+ UpEdge.x := 0;
+ UpEdge.y := 0;
+ DownEdge.x := 0;
+ DownEdge.y := 0;
+ square := shape.first;
+ while square <> nil do
+ begin
+ {left}
+ if square^.x < shape.cx then
+ begin
+ if LeftEdge.x = 0 then
+ begin
+ LeftEdge.x := square^.x;
+ LeftEdge.y := square^.y
+ end
+ else if square^.x < LeftEdge.x then
+ begin
+ LeftEdge.x := square^.x;
+ LeftEdge.y := square^.y
+ end
+ else if (square^.x = LeftEdge.x) and (square^.y < LeftEdge.y) then
+ begin
+ LeftEdge.x := square^.x;
+ LeftEdge.y := square^.y
+ end
+ end;
+ {right}
+ if square^.x > shape.cx then
+ begin
+ if RightEdge.x = 0 then
+ begin
+ RightEdge.x := square^.x;
+ RightEdge.y := square^.y
+ end
+ else if square^.x > RightEdge.x then
+ begin
+ RightEdge.x := square^.x;
+ RightEdge.y := square^.y
+ end
+ else if (square^.x = RightEdge.x) and (square^.y > RightEdge.y) then
+ begin
+ RightEdge.x := square^.x;
+ RightEdge.y := square^.y
+ end
+ end;
+ {up}
+ if square^.y < shape.cy then
+ begin
+ if UpEdge.y = 0 then
+ begin
+ UpEdge.x := square^.x;
+ UpEdge.y := square^.y
+ end
+ else if square^.y < UpEdge.y then
+ begin
+ UpEdge.x := square^.x;
+ UpEdge.y := square^.y
+ end
+ else if (square^.y = UpEdge.y) and (square^.x > UpEdge.x) then
+ begin
+ UpEdge.x := square^.x;
+ UpEdge.y := square^.y
+ end
+ end;
+ {down}
+ if square^.y > shape.cy then
+ begin
+ if DownEdge.y = 0 then
+ begin
+ DownEdge.x := square^.x;
+ DownEdge.y := square^.y
+ end
+ else if square^.y > DownEdge.y then
+ begin
+ DownEdge.x := square^.x;
+ DownEdge.y := square^.y
+ end
+ else if (square^.y = DownEdge.y) and (square^.x < DownEdge.x) then
+ begin
+ UpEdge.x := square^.x;
+ UpEdge.y := square^.y
+ end
+ end;
+ square := square^.next
+ end
+end;
+
+procedure CopyShape(shape: ShapeList; var ChangedShape: ShapeList);
+var
+ square: SquareItemPtr;
+begin
+ square := shape.first;
+ while square <> nil do
+ begin
+ CreateSquare(ChangedShape, Black);
+ ChangedShape.last^.x := square^.x;
+ ChangedShape.last^.y := square^.y;
+ ChangedShape.last^.CurDir := square^.CurDir;
+ ChangedShape.last^.color := square^.color;
+ square := square^.next
+ end;
+ ChangedShape.CurDir := shape.CurDir;
+ ChangedShape.IsSquare := shape.IsSquare;
+ ChangedShape.cx := shape.cx;
+ ChangedShape.cy := shape.cy
+end;
+
+procedure CalculateNewXY(shape: ShapeList; var ChangedShape: ShapeList);
+var
+ dx, dy: integer;
+ square: SquareItemPtr;
+begin
+ case shape.CurDir of
+ left: begin
+ dx := -WidthSquare;
+ dy := 0
+ end;
+ right: begin
+ dx := WidthSquare;
+ dy := 0
+ end;
+ down: begin
+ dx := 0;
+ dy := HeightSquare
+ end
+ end;
+ square := ChangedShape.first;
+ while square <> nil do
+ begin
+ square^.x := square^.x + dx;
+ square^.y := square^.y + dy;
+ square := square^.next
+ end;
+ ChangedShape.cx := ChangedShape.cx + dx;
+ ChangedShape.cy := ChangedShape.cy + dy
+end;
+
+procedure swap(var first, second: MadeTurn);
+var
+ temp: MadeTurn;
+begin
+ temp := first;
+ first := second;
+ second := temp
+end;
+
+procedure SortArr(var CurArr: ArrTurn; SortWay: TypeSort; CurDir: direction);
+const
+ n = 2;
+var
+ i, j: integer;
+begin
+ if SortWay = increase then
+ begin
+ for i := 0 to n - 1 do
+ for j := 0 to n - 1 - i do
+ begin
+ if CurDir = right then
+ begin
+ if CurArr[j+1].x > CurArr[j+2].x then
+ swap(CurArr[j+1], CurArr[j+2])
+ end
+ else if CurDir = down then
+ if CurArr[j+1].x > CurArr[j+2].x then
+ swap(CurArr[j+1], CurArr[j+2])
+ end
+ end
+ else
+ for i := 0 to n - 1 do
+ for j := 0 to n - 1 - i do
+ begin
+ if CurDir = left then
+ begin
+ if CurArr[j+1].x < CurArr[j+2].x then
+ swap(CurArr[j+1], CurArr[j+2])
+ end
+ else if CurDir = up then
+ if CurArr[j+1].y < CurArr[j+2].y then
+ swap(CurArr[j+1], CurArr[j+2])
+ end
+end;
+
+function FindSquare(ProcValues: ProcValuesType; x, y: integer)
+ : SquareItemPtr;
+var
+ TempSquare: TempSquareItemPtr;
+begin
+ TempSquare := ProcValues.first;
+ while TempSquare <> nil do
+ begin
+ if (TempSquare^.OldX = x) and (TempSquare^.OldY = y) then
+ begin
+ FindSquare := TempSquare^.ActualSquare;
+ exit
+ end;
+ TempSquare := TempSquare^.next
+ end;
+ FindSquare := nil
+end;
+
+{for searching old values which not containing completed offset}
+procedure AddProcValue(var ProcValues: ProcValuesType; OldX, OldY: integer;
+ square: SquareItemPtr);
+begin
+ if ProcValues.first = nil then
+ begin
+ new(ProcValues.first);
+ ProcValues.last := ProcValues.first
+ end
+ else
+ begin
+ new(ProcValues.last^.next);
+ ProcValues.last := ProcValues.last^.next
+ end;
+ ProcValues.last^.next := nil;
+ ProcValues.last^.OldX := OldX;
+ ProcValues.last^.OldY := OldY;
+ ProcValues.last^.ActualSquare := square
+end;
+
+procedure MakeOffset(CurXY: MadeTurn; var pos: SquareItemPtr;
+ CurDir: direction; var TotalOffset: integer;
+ var RememberValue: integer; var ProcValues: ProcValuesType);
+var
+ FoundPos: SquareItemPtr;
+ IsSequence: boolean = false;
+ offset: integer;
+begin
+ case CurDir of
+ left: begin
+ if CurXY.y = RememberValue then
+ begin
+ TotalOffset := TotalOffset + 1;
+ IsSequence := true
+ end;
+ if IsSequence then
+ offset := TotalOffset
+ else
+ offset := 1;
+ FoundPos := FindSquare(ProcValues, CurXY.x, CurXY.y);
+ if FoundPos <> nil then
+ begin
+ FoundPos^.x := FoundPos^.x - offset;
+ {$IFDEF DEBUG}
+ write('left ', FoundPos^.x, ' ', FoundPos^.y, ' ');
+ {$ENDIF}
+ end
+ else
+ begin
+ pos^.x := CurXY.x - offset;
+ pos^.y := CurXY.y;
+ {$IFDEF DEBUG}
+ write('left ', pos^.x, ' ', pos^.y, ' ');
+ {$ENDIF}
+ AddProcValue(ProcValues, CurXY.x, CurXY.y, pos);
+ pos := pos^.next
+ end
+ end;
+ right: begin
+ if CurXY.y = RememberValue then
+ begin
+ TotalOffset := TotalOffset + 1;
+ IsSequence := true
+ end;
+ if IsSequence then
+ offset := TotalOffset
+ else
+ offset := 1;
+ FoundPos := FindSquare(ProcValues, CurXY.x, CurXY.y);
+ if FoundPos <> nil then
+ begin
+ FoundPos^.x := FoundPos^.x + offset;
+ {$IFDEF DEBUG}
+ write('right ', FoundPos^.x, ' ', FoundPos^.y, ' ');
+ {$ENDIF}
+ end
+ else
+ begin
+ pos^.x := CurXY.x + offset;
+ pos^.y := CurXY.y;
+ {$IFDEF DEBUG}
+ write('right ', pos^.x, ' ', pos^.y, ' ');
+ {$ENDIF}
+ AddProcValue(ProcValues, CurXY.x, CurXY.y, pos);
+ pos := pos^.next
+ end
+ end;
+ up: begin
+ if CurXY.x = RememberValue then
+ begin
+ TotalOffset := TotalOffset + 1;
+ IsSequence := true
+ end;
+ if IsSequence then
+ offset := TotalOffset
+ else
+ offset := 1;
+ FoundPos := FindSquare(ProcValues, CurXY.x, CurXY.y);
+ if FoundPos <> nil then
+ begin
+ FoundPos^.y := FoundPos^.y + offset;
+ {$IFDEF DEBUG}
+ write('up ', FoundPos^.x, ' ', FoundPos^.y, ' ');
+ {$ENDIF}
+ end
+ else
+ begin
+ pos^.x := CurXY.x;
+ pos^.y := CurXY.y + offset;
+ AddProcValue(ProcValues, CurXY.x, CurXY.y, pos);
+ pos := pos^.next
+ end
+ end;
+ down: begin
+ if CurXY.x = RememberValue then
+ begin
+ TotalOffset := TotalOffset + 1;
+ IsSequence := true
+ end;
+ if IsSequence then
+ offset := TotalOffset
+ else
+ offset := 1;
+ FoundPos := FindSquare(ProcValues, CurXY.x, CurXY.y);
+ if FoundPos <> nil then
+ begin
+ FoundPos^.y := FoundPos^.y - offset;
+ {$IFDEF DEBUG}
+ write('down ', FoundPos^.x, ' ', FoundPos^.y, ' ');
+ {$ENDIF}
+ end
+ else
+ begin
+ pos^.x := CurXY.x;
+ pos^.y := CurXY.y - offset;
+ {$IFDEF DEBUG}
+ write('down ', pos^.x, ' ', pos^.y, ' ');
+ {$ENDIF}
+ AddProcValue(ProcValues, CurXY.x, CurXY.y, pos);
+ pos := pos^.next
+ end
+ end
+ end
+end;
+
+procedure ExtractFromArr(CurArr: ArrTurn; var pos: SquareItemPtr;
+ CurDir: direction; var ProcValues: ProcValuesType);
+var
+ i: integer = 1;
+ ShiftQuantity: integer = 1;
+ RememberValue: integer;
+ FoundPos: SquareItemPtr;
+begin
+ while (i <= MaxSquaresFromCenter) and
+ (CurArr[i].x = 0) and (CurArr[i].y = 0) do
+ i := i + 1;
+ if i <= MaxSquaresFromCenter then
+ begin
+ case CurDir of
+ left: begin
+ RememberValue := CurArr[i].y;
+ FoundPos := FindSquare(ProcValues, CurArr[i].x, CurArr[i].y);
+ if FoundPos <> nil then
+ begin
+ FoundPos^.x := FoundPos^.x - ShiftQuantity;
+ {$IFDEF DEBUG}
+ write('left ', FoundPos^.x, ' ', FoundPos^.y, ' ');
+ {$ENDIF}
+ end
+ else
+ begin
+ pos^.x := CurArr[i].x - ShiftQuantity;
+ pos^.y := CurArr[i].y;
+ AddProcValue(ProcValues, CurArr[i].x, CurArr[i].y, pos);
+ {$IFDEF DEBUG}
+ write('left ', pos^.x, ' ', pos^.y, ' ');
+ {$ENDIF}
+ pos := pos^.next
+ end;
+ end;
+ right: begin
+ RememberValue := CurArr[i].y;
+ FoundPos := FindSquare(ProcValues, CurArr[i].x, CurArr[i].y);
+ if FoundPos <> nil then
+ begin
+ FoundPos^.x := FoundPos^.x + ShiftQuantity;
+ {$IFDEF DEBUG}
+ write('right ', FoundPos^.x, ' ', FoundPos^.y, ' ');
+ {$ENDIF}
+ end
+ else
+ begin
+ pos^.x := CurArr[i].x + ShiftQuantity;
+ pos^.y := CurArr[i].y;
+ AddProcValue(ProcValues, CurArr[i].x, CurArr[i].y, pos);
+ {$IFDEF DEBUG}
+ write('right ', pos^.x, ' ', pos^.y, ' ');
+ {$ENDIF}
+ pos := pos^.next
+ end
+ end;
+ up: begin
+ RememberValue := CurArr[i].x;
+ FoundPos := FindSquare(ProcValues, CurArr[i].x, CurArr[i].y);
+ if FoundPos <> nil then
+ begin
+ FoundPos^.y := FoundPos^.y + ShiftQuantity;
+ {$IFDEF DEBUG}
+ write('up ', FoundPos^.x, ' ', FoundPos^.y, ' ');
+ {$ENDIF}
+ end
+ else
+ begin
+ pos^.x := CurArr[i].x;
+ pos^.y := CurArr[i].y + ShiftQuantity;
+ AddProcValue(ProcValues, CurArr[i].x, CurArr[i].y, pos);
+ {$IFDEF DEBUG}
+ write('up ', pos^.x, ' ', pos^.y, ' ');
+ {$ENDIF}
+ pos := pos^.next
+ end
+ end;
+ down: begin
+ RememberValue := CurArr[i].x;
+ FoundPos := FindSquare(ProcValues, CurArr[i].x, CurArr[i].y);
+ if FoundPos <> nil then
+ begin
+ FoundPos^.y := FoundPos^.y - ShiftQuantity;
+ {$IFDEF DEBUG}
+ write('down ', FoundPos^.x, ' ', FoundPos^.y, ' ');
+ {$ENDIF}
+ end
+ else
+ begin
+ pos^.x := CurArr[i].x;
+ pos^.y := CurArr[i].y - ShiftQuantity;
+ AddProcValue(ProcValues, CurArr[i].x, CurArr[i].y, pos);
+ {$IFDEF DEBUG}
+ write('down ', pos^.x, ' ', pos^.y, ' ');
+ {$ENDIF}
+ pos := pos^.next
+ end
+ end
+ end
+ end
+ else
+ exit;
+ for i := i + 1 to MaxSquaresFromCenter do
+ if (CurArr[i].x = 0) and (CurArr[i].y = 0) then
+ continue
+ else
+ MakeOffset(CurArr[i], pos, CurDir, ShiftQuantity, RememberValue,
+ ProcValues)
+end;
+
+procedure AddToArr(var CurArr: ArrTurn; x, y: integer);
+var
+ i: integer;
+begin
+ for i := 1 to MaxSquaresFromCenter do
+ if (CurArr[i].x = 0) and (CurArr[i].y = 0) then
+ begin
+ CurArr[i].x := x;
+ CurArr[i].y := y;
+ break
+ end
+end;
+
+procedure PrintServiceMsg(x, y: integer; msg: string);
+const
+ size = 30;
+var
+ i: integer;
+begin
+ GotoXY(x, y);
+ for i := 1 to size do
+ write(' ');
+ GotoXY(x, y);
+ write(msg)
+end;
+
+procedure UpdateChangedShape(var ChangedShape: ShapeList;
+ AllTurns: AllTurnsType);
+var
+ square: SquareItemPtr;
+ ProcValues: ProcValuesType;
+begin
+ ProcValues.first := nil;
+ ProcValues.last := nil;
+ {first square is a center of figure}
+ ChangedShape.first^.x := ChangedShape.cx;
+ ChangedShape.first^.y := ChangedShape.cy;
+ square := ChangedShape.first^.next;
+ {$IFDEF DEBUG}
+ GotoXY(55, 20);
+ write(' ');
+ GotoXY(55, 20);
+ write('centre: ', ChangedShape.cx, ' ', ChangedShape.cy, ' ');
+ {$ENDIF}
+ ExtractFromArr(AllTurns.left, square, left, ProcValues);
+ ExtractFromArr(AllTurns.right, square, right, ProcValues);
+ ExtractFromArr(AllTurns.up, square, up, ProcValues);
+ ExtractFromArr(AllTurns.down, square, down, ProcValues)
+end;
+
+procedure FixTurnViaArr(square: SquareItemPtr; cx, cy, NewX, NewY: integer;
+ var AllTurns: AllTurnsType);
+begin
+ if (square^.x <> cx) or (square^.y <> cy) then
+ begin
+ if square^.x > cx then
+ AddToArr(AllTurns.down, NewX, NewY);
+ if square^.x < cx then
+ AddToArr(AllTurns.up, NewX, NewY);
+ if square^.y > cy then
+ AddToArr(AllTurns.left, NewX, NewY);
+ if square^.y < cy then
+ AddToArr(AllTurns.right, NewX, NewY)
+ end
+end;
+
+procedure InitArr(var AllTurns: AllTurnsType);
+var
+ i: integer;
+begin
+ for i := 1 to MaxSquaresFromCenter do
+ begin
+ AllTurns.left[i].x := 0;
+ AllTurns.left[i].y := 0;
+ AllTurns.right[i].x := 0;
+ AllTurns.right[i].y := 0;
+ AllTurns.up[i].x := 0;
+ AllTurns.up[i].y := 0;
+ AllTurns.down[i].x := 0;
+ AllTurns.down[i].y := 0
+ end
+end;
+
+procedure PrintArr(arr: ArrTurn);
+var
+ i: integer;
+begin
+ for i := 1 to MaxSquaresFromCenter do
+ write(arr[i].x, ' ', arr[i].y, ' ')
+end;
+
+procedure ComputeTurn(var ChangedShape: ShapeList);
+var
+ AllTurns: AllTurnsType;
+ NewX, NewY: integer;
+ square: SquareItemPtr;
+begin
+ InitArr(AllTurns);
+ square := ChangedShape.first;
+ while square <> nil do
+ begin
+ NewX := ChangedShape.cx - (square^.y - ChangedShape.cy);
+ NewY := ChangedShape.cy + (square^.x - ChangedShape.cx);
+ FixTurnViaArr(square, ChangedShape.cx, ChangedShape.cy, NewX, NewY,
+ AllTurns);
+ square := square^.next
+ end;
+ SortArr(AllTurns.left, decrease, left);
+ SortArr(AllTurns.right, increase, right);
+ SortArr(AllTurns.up, decrease, up);
+ SortArr(AllTurns.down, increase, down);
+ {$IFDEF DEBUG}
+ PrintServiceMsg(55, 21, 'left arr: ');
+ PrintArr(AllTurns.left);
+ PrintServiceMsg(55, 22, 'right arr: ');
+ PrintArr(AllTurns.right);
+ PrintServiceMsg(55, 23, 'up arr: ');
+ PrintArr(AllTurns.up);
+ PrintServiceMsg(55, 24, 'down arr: ');
+ PrintArr(AllTurns.down);
+ {$ENDIF}
+ UpdateChangedShape(ChangedShape, AllTurns)
+end;
+
+procedure CheckBorders(var shape: ShapeList; var ChangedShape: ShapeList;
+ CurBorders: borders; var IsObstacle: boolean);
+begin
+ FindCenterFigure(shape);
+ {ChangedShape's center has been got from shape}
+ CopyShape(shape, ChangedShape);
+ if shape.CurDir <> turning then
+ CalculateNewXY(shape, ChangedShape)
+ else
+ ComputeTurn(ChangedShape);
+ IsObstacle := false;
+ if IsOnBorders(ChangedShape, CurBorders) then
+ begin
+ IsObstacle := true;
+ exit
+ end
+end;
+
+procedure FigureInitial(var shape: ShapeList; CurBorders: borders);
+const
+ quantity = 3;
+ ColorCount = 13;
+ probability = 6;
+var
+ TotalSquares: integer = 1;
+ i: integer;
+ AllColors: array [1..ColorCount] of word =
+ (
+ Green, Cyan, Magenta, Brown,
+ LightGray, DarkGray, LightBlue, LightGreen,
+ LightCyan, LightRed, LightMagenta,
+ Yellow, White
+ );
+ color: word;
+ LineShape: boolean = false;
+begin
+ {creating first square}
+ color := AllColors[random(ColorCount)+1];
+ LineShape := random(probability) = 0;
+ if LineShape then
+ CreateLineShape(shape, color)
+ else
+ CreateSquare(shape, color);
+ shape.CurDir := down;
+ shape.cx := -1;
+ shape.cy := -1;
+ shape.last^.x := CupWidth div 2 - 1;
+ shape.last^.y := 1;
+ shape.last^.CurDir := center;
+ if LineShape then
+ for i := 1 to quantity do
+ CreateLineShape(shape, color)
+ else
+ begin
+ {creating others squares}
+ for i := 1 to quantity do
+ begin
+ CreateSquare(shape, color);
+ SelectPos(shape, TotalSquares);
+ TotalSquares := TotalSquares + 1
+ end
+ end
+end;
+end.
diff --git a/tetree.pp b/tetree.pp
new file mode 100644
index 0000000..2b2a0c7
--- /dev/null
+++ b/tetree.pp
@@ -0,0 +1,358 @@
+unit tetree;
+
+interface
+uses figure;
+
+const
+ MaxLine = CupHeight div 2;
+ MaxSquares = 10;
+type
+ NodePtr = ^Node;
+ Node = record
+ square: SquareItemPtr;
+ left, right: NodePtr;
+ end;
+ LineInfo = record
+ NodeCount: byte;
+ root: NodePtr;
+ end;
+ WayFinding = array [1..MaxLine] of LineInfo;
+
+function SearchFillViaShape(arr: WayFinding; shape: ShapeList): integer;
+function SearchOtherFill(arr: WayFinding; pos: integer): integer;
+procedure InitMassive(var arr: WayFinding);
+procedure LineInspection(var shape, ChangedShape: ShapeList;
+ var arr: WayFinding; var IsObstacle: boolean);
+procedure AddInTree(var shape: ShapeList; var arr: WayFinding);
+procedure DropLine(var arr: WayFinding; pos: integer; CurBorders: borders);
+procedure ClearSquaresAndTree(var root: NodePtr);
+procedure ClearLines(pos: integer);
+
+implementation
+uses crt;
+type
+ TreeNodePos = ^NodePtr;
+ action = (print, ChValue);
+
+function SearchOtherFill(arr: WayFinding; pos: integer): integer;
+var
+ i, LowerLineIdx: integer;
+begin
+ LowerLineIdx := 0;
+ for i := 1 to pos do
+ if (arr[i].NodeCount = MaxSquares) and (i > LowerLineIdx) then
+ LowerLineIdx := i;
+ SearchOtherFill := LowerLineIdx
+end;
+
+function SearchFillViaShape(arr: WayFinding; shape: ShapeList): integer;
+type
+ BottomFillLineType = record
+ Idx, value: integer;
+ end;
+var
+ square: SquareItemPtr;
+ BottomFillLine: BottomFillLineType;
+ IdxArr: integer;
+begin
+ BottomFillLine.Idx := 0;
+ BottomFillLine.value := 0;
+ square := shape.first;
+ while square <> nil do
+ begin
+ IdxArr := (square^.y - 1) div 2 + 1;
+ if (IdxArr >= 1) and (IdxArr <= MaxLine) then
+ begin
+ if (arr[IdxArr].NodeCount = MaxSquares) and
+ (square^.y > BottomFillLine.value) then
+ begin
+ BottomFillLine.Idx := IdxArr;
+ BottomFillLine.value := square^.y
+ end
+ end;
+ square := square^.next
+ end;
+ SearchFillViaShape := BottomFillLine.Idx
+end;
+
+procedure ClearSquaresAndTree(var root: NodePtr);
+begin
+ if root <> nil then
+ begin
+ ClearSquaresAndTree(root^.left);
+ ClearSquaresAndTree(root^.right);
+ {delete squares}
+ if root^.square <> nil then
+ begin
+ dispose(root^.square);
+ root^.square := nil
+ end;
+ {delete tree}
+ dispose(root);
+ root := nil
+ end
+end;
+
+procedure Traversal(var root: NodePtr; select: action; CurBorders: borders);
+var
+ i, j: integer;
+begin
+ if root = nil then
+ exit;
+ Traversal(root^.left, select, CurBorders);
+ case select of
+ print: begin
+ for i := 0 to HeightSquare-1 do
+ begin
+ for j := 0 to WidthSquare-1 do
+ begin
+ if not IsAboveTop(root^.square, CurBorders) then
+ begin
+ GotoXY(root^.square^.x+j, root^.square^.y+i);
+ TextColor(root^.square^.color);
+ write('*')
+ end
+ end;
+ writeln
+ end
+ end;
+ ChValue: root^.square^.y := root^.square^.y + HeightSquare
+ end;
+ Traversal(root^.right, select, CurBorders)
+end;
+
+procedure ClearLines(pos: integer);
+const
+ LeftBegin = 2;
+var
+ i, j: integer;
+begin
+ for i := 1 to pos * HeightSquare do
+ begin
+ GotoXY(LeftBegin, i);
+ for j := 1 to CupWidth-1 do
+ write(' ')
+ end
+end;
+
+procedure LineShifting(var arr: WayFinding; BeginPos, EndPos: integer;
+ CurBorders: borders);
+begin
+ if BeginPos = EndPos then
+ begin
+ ClearSquaresAndTree(arr[EndPos].root);
+ arr[EndPos] := arr[EndPos-1];
+ Traversal(arr[EndPos].root, ChValue, CurBorders);
+ exit
+ end;
+ LineShifting(arr, BeginPos+1, EndPos, CurBorders);
+ if BeginPos-1 < BeginCup then
+ exit;
+ arr[BeginPos] := arr[BeginPos-1];
+ Traversal(arr[BeginPos].root, ChValue, CurBorders)
+end;
+
+procedure DropLine(var arr: WayFinding; pos: integer; CurBorders: borders);
+var
+ i: integer;
+begin
+ ClearLines(pos);
+ i := 1;
+ while arr[i].NodeCount = 0 do
+ i := i + 1;
+ if (i + 1 <> pos) and (i <= MaxLine) then
+ LineShifting(arr, i + 1, pos, CurBorders)
+ else if i + 1 = pos then
+ LineShifting(arr, pos, pos, CurBorders);
+ {if i > pos, clear only last line}
+ if (i >= 1) and (i <= MaxLine) then
+ begin
+ arr[i].root := nil;
+ arr[i].NodeCount := 0
+ end;
+ for i := i + 1 to pos do
+ Traversal(arr[i].root, print, CurBorders)
+end;
+
+procedure InitMassive(var arr: WayFinding);
+var
+ i: integer;
+begin
+ for i := 1 to MaxLine do
+ begin
+ arr[i].NodeCount := 0;
+ arr[i].root := nil
+ end
+end;
+
+function SearchTree(var p: NodePtr; val: integer): TreeNodePos;
+begin
+ if (p = nil) or (p^.square^.x= val) then
+ begin
+ {$IFDEF DEBUG}
+ GotoXY(50, 1);
+ if (p <> nil) and (p^.square^.x = val) then
+ write('DEBUG: value is found');
+ {$ENDIF}
+ SearchTree := @p
+ end
+ else if val < p^.square^.x then
+ SearchTree := SearchTree(p^.left, val)
+ else
+ SearchTree := SearchTree(p^.right, val)
+end;
+
+procedure AddInTree(var shape: ShapeList; var arr: WayFinding);
+var
+ square: SquareItemPtr;
+ PosNode: TreeNodePos;
+ IdxArr: integer;
+begin
+ square := shape.first;
+ while square <> nil do
+ begin
+ IdxArr := (square^.y-1) div 2+1;
+ PosNode := SearchTree(arr[IdxArr].root, square^.x);
+ if PosNode^ = nil then
+ begin
+ new(PosNode^);
+ PosNode^^.square := square;
+ PosNode^^.left := nil;
+ PosNode^^.right := nil;
+ arr[IdxArr].NodeCount := arr[IdxArr].NodeCount + 1
+ end;
+ square := square^.next
+ end
+end;
+
+procedure CheckTurnThroughSquare(var shape: ShapeList; arr: WayFinding);
+const
+ MaxLength = 15;
+var
+ IdxArr, i, j, distance: integer;
+ LeftEdge, RightEdge, UpEdge, DownEdge: EdgeType;
+begin
+ InitEdges(LeftEdge, RightEdge, UpEdge, DownEdge, shape);
+ {left}
+ if (LeftEdge.x <> 0) and (LeftEdge.y <> 0) then
+ begin
+ distance := (shape.cx - LeftEdge.x) div 3;
+ if distance >= 1 then
+ begin
+ for i := 0 to distance-1 do
+ begin
+ for j := 1 to distance do
+ begin
+ IdxArr := ((LeftEdge.y - j * HeightSquare) - 1) div 2 + 1;
+ if (IdxArr >= 1) and (IdxArr <= MaxLength) then
+ begin
+ if SearchTree(arr[IdxArr].root,
+ LeftEdge.x + i * WidthSquare)^ <> nil then
+ begin
+ shape.CanTurn := false;
+ exit
+ end
+ end
+ end
+ end
+ end
+ end;
+ {right}
+ if (RightEdge.x <> 0) and (RightEdge.y <> 0) then
+ begin
+ distance := (RightEdge.x - shape.cx) div 3;
+ if distance >= 1 then
+ begin
+ for i := 0 to distance-1 do
+ begin
+ for j := 1 to distance do
+ begin
+ IdxArr := ((RightEdge.y + j * HeightSquare) - 1) div 2 + 1;
+ if (IdxArr >= 1) and (IdxArr <= MaxLength) then
+ begin
+ if SearchTree(arr[IdxArr].root,
+ RightEdge.x - i*WidthSquare)^ <> nil then
+ begin
+ shape.CanTurn := false;
+ exit
+ end
+ end
+ end
+ end
+ end
+ end;
+ {up}
+ if (UpEdge.x <> 0) and (UpEdge.y <> 0) then
+ begin
+ distance := (shape.cy - UpEdge.y) div 2;
+ if distance >= 1 then
+ begin
+ for i := 0 to distance-1 do
+ begin
+ for j := 1 to distance do
+ begin
+ IdxArr := ((UpEdge.y + i * HeightSquare) - 1) div 2 + 1;
+ if (IdxArr >= 1) and (IdxArr <= MaxLength) then
+ begin
+ if SearchTree(arr[IdxArr].root,
+ UpEdge.x + j * WidthSquare)^ <> nil then
+ begin
+ shape.CanTurn := false;
+ exit
+ end
+ end
+ end
+ end
+ end
+ end;
+ {down}
+ if (DownEdge.x <> 0) and (DownEdge.y <> 0) then
+ begin
+ distance := (DownEdge.y - shape.cy) div 2;
+ if distance >= 1 then
+ begin
+ for i := 0 to distance-1 do
+ begin
+ for j := 1 to distance do
+ begin
+ IdxArr := ((DownEdge.y - i * HeightSquare) - 1) div 2 + 1;
+ if (IdxArr >= 1) and (IdxArr <= MaxLength) then
+ begin
+ if SearchTree(arr[IdxArr].root,
+ DownEdge.x - j * WidthSquare)^ <> nil then
+ begin
+ shape.CanTurn := false;
+ exit
+ end
+ end
+ end
+ end
+ end
+ end;
+end;
+
+procedure LineInspection(var shape, ChangedShape: ShapeList;
+ var arr: WayFinding; var IsObstacle: boolean);
+var
+ square: SquareItemPtr;
+ IdxArr: integer;
+begin
+ IsObstacle := false;
+ square := ChangedShape.first;
+ while square <> nil do
+ begin
+ if square^.y > 0 then
+ begin
+ IdxArr := (square^.y-1) div 2+1;
+ if SearchTree(arr[IdxArr].root, square^.x)^ <> nil then
+ begin
+ IsObstacle := true;
+ break
+ end
+ end;
+ square := square^.next
+ end;
+ if not shape.IsSquare then
+ CheckTurnThroughSquare(shape, arr)
+end;
+end.
diff --git a/tetris.pas b/tetris.pas
new file mode 100644
index 0000000..f3ce680
--- /dev/null
+++ b/tetris.pas
@@ -0,0 +1,725 @@
+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;
+ key: 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.
generated by cgit v1.2.3 (git 2.25.1) at 2024-10-16 14:24:46 +0300