eg9413.pas

一个类似俄罗斯方块的游戏

    OutTextXY(90, 267, 'rotate right');
    OutTextXY(90, 279, 'move right');
    OutTextXY(90, 291, 'drop');
    OutTextXY(90, 303, 'pause/quit');
    OutTextXY(494, 243, 'block style');
    OutTextXY(494, 255, 'change level');
    OutTextXY(494, 267, 'show next');
    OutTextXY(494, 279, 'toggle sound');
    OutTextXY(494, 291, 'extended shapes');
    OutTextXY(494, 303, 'quick exit')
   End; {-drawhelpwin-}

  Procedure refill;

   Var
    i, j	  : integer;

   Begin {-refill-}
    For i := depth DownTo depth-(height-1) Do
     For j := 1 To blockcols Do
      If field[i, j] Then
       PutImage(colmin+(pixelsperblock*(j-1))+1,
		rowmin+(pixelsperblock*(i-1)), filler^, XORPut)
   End; {-refill-}

  Begin {-drawscreen-}
   ClearDevice;
   drawfieldwin;
   GetImage(colmin+1, rowmin, colmax-1, rowmin+pixelsperblock+1, emptyrow^);
   drawnextwin;
   drawscorewin;
   drawhelpwin;
   If height In [1..maxheight] Then
    refill;

   SetVisualPage(page);
   page := 1-page;
   SetActivePage(page);

   ClearDevice;
   drawfieldwin;
   drawnextwin;
   drawscorewin;
   drawhelpwin;
   If height In [1..maxheight] Then
    refill;
  End; {-drawscreen-}

 procedure cleanup;
  forward;

 Procedure play;

  Var
   dropped	  : boolean;
   endgame	  : boolean;
   shape	  : byte;
   orient	  : byte;
   row, col	  : byte;
   color	  : byte;
   style	  : byte;
   ch		  : word;
   k		  : byte;
   t, tdelay	  : longint;

   nextshape	  : byte;
   nextcolor	  : byte;
   nextstyle	  : byte;

   xsize	  : byte;
   xvalue	  : integer;

   oldscore	  : longint;
   oldxvalue	  : integer;
   oldlevel	  : byte;
   oldxshape	  : byte;
   oldrowsclear   : word;

   i, j 	  : integer;
   r, c 	  : byte;

{ procedure fake;
   var
    a, b, c, d	  : pointer;
    i, j	  : integer;
    z		  : bufstr;

   begin
    i := imagesize(0, 0, getmaxx, getmaxy div 2);
    j := imagesize(0, (getmaxy div 2)+1, getmaxx, getmaxy);
    getmem(a, i); getmem(c, i);
    getmem(b, j); getmem(d, j);
    getimage(0, 0, getmaxx, getmaxy div 2, a^);
    getimage(0, (getmaxy div 2)+1, getmaxx, getmaxy, b^);
    setactivepage(1-page);
    getimage(0, 0, getmaxx, getmaxy div 2, c^);
    getimage(0, (getmaxy div 2)+1, getmaxx, getmaxy, d^);
    textmode(c80);
    repeat
     write('C:>');
     readln(z)
    until z = 'exit';
    dographics;
    SetTextStyle(SmallFont, HorizDir, 4);
    setvisualpage(page);
    setactivepage(1-page);
    putimage(0, 0, c^, normalput);
    putimage(0, (getmaxy div 2)+1, d^, normalput);
    setvisualpage(1-page);
    setactivepage(page);
    putimage(0, 0, a^, normalput);
    putimage(0, (getmaxy div 2)+1, b^, normalput);
    freemem(a, i); freemem(b, j); freemem(c, i); freemem(d, j)
   end; }

  Procedure scrolldown(rclr  : byte;
		       var r : rinfotype);

   Var
    rz		  : Array [1..clearlimit] Of integer;
    i, j	  : integer;

   Begin {-scrolldown-}
    For i := 1 To rclr Do
     rz[i] := pixelsperblock*(r[i]-1);

    For i := 1 To rclr Do
     Begin
      GetImage(colmin+1, rowmin, colmax-1, rz[i], scrollptr^);
      PutImage(colmin+1, rowmin, emptyrow^, NormalPut);
      PutImage(colmin+1, rowmin+pixelsperblock, scrollptr^, NormalPut);
      if tones then
       begin
	Sound(cleartone);
	Delay(cleartonedelay);
	NoSound
       end;
      SetVisualPage(page);
      page := 1-page;
      SetActivePage(page);
      PutImage(colmin+1, rowmin, emptyrow^, NormalPut);
      PutImage(colmin+1, rowmin+pixelsperblock, scrollptr^, NormalPut)
     End
   End; {-scrolldown-}

  Procedure drawshape;

   Var
    i		  : integer;
    x, y, x1, y1  : integer;
    p		  : pointer;

   Begin {-drawshape-}
  { If showshadow Then
     FillChar(fieldshadows, SizeOf(fieldshadows), 0); }
    x := colmin+(pixelsperblock*(col-1))+1;
    y := rowmin+(pixelsperblock*(row-1));
    p := styletab[color, style];

    PutImage(x, y, p^, XORPut);
  { If showshadow Then
     Begin
      PutImage(x, rowmax+1, shadows^, XORPut);
      fieldshadows[col] := True
     End; }
    For i := 1 To xsize Do
     Begin
      x1 := x+xshapetab[shape, orient, i, 2];
      y1 := y+xshapetab[shape, orient, i, 1];
      If (y1 >= rowmin) Then
       PutImage(x1, y1, p^, XORPut);
    { If showshadow And Not fieldshadows[col+yshapetab[shape, orient, i, 2]]
      Then
       Begin
	PutImage(x1, rowmax+1, shadows^, XORPut);
	fieldshadows[col+yshapetab[shape, orient, i, 2]] := True
       End }
     End
   End; {-drawshape-}

  Procedure dispscore;
   Begin
    If oldscore <> score Then
     Begin
      SetColor(Black);
      Str(oldscore, buf);
      OutTextXY(522, 72, buf);
      SetColor(colorhigh);
      Str(score, buf);
      OutTextXY(522, 72, buf)
     End;
    If oldxvalue <> xvalue Then
     Begin
      SetColor(Black);
      Str(oldxvalue, buf);
      OutTextXY(522, 84, buf);
      SetColor(colorhigh);
      Str(xvalue, buf);
      OutTextXY(522, 84, buf)
     End;
    If (oldlevel <> level) Or (oldxshape <> xshape) Then
     Begin
      SetColor(Black);
      Str(oldlevel, buf);
      buf := buf+' '+xshapetitles[oldxshape];
      OutTextXY(522, 96, buf);
      SetColor(colorhigh);
      Str(level, buf);
      buf := buf+' '+xshapetitles[xshape];
      OutTextXY(522, 96, buf)
     End;
    If oldrowsclear <> rowsclear Then
     Begin
      SetColor(Black);
      Str(oldrowsclear, buf);
      OutTextXY(522, 108, buf);
      SetColor(colorhigh);
      Str(rowsclear, buf);
      OutTextXY(522, 108, buf)
     End
   End; {-dispscore-}

  Function chk : boolean;

   Var
    f		  : boolean;
    x, y, r	  : shortint;
    i		  : integer;

   Begin {-chk-}
    r := row+1;

    f := field[r, col];
    For i := 1 To xsize Do
     Begin
      y := r+yshapetab[shape, orient, i, 1];
      x := col+yshapetab[shape, orient, i, 2];
      If ((y >= 1) And (y <= depth+1)) And ((x >= 1) And (x <= blockcols))
      Then
       f := f Or field[y, x]
     End;

    chk := f
   End; {-chk-}

  Procedure chkmv(c : shortint);

   Var
    f1, f2	  : boolean;
    x, y	  : shortint;
    i		  : integer;
    xcol	  : shortint;

   Begin {-chkmv-}
    Inc(c, col);

    f1 := (c >= 1) And (c <= blockcols);
    If f1 Then
     f2 := field[row, c]
    Else
     f2 := True;
    For i := 1 To xsize Do
     Begin
      x  := c+yshapetab[shape, orient, i, 2];
      y  := row+yshapetab[shape, orient, i, 1];
      f1 := f1 And ((x >= 1) And (x <= blockcols));
      If f1 And ((y >= 1) And (y <= depth)) Then
       f2 := f2 Or field[y, x]
     End;

    If f1 And (Not f2) Then
     Begin
      xcol := col;
      col := c;
      drawshape;
      SetVisualPage(page);
      page := 1-page;
      SetActivePage(page);
      col := xcol;
      drawshape;
      col := c
     End
   End; {-chkmv-}

  Procedure chkrot(o : byte);

   Var
    f1, f2     : boolean;
    xorient    : byte;
    x, y       : shortint;
    i	       : integer;
    f	       : Text;

   Begin {-chkrot-}
    f1 := True;
    f2 := False;

    For i := 1 To xsize Do
     Begin
      y  := row+yshapetab[shape, o, i, 1];
      x  := col+yshapetab[shape, o, i, 2];
      f1 := f1 And ((x >= 1) And (x <= blockcols)) And
		   (y <= depth);
      If f1 And (y >= 1) Then
       f2 := f2 Or field[y, x]
     End;

    If f1 And (Not f2) Then
     Begin
      xorient := orient;
      orient := o;
      drawshape;
      SetVisualPage(page);
      page := 1-page;
      SetActivePage(page);
      orient := xorient;
      drawshape;
      orient := o
     End
   End; {-chkrot-}

  Procedure dropshape;

   Var
    oldrow, xrow  : byte;

   Begin {-dropshape-}
    oldrow := row;

    While Not chk Do
     Inc(row);
    drawshape;
    SetVisualPage(page);
    page := 1-page;
    SetActivePage(page);
    xrow := row;
    row := oldrow;
    drawshape;
    row := xrow;

    inc(score, level*oldrow+bonus);
  { Inc(score, level*(row-oldrow)+bonus); }
    dropped := True
   End; {-dropshape-}

  Procedure chkrows;

   Var
    f : boolean; i : integer;
    rows       : byte;
    r	       : byte;
    rinfo      : rinfotype;

   Function chkrow(r : byte) : boolean;

    Var
     f	       : boolean;
     i, j      : integer;

    Begin {-chkrow-}
     f := False;
     If r < depth+1 Then
      Begin
       f := field[r, 1];
       i := 2;
       While f And (i <= blockcols) Do
	Begin
	 f := f And field[r, i];
	 Inc(i)
	End;

       If f Then
	Begin
	 Inc(rowsclear);
	 If (level < maxlevel) And (rowsclear = advancetab[level]) Then
	  Begin
	   Inc(level);
	   tdelay := timedelaytab[level]
	  End;
	 Move(field[0, 1], field[1, 1], blockcols*r);
	 Inc(score, level*bonusrowclear+bonus)
	End
      End;
     chkrow := f
    End; {-chkrow-}

   Begin {-chkrows-}
    rows := 0;
    For r := row-2 To row+2 Do
     If chkrow(r) Then
      Begin
       Inc(rows);
       rinfo[rows] := r
      End;

    If rows > 0 Then
     Begin
      scrolldown(rows, rinfo);
      If rows > 1 Then
       Inc(score, level*((rows-1)*bonusmultclear)+bonus);
      f := false;
      I := 1;
      while (not f) and (i <= blockcols) do
       begin
	f := f or field[depth, i];
	inc(i);
       end;
      if not f then
       inc(score, level*bonusempty+bonus);
     End
   End; {-chkrows-}

  Procedure gameover;

   Var
    i, x, y, p	  : integer;
    f		  : boolean;

   Begin {-gameover-}
    f := True;
    For y := 1 To depth Do
     For p := 1 To 2 Do
      Begin
       For x := 1 To blockcols Do
	Begin
	 If Not field[y, x] Then
	   PutImage(colmin+(pixelsperblock*(x-1))+1,
		   rowmin+(pixelsperblock*(y-1)),
		   curtain[f]^, NormalPut);
	 f := Not f
	End;
       SetVisualPage(page);
       page := 1-page;
       SetActivePage(page);
       If Not KeyPressed Then
	Delay(dropdelay)
      End;

    setcolor(0);
    setfillstyle(solidfill, 0);
    bar(colmin+1, rowmin, colmax-1, rowmin+pixelsperblock);
    SetColor(colorhigh);
    SetTextStyle(DefaultFont, HorizDir, 1);
    SetTextJustify(CenterText, TopText);
    OutTextXY(320, rowmin+4, 'Game Over');

    i := 1;
    Repeat
     SetVisualPage(page);
     page := 1-page;
     SetActivePage(page);
     Delay(i*dropdelay);
     Inc(i)
    Until (i > 25) Or (Not Odd(i) And KeyPressed);

    While KeyPressed Do
     ch := getkey
   End; {-gameover-}

  Begin {-play-}
   initlevel := level;
   endgame   := False;
   nextshape := Random(shapemap)+1;
   nextcolor := Random(ncolors)+1;
   nextstyle := Random(nstyles)+1;
   xvalue    := 0;
   tdelay    := timedelaytab[level];

   oldscore	:= 255;
   oldlevel	:= 255;
   oldxvalue	:= 0;
   oldxshape	:= (xshape+1) Mod xshapelevels;
   oldrowsclear := 65535;

 { dispscore;
   SetVisualPage(page);
   page := 1-page;
   SetActivePage(page);
   dispscore;
   oldscore	:= 0;
   oldlevel	:= level;