Initial commit

1 files changed, 358 insertions, 0 deletions

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.