box.~pas

双人对战 俄罗斯访快

unit box;

interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls,mmsystem;

const
    CellWH=15;
  BoxNum=4;
  MapWNum=15;
  MapHNum=24;
  stale=7;
Type
  TBoxCell=record
    X : INTEGER;
    Y : INTEGER;
    b : boolean;
    end;

Type
  TBoxBlock=record
   block:array[1..BoxNum] of TBoxCell;
   s:integer;
   end;
type

 TMapBlock = array[0..MapWNum+3,0..MapHNum+3] of TBoxCell;
 TBoxStale = array[1..stale] of TBoxBlock;
 TFline = array[1..MapHNum] of integer;


var
 Bcolor   : Tcolor=clblack;


 procedure DrawMap(canvas:Tcanvas;Pic:Tpicture;DMapBlock:TMapBlock);
 procedure DrawBlock(X,Y:integer;canvas:Tcanvas;DBoxBlock:TBoxBlock;pic:Tpicture;Map:TMapBlock);
 procedure BoxToMap(var BMapBlock:TMapBlock;BBoxBlock:TBoxBlock;curX,curY:integer);
 procedure InitBoxB(var Boxstale:TBoxStale);
 procedure InitMapB(var Map:TMapBlock);
 function  CanGo(curX,cury:integer;Boxblock:TBoxBlock;MapBlock:TMapBlock):boolean;
 function  ChangeBoxBlock(CBoxBlock:TBoxBlock):TBoxBlock;
 procedure DrawRectB(canvas:Tcanvas;x,y:integer;color:Tcolor);
 procedure DrawRectG(canvas:Tcanvas;x,y:integer;pic:TPicture);
 procedure FlineBlock( Map:TMapBlock;var Fline:TFline);
// procedure ElineBlock(var Map:TMapBlock; Fline:TFline; var mapD:tmapblock;m:integer);
 procedure ProductBoxBlock(var Box:TBoxBlock;BoxStale:TBoxStale);
 Function BoxMove(var curX,curY:integer;can:Tcanvas;pic:Tpicture;Box:TboxBlock;Map:TMapBlock;i:integer=0):boolean;
Function FlineE(map:tmapblock;var Eline:integer;k:integer):boolean;
procedure ElineBlock(var Map:TMapBlock; Fline:TFline; var mapD:tmapblock;m:integer;eline:integer);
function ElineE(var map:tmapblock;k:integer;eline:integer):boolean;
implementation
uses
unit1;

function ElineE(var map:tmapblock;k:integer;eline:integer):boolean;
var i,j:integer;
begin
result:=true;
if not Flinee(map,eline,k) then
begin
result:=false;
exit;
end;
 for i:=eline to 24 do
    for j:=1 to MapWNum do
    Map[j,i-k].b:=Map[j,i].b;
    eline:=24;
end;

Function BoxMove(var curX,curY:integer;can:Tcanvas;pic:Tpicture;Box:TboxBlock;Map:TMapBlock;i:integer=0):boolean;
begin
result:=true;

if i=0 then
begin
 if not cango(curx,cury+1,box,map) then
  begin
  result:=false;
  exit;
  end;
 DrawBlock(curx,cury+1,can,box,pic,map);
 inc(cury);
end else
if (i=1) and cango(curx-1,cury,box,map) then
begin
  DrawBlock(curx-1,cury,can,box,pic,map);
  dec(curx);
end else
if (i=2) and cango(curx+1,cury,box,map) then
begin
  DrawBlock(curx+1,cury,can,box,pic,map);
  inc(curx);
end else result:=false;
end;

procedure ProductBoxBlock(var Box:TBoxBlock;BoxStale:TBoxStale);
var i,t,k:integer;
begin
 Randomize;
k:=random(7)+1;
t:=random(5)+1;
box:= Boxstale[k];
for i:=1 to t do
box:=changeboxblock(box);
end;

procedure ElineBlock(var Map:TMapBlock; Fline:TFline; var mapD:tmapblock;m:integer;eline:integer);
var i,j,k,l:integer;
begin
 for k:= 1 to MapHNum do
 begin
 if Fline[k]<>0 then
  begin
   inc(l);
   for i:=Fline[k] Downto 2 do
    for j:=1 to MapWNum do
    Map[j,i].b:=Map[j,i-1].b;

    if form1.Menusound.Checked then
    PlaySound(PChar('succ'), hInstance, snd_ASync or snd_Resource);
  end;
 end;
    if (l>=2) and (l<4) then
    begin
      if ElineE(mapD,l-1,eline) then
        begin
        ranmap(l-1,mapd,m) ;
        if form1.Menusound.Checked then
       PlaySound(PChar('fail'), hInstance, snd_ASync or snd_Resource);
        end
        else
        begin
        if m=1 then
        begin
         form1.timer1.Enabled:=false;
      form1.timer3.Enabled:=false;
        over1:=3;
       // over2:=1;
        end;
        if m=2 then
        begin
         form1.timer1.Enabled:=false;
      form1.timer3.Enabled:=false;
        over2:=3;
      //  over1:=1;
        end;
        form1.timer5.Enabled:=true;
        // gameover;
         exit;
        end;
       end  else
        if l=4 then
    begin
      if ElineE(mapD,l,eline) then
        begin
        ranmap(l,mapd,m) ;
        if form1.Menusound.Checked then
    PlaySound(PChar('up'), hInstance, snd_ASync or snd_Resource);
        end
        else
        begin
         if m=1 then
        begin
         form1.timer1.Enabled:=false;
      form1.timer3.Enabled:=false;
        over1:=3;
       // over2:=1;
        end;
        if m=2 then
        begin
         form1.timer1.Enabled:=false;
      form1.timer3.Enabled:=false;
        over2:=3;
      //  over1:=1;
        end;
        form1.timer5.Enabled:=true;
        // gameover;
         exit;
        end;
       end

end;

Function FlineE(map:tmapblock;var Eline:integer;k:integer):boolean;
var i,j:integer;
begin
Eline:=24;
result:=true;
for i:=1 to MapHNum do
begin
 for j:=1 to MapWnum do
 begin
   if  Map[j,i].b then
   begin
   if ((25-i)+k)>=22 then
   begin
   result:=false;
   exit;
   end;
   Eline:= i;
   exit;
   end;
 end;
 end;
 end;


procedure FlineBlock( Map:TMapBlock;var Fline:TFline);
var i,j,k:integer;
   e:boolean;
begin
K:=1;
for i:=1 to MapHNum do Fline[i]:=0;
for i:=1 to MapHNum do
begin
 e:=true;
 for j:=1 to MapWnum do
 begin
    //Fline[k]:=0;
    if not Map[j,i].b then
     e:=false;
 end;
  if e then
   begin
    Fline[k]:=i; inc(k);
    end;
end;
end;

procedure DrawRectG(canvas:Tcanvas;x,y:integer;pic:TPicture);
var
rect:Trect;

begin
rect.Left:=x-CellWH;
rect.Top :=y-CellWH;
rect.Bottom:=Y;
rect.Right :=x;
canvas.StretchDraw(rect,pic.Graphic);
end;
procedure DrawRectB(canvas:Tcanvas;x,y:integer;color:Tcolor);
var
 rect :Trect;
begin
rect.Left:=x-CellWH;
rect.Top :=y-CellWH;
rect.Bottom:=Y;
rect.Right :=x;
canvas.Brush.Color:=color;
canvas.Pen.Color:=color;
canvas.FillRect(rect);
end;


procedure InitMapB(var Map:TMapBlock);
var
i,j:integer;
begin
for i:=0 to MapHNum+3   do
 for j:=0 to MapWNum +3 do
  map[j,i].b:=true;
 for i:=1 to MapHNum do
  for j:=1 to MapWNum do
   begin
   Map[j,i].b := false;  //kong
 //  Map[i,j].b := true;
   end; 

end;

procedure DrawMap(canvas:Tcanvas;Pic:Tpicture;DMapBlock:TMapBlock);
var
 i,j:integer;
begin
Canvas.Pen.Color:=Bcolor;
Canvas.Brush.Color:=Bcolor;
for j:=1 to MapHNum do
 for i:=1 to MapWNum do
  begin
  if DMapBlock[i,j].b  then
  begin
  DrawRectG(canvas,i*cellwh,j*cellwh,pic);
  end else DrawRectB(canvas,i*cellwh,j*cellwh,bcolor);
  end;
//
end;
procedure DrawBlock(X,Y:integer;canvas:Tcanvas;DBoxBlock:TBoxBlock;pic:Tpicture;Map:TMapBlock);
var
i,j:integer;
begin
for j:=-3 to BoxNUm+3 do
  for i:=-3 to BoxNum+3 do
   begin
   if not map[i+x-1,j+y-1].b then
    DrawRectB(canvas,(X+i-1)*cellwh,(y+j-1)*cellwh,bcolor);
    end; //}
   // DrawMap(canvas,pic,map);
for i:=1 to BoxNum do
 DrawRectG(canvas,(X+DboxBlock.block[i].X-1)*cellwh,(y+DBoxBlock.block[i].Y-1)*cellwh,pic);
//
end;

procedure BoxToMap(var BMapBlock:TMapBlock;BBoxBlock:TBoxBlock;curX,curY:integer);
var i:integer;
begin
for i:=1 to BoxNum do
BMapBlock[BBoxBlock.block[i].X+curX-1,BBoxBlock.block[i].Y+curY-1].b:=true;
// end;
end;

procedure InitBoxB(var Boxstale:TBoxStale);

procedure setbox(var box:TBoxBlock;S:string);
var
i, j,k:integer;
begin
i:=1;
for j:=1 to BoxNum do
 for k:=1 to BoxNum do
  begin
  if copy(s,(J-1)*BoxNum+k,1)='1' then
  begin
  box.block[i].X:=k;
  box.block[i].Y:=j;
  inc(i);
  if i=5 then exit;
  end;
  end;
end;

begin
setbox(BoxStale[1],'1000'+
                   '1100'+
                   '0100'+
                   '0000');
                   BoxStale[1].s:=1;
setbox(BoxStale[2],'0100'+
                   '1100'+
                   '1000'+
                   '0000');
                    BoxStale[2].s:=2;
setbox(BoxStale[3],'0100'+
                   '0100'+
                   '1100'+
                   '0000');
                    BoxStale[3].s:=3;
setbox(BoxStale[4],'0100'+
                   '0100'+
                   '0110'+
                   '0000');
                    BoxStale[4].s:=4;
setbox(BoxStale[5],'0100'+
                   '1100'+
                   '0100'+
                   '0000');
                    BoxStale[5].s:=5;
setbox(BoxStale[6],'0100'+
                   '0100'+
                   '0100'+
                   '0100');
                    BoxStale[6].s:=6;
setbox(BoxStale[7],'1100'+
                   '1100'+
                   '0000'+
                   '0000');
                   BoxStale[7].s:=7;
end;
function CanGo(curX,curY:integer;BoxBlock:TBoxBlock;MapBlock:TMapBlock):boolean;
var
 i:integer;
begin
 CanGo:=true;
 for i:=1 to BoxNum do
 begin
 if  MapBlock[BoxBlock.block[i].X+curX-1,BoxBlock.block[i].Y+curY-1].b then
  begin
  CanGo:=false;
  exit;
  end;
 end;
//end;
end;

Function ChangeBoxBlock(CBoxBlock:TBoxBlock):TBoxBlock;
var i:integer;
begin
if CBoxBlock.s=7 then
begin
result :=CBoxBlock ;
exit;
end;
if CBoxblock.s=6 then
 begin
  for i:=1 to BoxNum do
   begin
   result.block[i].X :=CBoxBlock.block[i].Y;
   result.block[i].Y :=CBoxBlock.block[i].X;
   end
 end else
 begin
  for i:=1 to BoxNum do
  begin
   result.block[i].X :=    CBoxBlock.block[i].Y;
   result.block[i].Y :=   BoxNum-CBoxBlock.block[i].X;
  end;
 end;
end;

end.