From 7524bcbda6a6aa8db0b6989563602aeb5e159bdf Mon Sep 17 00:00:00 2001 From: scratko Date: Thu, 21 Mar 2024 03:24:10 +0300 Subject: Initial commit --- tetree.pp | 358 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 358 insertions(+) create mode 100644 tetree.pp (limited to 'tetree.pp') 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. -- cgit v1.2.3