ubox.pas

很好的俄罗斯方块

  i,j: Integer;
begin
  Canvas.Brush.Color := Color;
  Canvas.Pen.Color := Color;
  for i := 1 to MLen do
    for j := 1 to MLen do
      if B[i,j].Empty <>EmptyBlock then
      Canvas.Rectangle(X+i*BWid-BWid,
                       Y+j*BWid-BWid,
                       X+i*BWid,
                       Y+j*BWid);    //修正了覆盖背景中的bug使改变背景成为可能。
                       {原来的程序：
                       X+i*BWid -1,
                       Y+j*BWid -1);}    //修正了覆盖背景中的bug使改变背景成为可能。
end;

//---------------------------------------------------------------------
{ 在 (X,Y) 位置画出方块 }
{ 方块用数组 B 表示     }
procedure DrawBoxXY(Canvas: TCanvas;
                    X,Y: Integer;
                    B: TBoxArray);
var
  i,j: Integer;
begin
  for i := 1 to MLen do
    for j := 1 to MLen do
      if B[i,j].Empty <>EmptyBlock {=true} then
      DrawRect(Canvas,X+i*BWid-BWid,
               Y+j*BWid-BWid,
               X+i*BWid-1,
               Y+j*BWid-1,B[i,j].Color);
end;

//---------------------------------------------------------------------
{ 使用背景数组的维数为坐标 }
{ 画方块，这样可以脱离实际 }
{ 屏幕                     }
procedure BoxMoveTo(Canvas: TCanvas;
                    X,Y: Integer;
                    B: TBoxArray);
begin
  DrawBoxBK(Canvas,BkLeft+(LasX-1)*BWid,BkTop+(LasY-1)*BWid,B,BkColor);
  DrawBoxXY(Canvas,BkLeft+(X-1)*BWid,BkTop+(Y-1)*BWid,B);
end;

//---------------------------------------------------------------------
{ 画背景图 }

procedure DrawMap(Canvas: TCanvas);
var
  i,j: Integer;
begin
  Canvas.Pen.Color := clYellow xor BkColor;
  Canvas.Brush.Color := BkColor;
  Canvas.Rectangle(BkLeft+3*BWid-1,BkTop-1,
                   BkLeft+(MapWid-3)*BWid+1,
                   BkTop+(MapHei-3)*BWid+1);
  for i := 4 to MapWid-3 do
    for j := 1 to MapHei-3 do
      if Map[i,j].Empty <>EmptyBlock{=true} then
      DrawRect(Canvas,BkLeft+i*BWid-BWid,BkTop+j*BWid-BWid,
                            BkLeft+i*BWid-1,BkTop+j*BWid-1,Map[i,j].Color);

end;

//---------------------------------------------------------------------
{ 测试是否可以走到 (X,Y) 地图位置 }
function  CanGo(X,Y: Integer;B: TBoxArray): Boolean;
var
  i,j: Integer;
  Flag: Boolean;
begin
  if (X<1) or (X>MapWid) or
     (Y<1) or (Y>MapHei) then
     begin
       CanGo := false;
       Exit;
     end;

  Flag := true;
  for i := X to X+MLen-1 do
    for j := Y to Y+MLen-1 do
    begin
      if (Map[i,j].Empty <>EmptyBlock{true}) and (B[i-X+1,j-Y+1].Empty <>EmptyBlock{=true}) then
        Flag := false;
    end;
  CanGo := Flag;
end;

//---------------------------------------------------------------------
{ 用来对两个数组之间的拷贝 }
procedure CopyBox(var ObjBox: TBoxArray;Source: TBoxArray);
var
  i,j: Integer;
begin
  for i := 1 to MLen do
    for j := 1 to MLen do
      ObjBox[i,j] := Source[i,j];
end;

//---------------------------------------------------------------------
{ 对一个数组进行转置 }
{ 用来实现反转效果   }
procedure Change(Canvas: TCanvas;var B: TBoxArray;var CurX: Integer;var CurY:Integer);
var
  i,j: Integer;
  tmp: TBoxArray;
begin
  if BlockId = 1 then Exit;
  if (BlockId = 7) then
  begin
    for i := 1 to MLen do
      for j:= 1 to MLen do
        tmp[i,j] := B[j,i];
  end else
  begin
      for i := 1 to MLen do
         for j := 1 to MLen do
            tmp[i,j].Empty  := EmptyBlock;

     for i := 1 to 3 do
         for j := 1 to 3 do
           if B[i,j].Empty  <> EmptyBlock then tmp[j,3-i+1] := B[i,j];
  end;

  if not CanGo(CurX,CurY,tmp) then exit;

  DrawBoxBK(Canvas,BkLeft+(LasX-1)*BWid,BkTop+(LasY-1)*BWid,B,BkColor);
  CopyBox(B,tmp);

  DrawBoxXY(Canvas,BkLeft+(CurX-1)*BWid,BkTop+(CurY-1)*BWid,B);
end;

//---------------------------------------------------------------------
{ 当一个方块停止的时候，把他完全复制给背景 }
procedure MoveToMap(X,Y: Integer;B: TBoxArray);
var
  i,j: Integer;
begin
  for i := X to X+MLen-1 do
    for j := Y to Y+MLen-1 do
      if B[i-X+1,j-Y+1].Empty <>EmptyBlock then Map[i,j] := B[i-X+1,j-Y+1];
end;

//---------------------------------------------------------------------
{ 在 MAP 中找已经完成的行 }
procedure ScanEmptyLine(Canvas: TCanvas;var Line: TEmptyLine);
var
  i,j,k: Integer;
  EptLine: Boolean; //是一个空行
begin
  k := 1;
  for i := 1 to MapHei do
  begin
    EptLine := true;
    Line[k] := 0;
    { 扫描一行 }
    for j := 1 to MapWid do
      if Map[j,i].Empty = EmptyBlock then EptLine := false;
    if EptLine then
    begin
      Line[k] := i;
      k := k + 1;
      if k=5 then exit;
    end;
  end;
  //for i := CurY to CurY+Hei-1 do
  {for i := CurY to CurY + 3 do
  begin
    EptLine := true;
    Line[i-CurY+1] := 0;
    for j := 1 to MapWid do
      if Map[j,i].Empty = EmptyBlock then EptLine := false;
    if EptLine then
      Line[i-CurY+1] := i;
  end;
  }
end;

//---------------------------------------------------------------------
{ 对地图进行消行的处理 }
procedure FreshMap(Canvas: TCanvas;Line: TEmptyLine);
var
  i: Integer;
  Count: Integer;
  Hei: Integer;
begin
  Hei := GetHeight(Block);
  Count := 0;
  for i := 1 to Hei do
  begin
    if Line[i]<>0 then
    begin
      DelAMapLine(Line[i]);
      DrawMap(Canvas);
      Count := Count +1;
    end;
  end;
  {在这里积分,按平方记}
  Score := Score +Count*Count*100;
  CurLevelScore := CurLevelScore +Count*Count*100;

end;

//---------------------------------------------------------------------
{ 删除地图数组中的第 I 行 }
procedure DelAMapLine(I: Integer);
var
  j,k: Integer;
begin
  for k := I downto 2 do
    for j := 4 to MapWid - 3 do  {这里一定要使用 4 和 MapWid - 3 这两个之间的宽度，否则有错误} 
      Map[j,k] := Map[j,k-1];
end;

//---------------------------------------------------------------------
function Max(X1,X2: Integer): Integer;
begin
  if X1 <= X2 then Max := X2
    else Max := X1;
end;

//---------------------------------------------------------------------
{ 显示下个方块 }
procedure ShowNext(Canvas: TCanvas);
var
   Block: TBoxArray;
begin
  Canvas.Brush.Color := frmGame.Color;
  Canvas.Pen.Color := frmGame.Color;
  Canvas.Rectangle(BkLeft+290,BkTop+50,BkLeft+290+4*BWid,BkTop+50+4*BWid);
  CopyBox(Block,Box[NextId]);
  SetBlockColor(Block,clGreen xor frmGame.Color);
  DrawBoxXY(Canvas,BkLeft+290,BkTop+50,Block);
end;

//---------------------------------------------------------------------
{ 显示提示信息 }
procedure ShowMess(Canvas: TCanvas;S: String);
begin
  Canvas.Brush.Color := clWhite;
  Canvas.Pen.Color := clYellow;
  Canvas.TextOut(200,60,S);
end;

//---------------------------------------------------------------------
{设置方块的颜色}
procedure SetBlockColor(var B:TBoxArray;Color: TColor);
var
   i,j: integer;
begin
   for i:= 1 to MLen do
      for j:=1 to MLen do
      B[i,j].Color := Color;
end;

//---------------------------------------------------------------------
{修正方快的坐标偏差（主要是垂直方向）
  这里存在一个修正问题，有可能出现下面的情况：
       0,0,0,0
       1,0,0,0
       1,1,1,0
       0,0,0,0
  那么这个时候应该把CurY的值修正为左上角的第一个一的直，而以前CurY的值
  为左上角(1,1)坐标的直。
  用在进行变换方快之后调整。。。
}
procedure CheckBlock(var B:TBoxArray);
var
   i,j: integer;
   EmptyLine: Boolean;
begin
   for j:= 1 to GetHeight(B) do
   begin
      EmptyLine := true;//如果一行为空那么这个直为true;
      for i:= 1 to GetWidth(B) do
         if B[i,j].Empty = NotEmptyBlock then EmptyLine := false;

      if EmptyLine then
      begin
         CurY := CurY + 1; //修正当前的y坐标
         exit;
      end;{if}
   end;{for i}
end;

end.