谁有用delphi4.0以上写的俄罗斯方块的源代码

Question

能发个附件给我吗,我的email:[email protected] or [email protected]

Answer 1

//turbo pascal 7.0 
//不你的要求，自己改改吧
program sysotffk;
  uses
    crt;
  const
    maxk=5;maxz=18;maxx=19;maxy=19;maxtx=5;maxty=5;maxcj=100;maxjb=12;
    px:array[1..maxz,1..maxk] of byte=
((1,2,3,4,5),(1,2,3,4,4),(2,2,3,4,5),(1,2,3,3,4),(2,3,3,4,5),
 (3,2,3,4,3),(2,3,4,2,3),(2,3,4,3,4),(2,2,3,4,3),(4,2,3,4,3),
 (2,3,3,4,4),(2,3,3,3,4),(3,4,3,2,3),(2,4,2,3,4),(2,3,4,3,3),
 (2,3,4,4,4),(1,2,3,3,4),(3,4,5,2,3));
    py:array[1..maxz,1..maxk] of byte=
((3,3,3,3,3),(3,3,3,3,4),(4,3,3,3,3),(3,3,3,4,3),(3,4,3,3,3),
 (2,3,3,3,4),(3,3,3,4,4),(3,3,3,4,4),(2,3,3,3,4),(2,3,3,3,4),
 (2,2,3,3,4),(2,2,3,4,4),(2,2,3,4,4),(2,2,3,3,3),(2,2,2,3,4),
 (2,2,2,3,4),(3,3,3,4,4),(3,3,3,4,4));
    jbc:array[1..maxjb] of string=
('①[4×4]','②[4×5]','③[5×5]','④[5×6]','⑤[6×6]',
 '⑥[6×7]','⑦[7×7]','⑧[7×8]','⑨[8×8]','⑩[8×9]','⑾[9×9]','⑿[9×10]');
    jbx:array[1..maxjb] of byte=(4,4,5,5,6,6,7,7,8,8,9,9);
    jby:array[1..maxjb] of byte=(4,5,5,6,6,7,7,8,8,9,9,10);
    FileName='sysoftfk.dat';
  type
    arby=array[1..maxx,1..maxy] of byte;
  var
    lc,lh,l0:arby;F:file of arby;
    tx:array[1..maxk] of byte;
    ty:array[1..maxk] of byte;
    i,r,rt,jb,inkey:byte;
    x,y,ink,kx,ky:shortint;
    hxm:boolean;
    cj:word;
  procedure ptt(s,d,n:word);
    var
      i:word;
    begin
      for i:=1 to n do
        begin
          sound(200+s*random(i));
          delay(d);
        end;
      NoSound;
    end;
  procedure pxy(x,y,c:byte;sh:string);
    var
      x0,y0:byte;
    begin
      x0:=wherex;y0:=wherey;
      gotoxy(x,y);textcolor(c);write(sh);
      gotoxy(x0,y0);
    end;
  procedure ppm;
    const
      c=7;
    procedure pplx;
      var x:byte;
      begin
        for x:=1 to maxx+2 do
          begin
            pxy(x*2-1,1,c,'━');pxy(x*2-1,maxy+2,c,'━');
          end
      end;
    procedure pply;
      var y:byte;
      begin
        for y:=1 to maxy+2 do
          begin
            pxy(1,y,c,'┃');pxy(maxx*2+3,y,c,'┃');
          end;
      end;
    procedure ppll;
      begin
        pxy(1,            1,c,'┏');
        pxy(1,       maxy+2,c,'┗');
        pxy(maxx*2+3,     1,c,'┓');
        pxy(maxx*2+3,maxy+2,c,'┛');
      end;
    begin
      clrscr;
      pplx;pply;ppll;
    end;
  procedure pp0;
    var
      x,y:byte;cjc:string;
    begin
      ppm;
      for x:=1 to maxx do
        for y:=1 to maxy do
          lc[x,y]:=0;
      l0:=lc;jb:=1;cj:=0;
      str(cj:8,cjc);
      pxy(maxx*2+10,maxy div 3,  jb,'级别:'+jbc[jb]);
      pxy(maxx*2+10,maxy div 3+2,jb,'成绩:'+cjc);
      pxy(1,maxy+4,15,'本程序由 王集鹄 设计 Tel:[phone] Bp:126-124499');
    end;
  function fke:shortint;
    var c:char;    begin
      c:=readkey;
      if (c=#0)and(keypressed) then
        begin
          c:=readkey;
          fke:=-ord(c);
        end
      else
        fke:=ord(c)
    end;
  procedure psj(n:byte);
    var i:byte;
    begin
      for i:=1 to maxk do
        begin
          tx[i]:=px[n,i];ty[i]:=py[n,i];
        end;
    end;
  procedure pwz(x,y,n,b:byte);
    var
      sh:string[2];c:byte;
    begin
      case b of
        0 : if lc[x,y]=0 then
              sh:='  '
            else
              begin
                n:=lc[x,y];
                sh:='★';
              end;
        2 : begin
              lc[x,y]:=n;
              sh:='★';
            end;
        1 : if lc[x,y]=0 then sh:='□' else sh:='■';
        3 : sh:='☆';
        4 : sh:='  ';
        5 : begin
              lc[x,y]:=0;
              sh:='  ';
            end;
      end;{case}
      c:=n mod 7+1;
      pxy(x*2+1,y+1,c,sh);
    end;
  procedure ptx(x,y:shortint;n,b:byte);
    var i:byte;
    begin
      for i:=1 to maxk do
        pwz(x+tx[i],y+ty[i],n,b);
    end;
  function fma(x,y:shortint):boolean;
    begin
      fma:=(x>=1)and(x<=maxx)and(y>=1)and(y<=maxy);
    end;
  function flc(x,y:shortint):byte;
    var i,b:byte;
    begin
      b:=0;
      i:=1;
      repeat
        if fma(x+tx[i],y+ty[i]) then
          begin
            if lc[x+tx[i],y+ty[i]]<>0 then b:=2
          end
        else
          b:=3;
        inc(i);
      until (b=3)or(i>maxk);
      flc:=b;
    end;
  procedure pzd;
    var i,t:word;bool:boolean;
    begin
      bool:=true;
      for i:=1 to maxk do
        if not fma(x+ty[i],y+6-tx[i]) then
           bool:=false;
      if bool then
         begin
           ptx(x,y,r,0);
           for i:=1 to maxk do
             begin
               t:=tx[i];tx[i]:=ty[i];ty[i]:=6-t
             end
         end
     end;
  procedure pxc(mx,my:byte);
    var
      lcy:boolean;
    function fflc(tx,ty,mx,my:byte):boolean;
      label loop;
      var
        ix,iy:byte;bool:boolean;
      begin
        bool:=true;
        for ix:=1 to mx do
          for iy:=1 to my do
            if lc[tx+ix-1,ty+iy-1]=0 then
              begin
                bool:=false;
                goto loop
              end;
loop:   fflc:=bool;
      end;
    procedure ppxx(tx,ty,mx,my:byte);
      var
        ix,iy:byte;
      begin
        for ix:=1 to mx do
          for iy:=1 to my do
            lh[tx+ix-1,ty+iy-1]:=5;
      end;
    procedure ppxc(mx,my:byte);
      var
        tx,ty:byte;
      begin
        for tx:=1 to maxx-mx+1 do
          for ty:=1 to maxy-my+1 do
            if fflc(tx,ty,mx,my) then
              begin
                lcy:=true;
                ppxx(tx,ty,mx,my);
              end;
      end;
    procedure ppcc;
      var
        x,y:byte;cjc:string;
      begin
        for x:=1 to maxx do
          for y:=1 to maxy do
            if lh[x,y]=5 then
              begin
                pwz(x,y,7,5);inc(cj);
                str(cj:8,cjc);
                pxy(maxx*2+15,maxy div 3+2,jb,cjc);
                if (cj mod maxcj=0)and(jb+1<=MaxJB) then
                  begin
                    inc(jb);
                    pxy(maxx*2+15,maxy div 3,jb,jbc[jb]);
                  end;
              end;
      end;
    begin
      lcy:=false;
      lh:=l0;
      if mx=my then
        ppxc(mx,my)
      else
        begin
          ppxc(mx,my);
          ppxc(my,mx);
        end;
      if lcy then ppcc;
    end;
  procedure pb1;
    var
      x,y:byte;
    begin
      for x:=1 to maxx do
        for y:=1 to maxy do
          pwz(x,y,0,0)
    end;
  procedure psa;
    var
      x,y:byte;
    begin
      assign(F,FileName);
      Rewrite(F);
      write(F,lc);
      close(F);
    end;
  procedure plo;
    var
      x,y:byte;
    begin
      assign(F,FileName);
      Reset(F);
      Read(F,lc);
      close(F);
      pb1;
    end;
  begin
    pp0;
    randomize;
    rt:=random(maxz)+1;
    repeat
      x:=round(maxx/2)-4;
      y:=round(maxy/2)-4;
      r:=rt;
      rt:=random(maxz)+1;psj(rt);ptx(maxx+7,maxy div 3,rt,3);hxm:=false;
      psj(r);
      repeat
        ptx(x,y,r,1);
        ink:=fke;inkey:=abs(ink);
        ky:=0;kx:=0;
        case ink of
{1}49,{2}50,{3}51,{4}52,{6}54,{7}55,{8}56,{9}57,-75,-77,-72,-80
             : begin
                 if (inkey in [49,52,55])or(ink=-75) then kx:=-1;
                 if (inkey in [51,54,57])or(ink=-77) then kx:=+1;
                 if (inkey in [55,56,57])or(ink=-72) then ky:=-1;
                 if (inkey in [49,50,51])or(ink=-80) then ky:=+1;
                 if flc(x+kx,y+ky)<>3 then
                   begin
                     ptx(x,y,r,0);x:=x+kx;y:=y+ky;ptt(40,10,50);
                   end;
               end;
    {5}53,13 :if flc(x,y)=0 then
                begin
                  ptx(x,y,r,2);
                  hxm:=true;
                  pxc(jbx[jb],jby[jb]);
                end
              else
                ptt(40,10,100);
    32,{0}48 :pzd;
    -60      :psa;
    -61      :plo;
        end;{case}
      until (ink=27)or(hxm);
      psj(rt);ptx(maxx+7,maxy div 3,rt,4);
    until ink=27;
{    psj(maxz);ptx(maxx+7,maxy div 3,rt,3)}
{    writeln(fke);}
  end.

Answer 2

program sysotffk;
  uses
    crt;
  const
    maxk=5;maxz=18;maxx=19;maxy=19;maxtx=5;maxty=5;maxcj=100;maxjb=12;
    px:array[1..maxz,1..maxk] of byte=
((1,2,3,4,5),(1,2,3,4,4),(2,2,3,4,5),(1,2,3,3,4),(2,3,3,4,5),
 (3,2,3,4,3),(2,3,4,2,3),(2,3,4,3,4),(2,2,3,4,3),(4,2,3,4,3),
 (2,3,3,4,4),(2,3,3,3,4),(3,4,3,2,3),(2,4,2,3,4),(2,3,4,3,3),
 (2,3,4,4,4),(1,2,3,3,4),(3,4,5,2,3));
    py:array[1..maxz,1..maxk] of byte=
((3,3,3,3,3),(3,3,3,3,4),(4,3,3,3,3),(3,3,3,4,3),(3,4,3,3,3),
 (2,3,3,3,4),(3,3,3,4,4),(3,3,3,4,4),(2,3,3,3,4),(2,3,3,3,4),
 (2,2,3,3,4),(2,2,3,4,4),(2,2,3,4,4),(2,2,3,3,3),(2,2,2,3,4),
 (2,2,2,3,4),(3,3,3,4,4),(3,3,3,4,4));
    jbc:array[1..maxjb] of string=
('①[4×4]','②[4×5]','③[5×5]','④[5×6]','⑤[6×6]',
 '⑥[6×7]','⑦[7×7]','⑧[7×8]','⑨[8×8]','⑩[8×9]','⑾[9×9]','⑿[9×10]');
    jbx:array[1..maxjb] of byte=(4,4,5,5,6,6,7,7,8,8,9,9);
    jby:array[1..maxjb] of byte=(4,5,5,6,6,7,7,8,8,9,9,10);
    FileName='sysoftfk.dat';
  type
    arby=array[1..maxx,1..maxy] of byte;
  var
    lc,lh,l0:arby;F:file of arby;
    tx:array[1..maxk] of byte;
    ty:array[1..maxk] of byte;
    i,r,rt,jb,inkey:byte;
    x,y,ink,kx,ky:shortint;
    hxm:boolean;
    cj:word;
  procedure ptt(s,d,n:word);
    var
      i:word;
    begin
      for i:=1 to n do
        begin
          sound(200+s*random(i));
          delay(d);
        end;
      NoSound;
    end;
  procedure pxy(x,y,c:byte;sh:string);
    var
      x0,y0:byte;
    begin
      x0:=wherex;y0:=wherey;
      gotoxy(x,y);textcolor(c);write(sh);
      gotoxy(x0,y0);
    end;
  procedure ppm;
    const
      c=7;
    procedure pplx;
      var x:byte;
      begin
        for x:=1 to maxx+2 do
          begin
            pxy(x*2-1,1,c,'━');pxy(x*2-1,maxy+2,c,'━');
          end
      end;
    procedure pply;
      var y:byte;
      begin
        for y:=1 to maxy+2 do
          begin
            pxy(1,y,c,'┃');pxy(maxx*2+3,y,c,'┃');
          end;
      end;
    procedure ppll;
      begin
        pxy(1,            1,c,'┏');
        pxy(1,       maxy+2,c,'┗');
        pxy(maxx*2+3,     1,c,'┓');
        pxy(maxx*2+3,maxy+2,c,'┛');
      end;
    begin
      clrscr;
      pplx;pply;ppll;
    end;
  procedure pp0;
    var
      x,y:byte;cjc:string;
    begin
      ppm;
      for x:=1 to maxx do
        for y:=1 to maxy do
          lc[x,y]:=0;
      l0:=lc;jb:=1;cj:=0;
      str(cj:8,cjc);
      pxy(maxx*2+10,maxy div 3,  jb,'级别:'+jbc[jb]);
      pxy(maxx*2+10,maxy div 3+2,jb,'成绩:'+cjc);
      pxy(1,maxy+4,15,'Zswang (C)1999,10');
    end;
  function fke:shortint;
    var c:char;    begin
      c:=readkey;
      if (c=#0)and(keypressed) then
        begin
          c:=readkey;
          fke:=-ord(c);
        end
      else
        fke:=ord(c)
    end;
  procedure psj(n:byte);
    var i:byte;
    begin
      for i:=1 to maxk do
        begin
          tx[i]:=px[n,i];ty[i]:=py[n,i];
        end;
    end;
  procedure pwz(x,y,n,b:byte);
    var
      sh:string[2];c:byte;
    begin
      case b of
        0 : if lc[x,y]=0 then
              sh:='  '
            else
              begin
                n:=lc[x,y];
                sh:='★';
              end;
        2 : begin
              lc[x,y]:=n;
              sh:='★';
            end;
        1 : if lc[x,y]=0 then sh:='□' else sh:='■';
        3 : sh:='☆';
        4 : sh:='  ';
        5 : begin
              lc[x,y]:=0;
              sh:='  ';
            end;
      end;{case}
      c:=n mod 7+1;
      pxy(x*2+1,y+1,c,sh);
    end;
  procedure ptx(x,y:shortint;n,b:byte);
    var i:byte;
    begin
      for i:=1 to maxk do
        pwz(x+tx[i],y+ty[i],n,b);
    end;
  function fma(x,y:shortint):boolean;
    begin
      fma:=(x>=1)and(x<=maxx)and(y>=1)and(y<=maxy);
    end;
  function flc(x,y:shortint):byte;
    var i,b:byte;
    begin
      b:=0;
      i:=1;
      repeat
        if fma(x+tx[i],y+ty[i]) then
          begin
            if lc[x+tx[i],y+ty[i]]<>0 then b:=2
          end
        else
          b:=3;
        inc(i);
      until (b=3)or(i>maxk);
      flc:=b;
    end;
  procedure pzd;
    var i,t:word;bool:boolean;
    begin
      bool:=true;
      for i:=1 to maxk do
        if not fma(x+ty[i],y+6-tx[i]) then
           bool:=false;
      if bool then
         begin
           ptx(x,y,r,0);
           for i:=1 to maxk do
             begin
               t:=tx[i];tx[i]:=ty[i];ty[i]:=6-t
             end
         end
     end;
  procedure pxc(mx,my:byte);
    var
      lcy:boolean;
    function fflc(tx,ty,mx,my:byte):boolean;
      label loop;
      var
        ix,iy:byte;bool:boolean;
      begin
        bool:=true;
        for ix:=1 to mx do
          for iy:=1 to my do
            if lc[tx+ix-1,ty+iy-1]=0 then
              begin
                bool:=false;
                goto loop
              end;
loop:   fflc:=bool;
      end;
    procedure ppxx(tx,ty,mx,my:byte);
      var
        ix,iy:byte;
      begin
        for ix:=1 to mx do
          for iy:=1 to my do
            lh[tx+ix-1,ty+iy-1]:=5;
      end;
    procedure ppxc(mx,my:byte);
      var
        tx,ty:byte;
      begin
        for tx:=1 to maxx-mx+1 do
          for ty:=1 to maxy-my+1 do
            if fflc(tx,ty,mx,my) then
              begin
                lcy:=true;
                ppxx(tx,ty,mx,my);
              end;
      end;
    procedure ppcc;
      var
        x,y:byte;cjc:string;
      begin
        for x:=1 to maxx do
          for y:=1 to maxy do
            if lh[x,y]=5 then
              begin
                pwz(x,y,7,5);inc(cj);
                str(cj:8,cjc);
                pxy(maxx*2+15,maxy div 3+2,jb,cjc);
                if (cj mod maxcj=0)and(jb+1<=MaxJB) then
                  begin
                    inc(jb);
                    pxy(maxx*2+15,maxy div 3,jb,jbc[jb]);
                  end;
              end;
      end;
    begin
      lcy:=false;
      lh:=l0;
      if mx=my then
        ppxc(mx,my)
      else
        begin
          ppxc(mx,my);
          ppxc(my,mx);
        end;
      if lcy then ppcc;
    end;
  procedure pb1;
    var
      x,y:byte;
    begin
      for x:=1 to maxx do
        for y:=1 to maxy do
          pwz(x,y,0,0)
    end;
  procedure psa;
    var
      x,y:byte;
    begin
      assign(F,FileName);
      Rewrite(F);
      write(F,lc);
      close(F);
    end;
  procedure plo;
    var
      x,y:byte;
    begin
      assign(F,FileName);
      Reset(F);
      Read(F,lc);
      close(F);
      pb1;
    end;
  begin
    pp0;
    randomize;
    rt:=random(maxz)+1;
    repeat
      x:=round(maxx/2)-4;
      y:=round(maxy/2)-4;
      r:=rt;
      rt:=random(maxz)+1;psj(rt);ptx(maxx+7,maxy div 3,rt,3);hxm:=false;
      psj(r);
      repeat
        ptx(x,y,r,1);
        ink:=fke;inkey:=abs(ink);
        ky:=0;kx:=0;
        case ink of
{1}49,{2}50,{3}51,{4}52,{6}54,{7}55,{8}56,{9}57,-75,-77,-72,-80
             : begin
                 if (inkey in [49,52,55])or(ink=-75) then kx:=-1;
                 if (inkey in [51,54,57])or(ink=-77) then kx:=+1;
                 if (inkey in [55,56,57])or(ink=-72) then ky:=-1;
                 if (inkey in [49,50,51])or(ink=-80) then ky:=+1;
                 if flc(x+kx,y+ky)<>3 then
                   begin
                     ptx(x,y,r,0);x:=x+kx;y:=y+ky;ptt(40,10,50);
                   end;
               end;
    {5}53,13 :if flc(x,y)=0 then
                begin
                  ptx(x,y,r,2);
                  hxm:=true;
                  pxc(jbx[jb],jby[jb]);
                end
              else
                ptt(40,10,100);
    32,{0}48 :pzd;
    -60      :psa;
    -61      :plo;
        end;{case}
      until (ink=27)or(hxm);
      psj(rt);ptx(maxx+7,maxy div 3,rt,4);
    until ink=27;
{    psj(maxz);ptx(maxx+7,maxy div 3,rt,3)}
{    writeln(fke);}
  end.