path: root/tetree.pp

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.