home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / games / egaint.zip / DISKMANT / EGAINT / AINT9.PAS < prev    next >
Pascal/Delphi Source File  |  1989-07-14  |  31KB  |  1,353 lines
  1. (*
  2.  * Copyright (C) 1989 Eric Ng
  3.  *
  4.  * Aint is free software; you can redistribute it and/or modify it
  5.  * under the terms of the GNU General Public License, Version 1, as
  6.  * published by the Free Software Foundation.
  7.  *
  8.  * This program is distributed in the hope that it will be useful, but
  9.  * without any warranty whatsoever, without even the implied warranties
  10.  * of merchantability or fitness for a particular purpose.  See the
  11.  * enclosed GNU General Public License for more details.
  12.  *
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with egaint; see the file COPYING.  If not, write to:
  15.  *
  16.  *       Free Software Foundation, Inc.
  17.  *       675 Massachusetts Avenue
  18.  *       Cambridge, Massachusetts 02139
  19.  *
  20.  *)
  21.  
  22. (*
  23.  * Aint is now being re-distributed as part of the egaint 0.93.05
  24.  * package.  The complete egaint 0.93.05 package can be obtained at
  25.  * either of the following bulletin board systems:
  26.  *
  27.  *       Tom and Sue McDermet's The Odyssey
  28.  *       A carrier of the SmartNet network
  29.  *       Morris Plains, New Jersey
  30.  *       (201) 984-6574
  31.  *
  32.  *       John Looker's Bandersnatch
  33.  *       Phoenix Net #807/7
  34.  *       Basking Ridge, New Jersey
  35.  *       (201) 766-3801
  36.  *
  37.  * In addition, bug reports, modifications, and other assorted
  38.  * queries can be directed, via Internet e-mail, to
  39.  *
  40.  *       erc@{mars,irss,inis}.njit.edu
  41.  *
  42.  * Please note that since I will be returning to college in the
  43.  * fall, future versions of egaint may not be posted on the above
  44.  * bulletin board systems.  The e-mail address, however, should
  45.  * remain valid.
  46.  *
  47.  *)
  48.  
  49. (*
  50.  * Aint 0.90.01 was originally written in Turbo Pascal 4.0;
  51.  * however, I have just received my upgrade copy of Turbo Pascal 5.5.
  52.  * This new version of the compiler, so far, has not exhibited
  53.  * any problems and compiled without change.  What this means,
  54.  * through interpolation, is that it should (but is not guaranteed to)
  55.  * compile with Turbo Pascal 5.0 (but I can't verify this).
  56.  *
  57.  *)
  58.  
  59. {$B-}
  60. {$D-}
  61. {$I-}
  62. {$L-}
  63. {$R-}
  64. {$S-}
  65. {$V-}
  66.  
  67. PROGRAM aint;
  68.  
  69.  USES
  70.   CRT, DOS;
  71.  
  72.  
  73.  CONST
  74.   id        : STRING[22] = 'aint 0.90.01 Copyright (C) 1989 Eric Ng';
  75.  
  76.   nblocks   = 7;              { different blocks }
  77.   blksiz    = 3;              { block size (minus one) }
  78.  
  79.   norients  = 3;              { different orientations (minus one) }
  80.  
  81.   nblkclrs  = 7;              { different colors for blocks }
  82.   nchars    = 4;              { different characters for blocks }
  83.  
  84.   rowmin    = 1;              { playing field coordinates on the screen }
  85.   rowmax    = 24;
  86.   colmin    = 29;
  87.   colmax    = 50;
  88.  
  89.   pelsiz     = 2;              { element size }
  90.   blkrows   = 24;             { size of playing field in block-rows }
  91.   xblkrows  = 25;             { blkrows plus one (the constant bottom) }
  92.   blkcols   = 10;             { size of playing field in block-columns }
  93.  
  94.   mkrow     = 1;              { initial row for freshly-made blocks }
  95.   mkcol     = 5;              { initial column for freshly-made blocks }
  96.  
  97.   mvup      = -1;             { displacements for movement }
  98.   mvdown    = 1;
  99.   mvleft    = -1;
  100.   mvright   = 1;
  101.  
  102.   maxlvl    = 10;             { maximum level }
  103.  
  104.   maxhgt    = 10;             { maximum height }
  105.   nfadd     = 3;              { random added fill number }
  106.   nfbase    = 3;              { base fill number }
  107.  
  108.   bnsrclr   = 5;              { bonus for clearing a row }
  109.   bnsrmul   = 3;              { bonus for clearing multiple rows }
  110.   bnsnext   = 1;              { bonus for not using show next }
  111.   bnsfran   = 1;              { bonus for frantic levels }
  112.  
  113.   rplvl     = 10;             { rows to clear per level }
  114.  
  115. { swpiter   = 10; }           { number of times to swap pieces }
  116.  
  117.   nhisc     = 15;             { number of high scores }
  118.   hiscnm    = 'aint.rec';     { high score filename }
  119.  
  120.  
  121.  TYPE
  122.   disptype  = (color, mono, plasma);   { different display types }
  123.   msgclrs   = (low, norm, high);       { different display attributes }
  124.   bufstr    = STRING[32];
  125.  
  126.   hiscrec   = RECORD
  127.                score    : longint;
  128.                rclr     : word;
  129.                lvl      : byte;
  130.                hgt      : byte;
  131.                name     : bufstr
  132.               END;
  133.  
  134.  
  135.  CONST
  136.   blktab    : ARRAY[1..nblocks, 1..blksiz, 1..2] OF shortint =
  137.    { bar }    ((( 0, -2), ( 0, -1), ( 0,  1)),
  138.    { box }     (( 0, -1), ( 1, -1), ( 1,  0)),
  139.    { tee }     (( 0, -1), ( 0,  1), ( 1,  0)),
  140.    { zig }     (( 0,  1), ( 1, -1), ( 1,  0)),
  141.    { zag }     (( 0, -1), ( 1,  0), ( 1,  1)),
  142.    { ell }     (( 0, -1), ( 0,  1), (-1, -1)),
  143.    { lel }     (( 0, -1), ( 0,  1), (-1,  1)));
  144.  
  145.   blkclrtab : ARRAY[disptype, 1..nblkclrs] OF byte =
  146.    { color }  ((LightBlue, LightGreen, LightCyan, LightRed,
  147.                 LightMagenta, Yellow, White),
  148.    { mono }    (LightGray, White, LightGray, White, LightGray, White,
  149.                 LightGray),
  150.    { plasma }  (Red, LightGray, Blue, Red, LightGray, Blue, Red));
  151.  
  152.   chartab   : ARRAY[1..nchars] OF char =
  153.               (#176, #177, #178, #219);
  154.  
  155.   msgclrtab : ARRAY[disptype, msgclrs] OF byte =
  156.    { color }  ((LightGray, LightGray, White),
  157.    { mono }    (LightGray, LightGray, White),
  158.    { plasma }  (Blue, Red, LightGray));
  159.  
  160.   tdeltab   : ARRAY[1..maxlvl] OF integer =
  161.               (10, 9, 8, 7, 6, 5, 4, 3, 2, 1);
  162.  
  163.   titletab  : ARRAY[1..nblocks] OF STRING[3] =
  164.               ('Bar', 'Box', 'Tee', 'Zig', 'Zag', 'Ell', 'Lel');
  165.  
  166.  VAR
  167.   field     : ARRAY[0..xblkrows, 1..blkcols] OF boolean;
  168.   xblktab   : ARRAY[1..nblocks, 0..norients, 1..blksiz, 1..2] OF shortint;
  169.   hisc      : ARRAY[1..nhisc] OF hiscrec;
  170.   blkclr    : ARRAY[1..nblkclrs] OF byte;
  171.   blkstats  : ARRAY[1..nblocks] OF word;
  172.  
  173.   rg        : Registers;         { registers }
  174.  
  175.   endrun    : boolean;           { end run flag }
  176.   cheater   : boolean;
  177.  
  178.   clow      : byte;              { message colors }
  179.   cnorm     : byte;
  180.   chigh     : byte;
  181.  
  182.   disp      : disptype;          { display type }
  183.   cst, csb  : byte;              { save for cursor format }
  184.   savemode  : word;              { save for text mode }
  185.  
  186.   trny      : boolean;           { tournament flag }
  187.   trnynum   : byte;              { tournament game number }
  188.  
  189.   shnext    : boolean;           { show next flag }
  190.   shstats   : boolean;           { show stats flag }
  191.  
  192.   blks      : word;
  193.   score     : longint;           { score }
  194.   rclr      : word;              { rows cleared }
  195.   lvl       : byte;              { current level }
  196.   hgt       : byte;              { initial height }
  197.   rank      : integer;           { rank }
  198.  
  199.   fhisc     : FILE OF hiscrec;   { handle for high score file }
  200.  
  201.  
  202.  PROCEDURE csron;
  203.   BEGIN
  204.    rg.ah := $01;
  205.    rg.ch := csb;
  206.    rg.cl := cst;
  207.    Intr($10, rg)
  208.   END;
  209.  
  210.  
  211.  PROCEDURE csroff;
  212.   BEGIN
  213.    rg.ah := $01;
  214.    rg.cx := $ffff;
  215.    Intr($10, rg)
  216.   END;
  217.  
  218.  
  219.  PROCEDURE drawbox;
  220.  
  221.   VAR
  222.    x1, y1   : byte;
  223.    x2, y2   : byte;
  224.    xd, yd   : byte;
  225.    i        : integer;
  226.  
  227.   BEGIN
  228.    x1 := lo(WindMin)+1;                { obtain current window coordinates }
  229.    y1 := hi(WindMin)+1;
  230.    x2 := lo(WindMax)+1;
  231.    y2 := hi(WindMax)+1;
  232.  
  233.    Window(x1-1, y1-1, x2+2, y2+1);
  234.    xd := x2-x1+3;
  235.    yd := y2-y1+3;
  236.  
  237.    GotoXY(1, 1);                       { upper left corner }
  238.    Write(#201);
  239.    GotoXY(1, yd);                      { lower left corner }
  240.    Write(#200);
  241.    GotoXY(xd, 1);                      { upper right corner }
  242.    Write(#187);
  243.    GotoXY(xd, yd);                     { lower right corner }
  244.    Write(#188);
  245.  
  246.    FOR i := 2 TO xd-1 DO
  247.     BEGIN
  248.      GotoXY(i, 1);                     { upper horizontal bar }
  249.      Write(#205);
  250.      GotoXY(i, yd);                    { lower horizontal bar }
  251.      Write(#205)
  252.     END;
  253.  
  254.    FOR i := 2 TO yd-1 DO
  255.     BEGIN
  256.      GotoXY(1, i);                     { left vertical bar }
  257.      Write(#186);
  258.      GotoXY(xd, i);                    { right vertical bar }
  259.      Write(#186)
  260.     END;
  261.  
  262.    Window(x1, y1, x2, y2)              { restore window coordinates }
  263.   END;
  264.  
  265.  
  266.  PROCEDURE wininfo;
  267.   BEGIN
  268.    Window(5, 3, 24, 7)
  269.   END;
  270.  
  271.  
  272.  PROCEDURE winnext;
  273.   BEGIN
  274.    Window(5, 11, 24, 14);
  275.   END;
  276.  
  277.  
  278.  PROCEDURE winstats;
  279.   BEGIN
  280.    Window(55, 3, 76, 13)
  281.   END;
  282.  
  283.  
  284.  PROCEDURE winfield;
  285.   BEGIN
  286.    Window(colmin, rowmin, colmax, rowmax)
  287.   END;
  288.  
  289.  
  290.  FUNCTION gettmr : longint;
  291.  
  292.   VAR
  293.    l        : longint;
  294.  
  295.   BEGIN
  296.    rg.ah := $00;
  297.    Intr($1a, rg);
  298.    l := rg.cx;
  299.    l := (l SHR 16)+rg.dx;
  300.    gettmr := l
  301.   END;
  302.  
  303.  
  304.  PROCEDURE init;
  305.  
  306.   VAR
  307.    i, j     : integer;
  308.    b        : STRING[1];
  309.  
  310.   BEGIN
  311.    disp := color;
  312.    b := Copy(ParamStr(1), 1, 1);
  313.    IF ParamCount > 0 THEN
  314.     CASE b[1] OF
  315.      'C', 'c':           disp := color;
  316.      'B', 'b', 'M', 'm': disp := mono;
  317.      'P', 'p':           disp := plasma
  318.     END;
  319.  
  320.    FOR i := 1 TO nblocks DO
  321.     FOR j := 1 TO blksiz DO
  322.      BEGIN
  323.       xblktab[i, 0, j, 1] :=  blktab[i, j, 1];     { north }
  324.       xblktab[i, 0, j, 2] :=  blktab[i, j, 2];
  325.       xblktab[i, 1, j, 1] :=  blktab[i, j, 2];     { east }
  326.       xblktab[i, 1, j, 2] := -blktab[i, j, 1];
  327.       xblktab[i, 2, j, 1] := -blktab[i, j, 1];     { south }
  328.       xblktab[i, 2, j, 2] := -blktab[i, j, 2];
  329.       xblktab[i, 3, j, 1] := -blktab[i, j, 2];     { west }
  330.       xblktab[i, 3, j, 2] :=  blktab[i, j, 1]
  331.      END;
  332.  
  333.    FOR i := 1 TO nblkclrs DO
  334.     blkclr[i] := blkclrtab[disp, i];
  335.  
  336.    clow := msgclrtab[disp, low];
  337.    cnorm := msgclrtab[disp, norm];
  338.    chigh := msgclrtab[disp, high];
  339.  
  340.    FillChar(hisc, sizeof(hisc), 0);
  341.  
  342.    Assign(fhisc, hiscnm);
  343.    Reset(fhisc);
  344.  
  345.    i := 1;
  346.    IF IOResult = 0 THEN
  347.     BEGIN
  348.      WHILE (i <= nhisc) AND (NOT Eof(fhisc)) DO
  349.       BEGIN
  350.        Read(fhisc, hisc[i]);
  351.        i := i+1
  352.       END;
  353.      Close(fhisc)
  354.     END;
  355.  
  356.    FOR j := i TO nhisc DO
  357.     hisc[j].score := 0;
  358.  
  359.    savemode := LastMode;
  360.    TextMode(CO80);
  361.  
  362.    rg.ah := $0f;
  363.    Intr($10, rg);
  364.    rg.ah := $03;
  365.    Intr($10, rg);
  366.    cst := rg.ch;
  367.    csb := rg.cl;
  368.  
  369.    trny    := FALSE;
  370.    trnynum := 0;
  371.    lvl     := 5;
  372.    hgt     := 0;
  373.    shnext  := TRUE;
  374.    shstats := TRUE
  375.   END;
  376.  
  377.  
  378.  PROCEDURE initgame;
  379.  
  380.   VAR
  381.    i, j     : integer;
  382.  { k, l, m  : integer;
  383.    n        : integer;
  384.    tmp      : shortint;
  385.    tmps     : STRING[3]; }
  386.  
  387.   PROCEDURE getoptions;
  388.  
  389.    VAR
  390.     c       : byte;
  391.     k       : char;
  392.  
  393.    PROCEDURE opening;
  394.     BEGIN
  395.      TextColor(cnorm);
  396.      TextBackground(Black);
  397.      ClrScr;
  398.  
  399.      GotoXY(20, 1);
  400.      TextColor(chigh);
  401.      Write('aint 0.90.01  Copyright (C) 1989 Eric Ng');
  402.  
  403.      GotoXY(6, 2);
  404.      TextColor(cnorm);
  405.      Write('Aint is free software; you can redistribute it and/or modify it under');
  406.      GotoXY(6, 3);
  407.      Write('the terms of the GNU General Public License, Version 1, as published');
  408.      GotoXY(6, 4);
  409.      Write('by the Free Software Foundation.  This program comes without any');
  410.      GotoXY(6, 5);
  411.      Write('warranty, without even the implied warranties of merchantability or');
  412.      GotoXY(6, 6);
  413.      Write('fitness for a particular purpose.  See the file COPYING for details.');
  414.  
  415.      GotoXY(11, 24);
  416.      TextColor(clow);
  417.      Write('Use ');
  418.      TextColor(chigh);
  419.      Write('J');
  420.      TextColor(clow);
  421.      Write(' for up, ');
  422.      TextColor(chigh);
  423.      Write('K');
  424.      TextColor(clow);
  425.      Write(' to rotate, ');
  426.      TextColor(chigh);
  427.      Write('L');
  428.      TextColor(clow);
  429.      Write(' for down, and ');
  430.      TextColor(chigh);
  431.      Write('SPACE');
  432.      TextColor(clow);
  433.      Write(' when done')
  434.     END;
  435.  
  436.    PROCEDURE showoptions;
  437.  
  438.     PROCEDURE showflag(f : boolean);
  439.      BEGIN
  440.       IF f THEN
  441.        Write('Yes')
  442.       ELSE
  443.        Write('No ')
  444.      END;
  445.  
  446.     BEGIN
  447.      TextColor(chigh);
  448.      GotoXY(20, 2);                    { tournament }
  449.      showflag(trny);
  450.      GotoXY(20, 4);                    { tournament game number }
  451.      Write(trnynum, '':2);
  452.      GotoXY(20, 6);                    { initial level }
  453.      Write(lvl, '':2);
  454.      GotoXY(20, 8);                    { initial height }
  455.      Write(hgt, '':2);
  456.      GotoXY(20, 10);                   { show next }
  457.      showflag(shnext);
  458.      GotoXY(20, 12);                   { show statistics }
  459.      showflag(shstats)
  460.     END;
  461.  
  462.    PROCEDURE drawoptions;
  463.     BEGIN
  464.      opening;
  465.  
  466.      Window(28, 9, 51, 21);
  467.      TextColor(clow);
  468.      drawbox;
  469.  
  470.      TextColor(cnorm);
  471.      GotoXY(1, 2);
  472.      Write('Tournament:':18);
  473.      GotoXY(1, 4);
  474.      Write('Tournament Game:':18);
  475.      GotoXY(1, 6);
  476.      Write('Initial Level:':18);
  477.      GotoXY(1, 8);
  478.      Write('Initial Height:':18);
  479.      GotoXY(1, 10);
  480.      Write('Show Next:':18);
  481.      GotoXY(1, 12);
  482.      Write('Show Statistics:':18);
  483.  
  484.      showoptions
  485.     END;
  486.  
  487.    PROCEDURE rotateopt;
  488.     BEGIN
  489.      CASE c OF
  490.        2: trny := NOT trny;
  491.        4: trnynum := (trnynum+1) MOD 256;
  492.        6: lvl := (lvl MOD (2*maxlvl))+1;
  493.        8: hgt := (hgt+1) MOD (maxhgt+1);
  494.       10: shnext := NOT shnext;
  495.       12: shstats := NOT shstats
  496.      END;
  497.      showoptions
  498.     END;
  499.  
  500.    BEGIN
  501.     drawoptions;
  502.     c := 2;
  503.  
  504.     REPEAT
  505.      TextColor(clow+Blink);
  506.      GotoXY(19, c);
  507.      Write(#26);
  508.      TextColor(clow);
  509.  
  510.      REPEAT UNTIL KeyPressed;
  511.      k := ReadKey;
  512.      GotoXY(19, c);
  513.      Write(#32);
  514.  
  515.      CASE k OF
  516.       'J', 'j': IF c < 4 THEN
  517.                  c := 12
  518.                 ELSE
  519.                  c := c-2;
  520.       'K', 'k': rotateopt;
  521.       'L', 'l': IF c > 10 THEN
  522.                  c := 2
  523.                 ELSE
  524.                  c := c+2
  525.      END;
  526.     UNTIL k = #32;
  527.     Window(1, 1, 80, 25);
  528.    END;
  529.  
  530.   BEGIN
  531.    csroff;
  532.  
  533.    getoptions;
  534.  
  535.    FillChar(field, sizeof(field)-blkcols, 0);
  536.    FillChar(field[xblkrows, 1], blkcols, 1);
  537.  
  538.    FillChar(blkstats, sizeof(blkstats), 0);
  539.    blks := 0;
  540.  
  541.    IF trny THEN
  542.     RandSeed := trnynum
  543.    ELSE
  544.     Randomize;
  545.  
  546.  { FOR n := 1 TO swpiter DO
  547.     FOR i := 1 TO nblocks DO
  548.      BEGIN
  549.       j := Random(nblocks)+1;
  550.  
  551.       FOR k := 0 TO 3 DO
  552.        FOR l := 1 TO blksiz DO
  553.         FOR m := 1 TO 2 DO
  554.          BEGIN
  555.           tmp := xblktab[i, k, l, m];
  556.           xblktab[i, k, l, m] := xblktab[j, k, l, m];
  557.           xblktab[j, k, l, m] := tmp
  558.          END;
  559.  
  560.       tmps        := titletab[i];
  561.       titletab[i] := titletab[j];
  562.       titletab[j] := tmps;
  563.      END }
  564.    END;
  565.  
  566.  PROCEDURE drawscreen;
  567.  
  568.   VAR
  569.    i        : integer;
  570.  
  571.   BEGIN
  572.    ClrScr;
  573.    wininfo;                            { score box }
  574.    TextColor(clow);
  575.    drawbox;
  576.    TextColor(cnorm);
  577.    GotoXY(3, 2);
  578.    Write('Score:');
  579.    GotoXY(3, 3);
  580.    Write('Level:');
  581.    GotoXY(4, 4);
  582.    Write('Rows:');
  583.  
  584.    IF shnext THEN                      { show next box }
  585.     BEGIN
  586.      winnext;
  587.      TextColor(clow);
  588.      drawbox;
  589.      GotoXY(8, 1);
  590.      Write(#179);
  591.      GotoXY(8, 2);
  592.      Write(#179);
  593.      TextColor(chigh);
  594.      Write('  aint 0.9');
  595.      TextColor(clow);
  596.      GotoXY(8, 3);
  597.      Write(#179);
  598.      TextColor(chigh);
  599.      Write('  (C) 1989');
  600.      TextColor(clow);
  601.      GotoXY(8, 4);
  602.      Write(#179)
  603.     END;
  604.  
  605.    IF shstats THEN                     { show stats box }
  606.     BEGIN
  607.      winstats;
  608.      TextColor(clow);
  609.      drawbox;
  610.      TextColor(cnorm);
  611.      FOR i := 1 TO nblocks DO
  612.       BEGIN
  613.        GotoXY(2, 1+I);
  614.        Write(titletab[I])
  615.       END;
  616.      GotoXY(2, 9);
  617.      Write(#196+#196+#196+#196+#196+#196+#196+#196);
  618.      GotoXY(2, 10);
  619.      Write('Sum');
  620.      TextColor(clow);
  621.      FOR i := 1 TO 11 DO
  622.       BEGIN
  623.        GotoXY(11, i);
  624.        Write(#179)
  625.       END;
  626.      TextColor(chigh);
  627.      GotoXY(13, 4);
  628.      Write('J');
  629.      TextColor(cnorm);
  630.      Write('Left':8);
  631.      TextColor(chigh);
  632.      GotoXY(13, 5);
  633.      Write('K');
  634.      TextColor(cnorm);
  635.      Write('Rotate':8);
  636.      TextColor(chigh);
  637.      GotoXY(13, 6);
  638.      Write('L');
  639.      TextColor(cnorm);
  640.      Write('Right':8);
  641.      TextColor(chigh);
  642.      GotoXY(13, 7);
  643.      Write('Sp');
  644.      TextColor(cnorm);
  645.      Write('Drop':7);
  646.      TextColor(chigh);
  647.      GotoXY(13, 8);
  648.      Write('^\');
  649.      TextColor(cnorm);
  650.      Write('Quit':7)
  651.     END;
  652.  
  653.     Window(colmin, rowmin+1, colmax, rowmax);
  654.     drawbox;
  655.     Window(colmin-1, rowmin, colmax+1, rowmax);
  656.     GotoXY(1, 1);
  657.     Write(#186, '':colmax-colmin+1, #186);
  658.     winfield
  659.   END;
  660.  
  661. {
  662.  
  663. 1                           |11223344556677889900|
  664. 2  +12345678901234567890+   |                    |   +1234567890123456789012+
  665. 3  1                    |   |                    |   |                      |
  666. 4  2  Score: 214748364  |   |                    |   | Bar 0000             |
  667. 5  3  Level: 00         |   |                    |   | Box 0000   J    Left |
  668. 6  4   Rows: 0000       |   |                    |   | Tee 0000   K  Rotate |
  669. 7  5                    |   |                    |   | Zig 0000   L   Right |
  670. 8  +--------------------+   |                    |   | Zag 0000   Sp   Drop |
  671. 9                           |                    |   | Ell 0000   Esc  Quit |
  672. 0  +1234567-123456789012+   |                    |   | Lel 0000             |
  673. 1  |       |            |   |                    |   | --------             |
  674. 2  |  XXX  |  aint 0.9  |   |                    |   | Sum 0000             |
  675. 3  |    X  |  (C) 1989  |   |                    |   |                      |
  676. 4  |       |            |   |                    |   +----------------------+
  677. 5  +--------------------+   |                    |
  678. 6                           |                    |
  679. 7                           |                    |
  680. 8                           |                    |
  681. 9                           |                    |
  682. 0                           |                    |
  683. 1                           |                    |
  684. 2                           +--------------------+
  685.  
  686. }
  687.  
  688.  
  689.  PROCEDURE play;
  690.  
  691.   VAR
  692.    bombed   : boolean;
  693.    cheater  : boolean;
  694.    dropped  : boolean;
  695.    endgame  : boolean;
  696.    frantic  : boolean;
  697.    blk      : byte;
  698.    nextblk  : byte;
  699.    orient   : byte;
  700.    row, col : byte;
  701.    color    : byte;
  702.    ch       : char;
  703.    kb       : char;
  704.    t, tdel  : longint;
  705.    bns      : integer;
  706.  
  707.   PROCEDURE fillfield;
  708.  
  709.    VAR
  710.     c       : char;
  711.     i, j    : integer;
  712.     k, l    : integer;
  713.  
  714.    BEGIN
  715.     FOR i := blkrows DOWNTO blkrows-(hgt-1) DO
  716.      BEGIN
  717.       k := Random(nfadd)+nfbase;
  718.       FOR j := 1 TO k DO
  719.        BEGIN
  720.         l := Random(blkcols)+1;
  721.         field[i, l] := TRUE;
  722.         TextColor(blkclr[Random(nblkclrs)+1]);
  723.         GotoXY(pelsiz*l, i);
  724.         c := chartab[Random(nchars)+1];
  725.         Write(c+c)
  726.        END
  727.      END
  728.    END;
  729.  
  730.   PROCEDURE mkblk;
  731.    BEGIN
  732.     blk     := nextblk;
  733.     orient  := 0;
  734.     row     := mkrow;
  735.     col     := mkcol;
  736.     ch      := chartab[Random(nchars)+1];
  737.     color   := blkclr[Random(nblkclrs)+1];
  738.     nextblk := Random(nblocks)+1
  739.    END;
  740.  
  741.   PROCEDURE drawblk(ch: char);
  742.  
  743.    VAR
  744.     r, c    : byte;
  745.     i       : integer;
  746.  
  747.    BEGIN
  748.     TextColor(color);
  749.     GotoXY(pelsiz*col, row);
  750.     Write(ch+ch);
  751.     FOR i := 1 TO blksiz DO
  752.      BEGIN
  753.       c := col+xblktab[blk, orient, i, 2];
  754.       r := row+xblktab[blk, orient, i, 1];
  755.       IF (r IN [1..blkrows]) AND (c IN [1..blkcols]) THEN
  756.        BEGIN
  757.         GotoXY(pelsiz*c, r);
  758.         Write(ch+ch)
  759.        END
  760.      END
  761.    END;
  762.  
  763.   PROCEDURE dispinfo;
  764.    BEGIN
  765.     wininfo;
  766.     IF cheater THEN
  767.      TextColor(chigh+Blink)
  768.     ELSE
  769.      TextColor(chigh);
  770.     GotoXY(10, 2);
  771.     Write(score);
  772.     TextColor(chigh);
  773.     GotoXY(10, 3);
  774.     Write(lvl, '':1);
  775.     GotoXY(10, 4);
  776.     Write(rclr);
  777.     winfield
  778.    END;
  779.  
  780.   FUNCTION check(m : shortint) : boolean;
  781.  
  782.    VAR
  783.     f       : boolean;
  784.     i       : integer;
  785.     y       : byte;
  786.  
  787.    BEGIN
  788.     m := row+m;
  789.  
  790.     f := field[m, col];
  791.     FOR i := 1 TO blksiz DO
  792.      BEGIN
  793.       y := m+xblktab[blk, orient, i, 1];
  794.       IF y IN [1..xblkrows] THEN
  795.        f := f OR field[y, col+xblktab[blk, orient, i, 2]]
  796.      END;
  797.     check := f
  798.    END;
  799.  
  800.   PROCEDURE checkmv(m : shortint);
  801.  
  802.    VAR
  803.     f1, f2  : boolean;
  804.     x       : byte;
  805.     i       : integer;
  806.  
  807.    BEGIN
  808.     m := col+m;
  809.  
  810.     f1 := m IN [1..blkcols];
  811.     IF f1 THEN
  812.      f2 := field[row, m]
  813.     ELSE
  814.      f2 := TRUE;
  815.     FOR i := 1 TO blksiz DO
  816.      BEGIN
  817.       x := m+xblktab[blk, orient, i, 2];
  818.       f1 := f1 AND (x IN [1..blkcols]);
  819.       IF f1 THEN
  820.        f2 := f2 OR field[row+xblktab[blk, orient, i, 1], x]
  821.      END;
  822.  
  823.     IF f1 AND (NOT f2) THEN
  824.      BEGIN
  825.       drawblk(#32);
  826.       col := m;
  827.       drawblk(ch)
  828.      END
  829.    END;
  830.  
  831.   PROCEDURE checkrot;
  832.  
  833.    VAR
  834.     f1, f2  : boolean;
  835.     o, x    : byte;
  836.     i       : integer;
  837.  
  838.    BEGIN
  839.     o  := (orient+1) MOD 4;
  840.     f1 := TRUE;
  841.     f2 := FALSE;
  842.  
  843.     FOR i := 1 TO blksiz DO
  844.      BEGIN
  845.       x  := col+xblktab[blk, o, i, 2];
  846.       f1 := f1 AND (x IN [1..blkcols]);
  847.       IF f1 THEN
  848.        f2 := f2 OR field[row+xblktab[blk, o, i, 1], x]
  849.      END;
  850.  
  851.     IF f1 AND (NOT f2) THEN
  852.      BEGIN
  853.       drawblk(#32);
  854.       orient := o;
  855.       drawblk(ch)
  856.      END
  857.    END;
  858.  
  859.   PROCEDURE checkpoly;
  860.  
  861.    VAR
  862.     f1, f2  : boolean;
  863.     p, x, y : byte;
  864.     i       : integer;
  865.  
  866.    BEGIN
  867.     p  := (blk MOD nblocks)+1;
  868.     f1 := TRUE;
  869.     f2 := FALSE;
  870.  
  871.     FOR i := 1 TO blksiz DO
  872.      BEGIN
  873.       x  := col+xblktab[p, orient, i, 2];
  874.       y  := row+xblktab[p, orient, i, 1];
  875.       f1 := f1 AND ((x IN [1..blkcols]) AND (y IN [1..blkrows]));
  876.       IF f1 THEN
  877.        f2 := f2 OR field[y, x]
  878.      END;
  879.  
  880.     IF f1 AND (NOT f2) THEN
  881.      BEGIN
  882.       drawblk(#32);
  883.       blk := p;
  884.       drawblk(ch)
  885.      END
  886.    END;
  887.  
  888.   PROCEDURE mvblk(m : shortint);
  889.    BEGIN
  890.     IF NOT check(m) THEN
  891.      BEGIN
  892.       drawblk(#32);
  893.       row := row+m;
  894.       drawblk(ch)
  895.      END
  896.    END;
  897.  
  898.   PROCEDURE dropblk;
  899.    BEGIN
  900.     score := score+lvl*(blkrows-row)+hgt+bns;
  901.     drawblk(#32);
  902.     WHILE NOT check(mvdown) DO
  903.      Inc(row, mvdown);
  904.     drawblk(ch);
  905.     dropped := TRUE
  906.    END;
  907.  
  908.   PROCEDURE plantblk;
  909.  
  910.    VAR
  911.     i       : integer;
  912.     y       : byte;
  913.  
  914.    BEGIN
  915.     field[row, col] := TRUE;
  916.     FOR i := 1 TO blksiz DO
  917.      BEGIN
  918.       y := row+xblktab[blk, orient, i, 1];
  919.       IF y IN [1..blkrows] THEN
  920.        field[y, col+xblktab[blk, orient, i, 2]] := TRUE
  921.      END
  922.    END;
  923.  
  924.   PROCEDURE checkrows;
  925.  
  926.    VAR
  927.     i       : integer;
  928.     r       : byte;
  929.  
  930.    FUNCTION checkrow(r : integer) : boolean;
  931.  
  932.     VAR
  933.      f      : boolean;
  934.      i, j   : integer;
  935.  
  936.     BEGIN
  937.      r := row+r;
  938.  
  939.      IF r < xblkrows THEN
  940.       BEGIN
  941.        f := field[r, 1];
  942.        i := 2;
  943.        WHILE f AND (i <= blkcols) DO
  944.         BEGIN
  945.          f := f AND field[r, i];
  946.          i := i+1
  947.         END;
  948.  
  949.        IF f THEN
  950.         BEGIN
  951.          rclr := rclr+1;
  952.          IF (lvl < maxlvl) AND (rclr = ((lvl+1)*rplvl)) THEN
  953.           BEGIN
  954.            lvl  := lvl+1;
  955.            tdel := tdeltab[lvl]
  956.           END;
  957.          score := score+lvl*bnsrclr*r+hgt+bns;
  958.          Move(field[0, 1], field[1, 1], blkcols*r);
  959.          FillChar(field, blkcols, 0);
  960.  
  961.          rg.ax := $0701;
  962.          rg.bh := $07;
  963.          rg.ch := 1;
  964.          rg.cl := colmin;
  965.          rg.dh := r-1;
  966.          rg.dl := colmax-1;
  967.          Intr($10, rg);
  968.  
  969.         END
  970.       END;
  971.      checkrow := f
  972.     END;
  973.  
  974.    BEGIN
  975.     r := 0;
  976.     FOR i := -2 TO 2 DO
  977.      IF checkrow(i) THEN
  978.       r := r+1;
  979.  
  980.     IF r > 1 THEN
  981.      score := score+lvl*bnsrmul*r+hgt+bns
  982.    END;
  983.  
  984.   PROCEDURE dispnext(ch : char);
  985.  
  986.    VAR
  987.     i       : integer;
  988.  
  989.    BEGIN
  990.     winnext;
  991.     TextColor(cnorm);
  992.     GotoXY(4, 2);
  993.     Write(ch);
  994.     FOR i := 1 TO blksiz DO
  995.      BEGIN
  996.       GotoXY(4+xblktab[nextblk, 0, i, 2], 2+xblktab[nextblk, 0, i, 1]);
  997.       Write(ch)
  998.      END;
  999.     winfield
  1000.    END;
  1001.  
  1002.   PROCEDURE dispstats(b: integer);
  1003.    BEGIN
  1004.     blkstats[b] := blkstats[b]+1;
  1005.     blks := blks+1;
  1006.  
  1007.     winstats;
  1008.     TextColor(chigh);
  1009.     GotoXY(6, 1+b);
  1010.     Write(blkstats[b]:4);
  1011.     GotoXY(6, 10);
  1012.     Write(blks:4);
  1013.     winfield
  1014.    END;
  1015.  
  1016.   PROCEDURE blitzblk;
  1017.  
  1018.    VAR
  1019.     x, y    : byte;
  1020.  
  1021.    BEGIN
  1022.     IF Random(maxlvl) < lvl THEN
  1023.      BEGIN
  1024.       x := Random(blkcols)+1;
  1025.       y := Random(blkrows)+1;
  1026.       IF field[y, x] THEN
  1027.        BEGIN
  1028.         field[y, x] := FALSE;
  1029.         GotoXY(pelsiz*x, y);
  1030.         Write(#32+#32)
  1031.        END
  1032.      END
  1033.    END;
  1034.  
  1035. { PROCEDURE smartbomb;
  1036.  
  1037.    BEGIN
  1038.     Move(field[0, 1], field[1, 1], blkcols*blkrows);
  1039.     FillChar(field, blkcols, 0);
  1040.  
  1041.     rg.ax := $0701;
  1042.     rg.bh := $07;
  1043.     rg.ch := 1;
  1044.     rg.cl := colmin;
  1045.     rg.dh := blkrows-1;
  1046.     rg.dl := colmax-1;
  1047.     Intr($10, rg);
  1048.  
  1049.     bombed := FALSE
  1050.    END; }
  1051.  
  1052.   PROCEDURE smartbomb;
  1053.  
  1054.    VAR
  1055.     x, y    : byte;
  1056.  
  1057.    BEGIN
  1058.     FOR y := row-2 TO row+2 DO
  1059.      FOR x := col-2 TO col+2 DO
  1060.       IF (y IN [1..blkrows]) AND (x IN [1..blkcols]) THEN
  1061.        BEGIN
  1062.         field[y, x] := FALSE;
  1063.         GotoXY(pelsiz*x, y);
  1064.         Write(#32+#32)
  1065.        END;
  1066.  
  1067.     bombed := FALSE;
  1068.    END;
  1069.  
  1070.   PROCEDURE nuke;
  1071.  
  1072.    VAR
  1073.     x, y    : byte;
  1074.  
  1075.    BEGIN
  1076.     FOR y := 1 TO blkrows DO
  1077.      FOR x := 1 TO blkcols DO
  1078.       field[y, x] := FALSE;
  1079.     ClrScr;
  1080.     IF shnext THEN
  1081.      dispnext(#32);
  1082.     mkblk;
  1083.     IF shnext THEN
  1084.      dispnext(chartab[nchars]);
  1085.     IF shstats THEN
  1086.      dispstats(blk);
  1087.     drawblk(ch)
  1088.    END;
  1089.  
  1090.   BEGIN
  1091.    IF hgt <> 0 THEN
  1092.     fillfield;
  1093.  
  1094.    rclr    := 0;
  1095.    score   := 0;
  1096.    bombed  := FALSE;
  1097.    cheater := FALSE;
  1098.    endgame := FALSE;
  1099.  
  1100.    IF NOT shnext THEN
  1101.     bns := bnsnext
  1102.    ELSE
  1103.     bns := 0;
  1104.    IF lvl > maxlvl THEN
  1105.     BEGIN
  1106.      lvl     := lvl-maxlvl;
  1107.      bns     := bns+bnsfran;
  1108.      frantic := TRUE
  1109.     END
  1110.    ELSE
  1111.     frantic := FALSE;
  1112.  
  1113.    tdel    := tdeltab[lvl];
  1114.    nextblk := Random(nblocks)+1;
  1115.  
  1116.    REPEAT
  1117.     dropped := FALSE;
  1118.  
  1119.     IF shnext THEN
  1120.      dispnext(#32);
  1121.     mkblk;
  1122.     IF shnext THEN
  1123.      dispnext(chartab[nchars]);
  1124.     IF shstats THEN
  1125.      dispstats(blk);
  1126.     drawblk(ch);
  1127.  
  1128.     IF check(mvdown) THEN
  1129.      endgame := TRUE
  1130.     ELSE
  1131.      BEGIN
  1132.       REPEAT
  1133.        IF frantic THEN
  1134.         blitzblk;
  1135.        t := gettmr;
  1136.  
  1137.        REPEAT
  1138.         REPEAT UNTIL KeyPressed OR (gettmr > t+tdel);
  1139.         IF KeyPressed THEN
  1140.          BEGIN
  1141.           kb := ReadKey;
  1142.           CASE kb OF
  1143.     { ^A } #1:       mvblk(mvup);
  1144.     { ^J } #10:      tdel := 2*tdel;
  1145.     { ^K } #11:      checkpoly;
  1146.     { ^L } #12:      BEGIN
  1147.                       lvl := (lvl MOD maxlvl)+1;
  1148.                       tdel := tdeltab[lvl]
  1149.                      END;
  1150.     { ^Q } #17:      BEGIN
  1151.                       color := color+Blink;
  1152.                       bombed := TRUE
  1153.                      END;
  1154.     { ^Z } #26:      mvblk(mvdown);
  1155.     { ^\ } #28:      BEGIN
  1156.                       dropblk;
  1157.                       endgame := TRUE
  1158.                      END;
  1159.     { Sp } #32:      dropblk;
  1160.            'J', 'j': checkmv(mvleft);
  1161.            'K', 'k': checkrot;
  1162.            'L', 'l': checkmv(mvright);
  1163.    { ^Bs } #127:     nuke
  1164.           END;
  1165.           IF (NOT cheater) AND (kb IN [#1, #10, #11, #12, #17, #26, #127]) THEN
  1166.            cheater := TRUE
  1167.          END
  1168.        UNTIL (gettmr > t+tdel) OR dropped;
  1169.  
  1170.        IF NOT dropped THEN
  1171.         mvblk(mvdown)
  1172.       UNTIL check(mvdown);
  1173.  
  1174.       plantblk;
  1175.       checkrows;
  1176.  
  1177.       IF bombed THEN
  1178.        smartbomb;
  1179.  
  1180.       dispinfo;
  1181.       t := gettmr;
  1182.       REPEAT UNTIL (gettmr > t+tdel);
  1183.  
  1184.       WHILE KeyPressed DO
  1185.        kb := ReadKey
  1186.      END
  1187.    UNTIL endgame;
  1188.  
  1189.    IF cheater THEN
  1190.     score := 0;
  1191.  
  1192.    REPEAT UNTIL KeyPressed;
  1193.    kb := ReadKey
  1194.   END;
  1195.  
  1196.  
  1197.  PROCEDURE cleanup;
  1198.  
  1199.   VAR
  1200.    c        : char;
  1201.    i, j     : integer;
  1202. {
  1203.  
  1204.   +123456789012345678901234567890123456789012345678901234567890123456+
  1205.   1 Rank |  Score  | Level | Rows | Name                             |
  1206.   2------------------------------------------------------------------|
  1207.   3   1  | 0000000 |  01   | 0000 | 12345678901234567890123456789012 |
  1208.   4   2
  1209.   5   3
  1210.   6   4
  1211.   7   5
  1212.   8   6
  1213.   9   7
  1214.   0   8
  1215.   1   9
  1216.   2  10
  1217.   3  11
  1218.   4  12
  1219.   5  13
  1220.   6  14
  1221.   7  15
  1222.  
  1223. }
  1224.  
  1225.   BEGIN
  1226.    Window(1, 1, 80, 25);
  1227.    ClrScr;
  1228.    csron;
  1229.  
  1230.    rank := 0;
  1231.  
  1232.    i := 1;
  1233.    WHILE (i <= nhisc) AND (hisc[i].score >= score) DO
  1234.     i := i+1;
  1235.    IF i <= nhisc THEN
  1236.     BEGIN
  1237.      rank := i;
  1238.      FOR j := nhisc-1 DOWNTO i DO
  1239.       hisc[j+1] := hisc[j];
  1240.      hisc[i].score := score;
  1241.      hisc[i].lvl   := lvl;
  1242.      hisc[i].rclr  := rclr;
  1243.      TextColor(cnorm);
  1244.      Write('Enter your name for posterity: ');
  1245.      TextColor(chigh);
  1246.      ReadLn(hisc[i].name)
  1247.     END;
  1248.  
  1249.    TextColor(chigh);
  1250.    ClrScr;
  1251.    GotoXY(30, 2);
  1252.    Write('The Glorious Fifteen');
  1253.  
  1254.    Window(7, 5, 73, 5+nhisc+1);
  1255.    TextColor(clow);
  1256.    drawbox;
  1257.  
  1258.    TextColor(cnorm);
  1259.    GotoXY(1, 1);
  1260.    Write(' Rank    Score    Level   Rows   Name');
  1261.  
  1262.    TextColor(clow);
  1263.    FOR i := 1 TO nhisc+2 DO
  1264.     BEGIN
  1265.      GotoXY(7, i);
  1266.      Write(#179);
  1267.      GotoXY(17, i);
  1268.      Write(#179);
  1269.      GotoXY(25, i);
  1270.      Write(#179);
  1271.      GotoXY(32, i);
  1272.      Write(#179)
  1273.     END;
  1274.  
  1275.    TextColor(clow);
  1276.    GotoXY(1, 2);
  1277.    FOR i := 7 TO 73 DO
  1278.     Write(#196);
  1279.  
  1280.    FOR i := 1 TO nhisc DO
  1281.     BEGIN
  1282.      IF rank = i THEN
  1283.       BEGIN
  1284.        TextBackground(chigh);
  1285.        TextColor(Black)
  1286.       END
  1287.      ELSE
  1288.       TextColor(cnorm);
  1289.      GotoXY(3, 2+i);
  1290.      Write(i:2);
  1291.      IF rank = i THEN
  1292.       TextBackground(Black);
  1293.      IF hisc[i].score <> 0 THEN
  1294.       BEGIN
  1295.        TextColor(chigh);
  1296.        GotoXY(9, 2+i);
  1297.        Write(hisc[i].score:7);
  1298.        GotoXY(20, 2+i);
  1299.        Write(hisc[i].lvl:2);
  1300.        GotoXY(27, 2+i);
  1301.        Write(hisc[i].rclr:4);
  1302.        GotoXY(34, 2+i);
  1303.        Write(hisc[i].name)
  1304.       END
  1305.     END;
  1306.  
  1307.    Window(1, 1, 80, 25);
  1308.    REPEAT
  1309.     TextColor(cnorm);
  1310.     GotoXY(31, 24);
  1311.     Write('Try again (Y/N)? ');
  1312.     TextColor(chigh);
  1313.     ReadLn(c)
  1314.    UNTIL c IN ['N', 'Y', 'n', 'y'];
  1315.    endrun := c IN ['N', 'n']
  1316.   END;
  1317.  
  1318.  
  1319.  PROCEDURE restore;
  1320.  
  1321.   VAR
  1322.    i        : integer;
  1323.  
  1324.   BEGIN
  1325.    Assign(fhisc, hiscnm);
  1326.    Rewrite(fhisc);
  1327.  
  1328.    i := 1;
  1329.    WHILE (i <= nhisc) AND (hisc[i].score <> 0) DO
  1330.     BEGIN
  1331.      Write(fhisc, hisc[i]);
  1332.      i := i+1
  1333.     END;
  1334.    Close(fhisc);
  1335.  
  1336.    csron;
  1337.    TextMode(savemode)
  1338.   END;
  1339.  
  1340.  
  1341.  BEGIN
  1342.   endrun := FALSE;
  1343.   init;
  1344.   REPEAT
  1345.    initgame;
  1346.    drawscreen;
  1347.    play;
  1348.    cleanup
  1349.   UNTIL endrun;
  1350.   restore
  1351.  END.
  1352.  
  1353.