home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / PCLIFE.ZIP / PC_LIFE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-01-27  |  46.6 KB  |  1,404 lines
  1. program PC_Life;
  2.  
  3. {
  4. The rules of Life call for live cells with 2 or 3 neighbors to
  5. survive, and empty cells with three neighbors to be born.
  6. Another way to look at this is to find the sum of all nine cells
  7. in a three by three box, and say that life will result if the
  8. cell is live and the 9-sum is three or four, or if the cell is
  9. dead and the 9-sum is three.  These 9-sums can be formed quickly
  10. by taking 3-sums on one axis, then adding three of these along
  11. the other axis to form 9-sums.
  12.  
  13. This method of running life uses tables that form sums along
  14. rows by look-up rather than calculation.  In these examples,
  15. the unused bits are shown as "x", while individual cell bits
  16. are shown as digits "0" to "B".  Nibble boundaries are marked
  17. by a period.
  18.  
  19. Life cells are stored in one nibble each, so three adjacent
  20. words showing 12 horizontal neighbors would look like this
  21.  ( Note the transposition of the high and low bytes. )
  22. on screen :
  23.    0.1.2.3.4.5.6.7.8.9.A.B
  24. in RAM :
  25.    3xxx.2xxx.0xxx.1xxx, 6xxx.7xxx.4xxx.5xxx, Axxx.Bxxx.8xxx.9xxx
  26.  
  27. To calculate the horizontal sum for the second word, the third
  28. word and the last cell of the first word are needed.  The cells
  29. of the second word and the last cell of the first word have been
  30. formatted into a "residue" like this: xxxx.x345.xx67.xxxx
  31.  
  32. The third word is then shifted in only one byte, and then
  33. logically or'ed into this residue like so:
  34.             xAxx.xBxx
  35.             8xxx.9xxx
  36.   xxxx.x345.xx67.xxxx
  37.  ---------------------
  38.   xxxx.x345.8A67.9Bxx
  39.  
  40. At this location in the SideSum table there is a word that has
  41. the nibble sums for the horizontal neighbors:
  42.     5+6+7.6+7+8.3+4+5.4+5+6
  43.  
  44. The same spot in the Residue table has the corresponding residue
  45. for the next word:
  46.       xxxx.x789.xxAB.xxxx
  47.  
  48. Sums along columns are done in the usual way, but because of the
  49. storage of four cell per word, each triple add forms four sums.
  50.  
  51. The two dimensional sums are exclusive or'ed  with the original
  52. cell array, and then discriminated.  Only cells that have the value
  53. of 1011, 1010, or 0011 are "alive".  This coresponds to alive with
  54. three neighbors, alive with two neighbors, or empty with three neighbors.
  55.  
  56. (You may wonder why the tables are twice as big as needed.  This
  57. allows a very cryptic folding of the two tables that can give a
  58. 3% speedup.  I didn't feel it was worth it, as this process is
  59. hard enough to understand as is.  You are welcome to try it as a
  60. puzzle though, if you like.  RJN)
  61.  
  62. }
  63.  
  64. {$I+}    { I/O checking on}
  65. {$N-}    { No numeric coprocessor}
  66. {$R+}    { Range checking on. }
  67. {$S+}    { Stack checking on. }
  68.  
  69. uses
  70.    Crt, Dos;
  71.  
  72. type
  73.    str80 = string[80];
  74.    Xindex = 0..159;
  75.    Yindex = 0..199;  { 100..199 are the odd lines. }
  76.  
  77. var
  78.    { Working on a 160x100 array. }
  79.    Sum3      : array[0..3999] of word;     { Triple sums. }
  80.    Cells     : array[0..3999] of word;     { Fast double for slow screens. }
  81.    Saver     : array[0..3999] of word;     { Cell safe storage. }
  82.    Screen    : array[0..8096] of word absolute $B800:$0000;
  83.  
  84.    { Look-up tables. }
  85.    SumTab   : array[0..1023] of integer;   { Triple sum look-up.     }
  86.    Residue  : array[0..1023] of integer;   { Left over look-up.      }
  87.    LifeTest : array[0.. 255] of byte;      { Discrimination look-up. }
  88.    MachineId : byte absolute $F000:$FFFE;
  89.  
  90.    SlowScreen : boolean;
  91.    AllDone : boolean;
  92.    Regs    : Registers;
  93.    OldMode : integer;      { Original video mode. }
  94.  
  95.    ForeGround : integer;
  96.    BackGround : integer;
  97.  
  98.  
  99. {            For each composite like this : xxxx.x345.8A67.9Bxx     }
  100. {    shift right 1 for an index like this : xxxx.xx34.58A6.79Bx     }
  101. {     to look-up a sum of three like this : 5+6+7.6+7+8.3+4+5.4+5+6 }
  102. procedure InitSideSum;
  103. var
  104.     I : integer;
  105.     Sum : integer;
  106. begin;
  107.    for I := 0 to 1023
  108.    do begin
  109.       Sum := 0;
  110.       if (I and $0200) <> 0 then Sum := Sum + $0010;  {3}
  111.       if (I and $0100) <> 0 then Sum := Sum + $0011;  {4}
  112.       if (I and $0080) <> 0 then Sum := Sum + $1011;  {5}
  113.       if (I and $0010) <> 0 then Sum := Sum + $1101;  {6}
  114.       if (I and $0008) <> 0 then Sum := Sum + $1100;  {7}
  115.       if (I and $0040) <> 0 then Sum := Sum + $0100;  {8}
  116.       SumTab[I] := Sum;
  117.       end;
  118.    end;
  119.  
  120.  
  121. {         For each composite like this : xxxx.x345.8A67.9Bxx  }
  122. { shift right 1 for an index like this : xxxx.xx34.58A6.79Bx  }
  123. {        to lookup a residue like this : xxxx.x789.xxAB.xxxx  }
  124. procedure InitResidue;
  125. var
  126.    I : integer;
  127.    Bits : integer;
  128. begin;
  129.    for I := 0 to 1023
  130.    do begin
  131.       Bits := 0;
  132.       if (I and $0008) <> 0 then Bits := Bits + $0400;  {7}
  133.       if (I and $0040) <> 0 then Bits := Bits + $0200;  {8}
  134.       if (I and $0004) <> 0 then Bits := Bits + $0100;  {9}
  135.       if (I and $0020) <> 0 then Bits := Bits + $0020;  {A}
  136.       if (I and $0002) <> 0 then Bits := Bits + $0010;  {B}
  137.       Residue[I] := Bits;
  138.       end;
  139.    end;
  140.  
  141.  
  142. {  Conway's game of life has few rules, only these cases will survive: }
  143. {       $B  =  Live and two neighbors.                                 }
  144. {       $C  =  Live and three neighbors.                               }
  145. {       $3  =  Dead and three neighbors.                               }
  146. procedure InitLifeTest;
  147. var
  148.    I : integer;
  149.    BotLive, TopLive : boolean;
  150. begin
  151.    for I := 0 to 255
  152.    do begin
  153.       if ((I shr 4) and $F) in [ $B, $C, $3]
  154.       then begin                           { The high nibble alive. }
  155.          if (I and $F) in [$B, $C, $3]
  156.          then LifeTest[I] := $88
  157.          else LifeTest[I] := $80;
  158.          end
  159.       else begin                          { the high nibble dead.  }
  160.          if (I and $F) in [$B, $C, $3]
  161.          then LifeTest[I] := $08
  162.          else LifeTest[I] := $00;
  163.          end;
  164.       end;
  165.    end;
  166.  
  167. {$I-,R-,S-}
  168. { Look up the horizontal three-cell sums. }
  169. procedure SideSum;
  170. var
  171.    Tally : word;
  172.    I : integer;
  173. begin
  174.    Tally := $0000;
  175.    for I := 1 to 3999 do begin
  176.       Tally :=    (  Tally               { Form three word composite. }
  177.                   or (hi(Screen[I]) shr 1)
  178.                   or lo(Screen[I])
  179.                   )
  180.                shr 1;
  181.       Sum3[I - 1] := SumTab[Tally];      { Look up middle word 3-sums. }
  182.       Tally  := Residue[Tally];          { Get new proto-composite. }
  183.       end;
  184.       Sum3[3999] := 0;
  185.    end;
  186. {$I+,R+,S+}
  187.  
  188. procedure SideSumEga;       { Avoids slow screen by copy. }
  189.    inline(
  190.    $FC/                { cld                    ;Sting stuff to incr.   }
  191.    $B8/>$B800/         { mov   ax, segScreen    ;Establish screen seg.  }
  192.    $8E/$C0/            { mov   es, ax                                   }
  193.    $BB/>0/             { mov   bx, 0            ;Clear running tally.   }
  194.    $B9/>1999/          { mov   cx, 3998/2       ;Do array as one line.  }
  195.    $BF/>SumTab/        { mov   di, SumTab       ;Fast reference.        }
  196.    $BE/>Cells + 2/     { mov   si, Cells + 2    ;Start at the begining. }
  197.             { H_LOOP                                                    }
  198.    $AD/                { lodsw Cells[si]        ;Get 4 cells.           }
  199.    $D0/$CC/            { ror   ah, 1            ;Shift lsb 2 right by 1.}
  200.    $0A/$D8/            { or    bl, al           ;Or lsb 2 into residue. }
  201.    $0A/$DC/            { or    bl, ah           ;Or msb 2 into residue. }
  202.    $8B/$01/            { mov   ax, [di][bx]     ;Table look-up sums.    }
  203.    $89/$84/>$E0BC/     { mov   Sum3-Cells[si-4], ax   ;Store sums.      }
  204.    $8B/$9F/>Residue/   { mov   bx, Residue[bx]  ;Get new residue.       }
  205.  
  206.    { Repeat the block once to cut prefetch queue and looping over head. }
  207.    $AD/$D0/$CC/$0A/$D8/$0A/$DC/$8B/$01/$89/$84/>$E0BC/$8B/$9F/>Residue/
  208.  
  209.    $E2/$DC);           { loop  H_LOOP           ;do till done.          }
  210.  
  211.  
  212. procedure SideSumCga;          { Works directly off fast screen. }
  213.    inline(
  214.    $FC/                { cld                    ;Sting stuff to incr.   }
  215.    $B8/>$B800/         { mov   ax, segScreen    ;Establish screen seg.  }
  216.    $8E/$C0/            { mov   es, ax                                   }
  217.    $BB/>0/             { mov   bx, 0            ;Clear running tally.   }
  218.    $B9/>1999/          { mov   cx, 3998/2       ;Do array as one line.  }
  219.    $BF/>SumTab/        { mov   di, SumTab       ;Fast reference.        }
  220.    $BE/>2/             { mov   si, 2            ;Start at the begining. }
  221.             { H_LOOP                                                    }
  222.    $26/                { es:                                            }
  223.    $AD/                { lodsw Screen[si]       ;Get 4 cells.           }
  224.    $D0/$CC/            { ror   ah, 1            ;Shift lsb 2 right by 1.}
  225.    $0A/$D8/            { or    bl, al           ;Or lsb 2 into residue. }
  226.    $0A/$DC/            { or    bl, ah           ;Or msb 2 into residue. }
  227.    $8B/$01/            { mov   ax, [di][bx]     ;Table look-up sums.    }
  228.    $89/$44/<-4/        { mov   Sum3[si-4], ax   ;Store sums.            }
  229.    $8B/$9F/>Residue/   { mov   bx, Residue[bx]  ;Get new residue.       }
  230.  
  231.             { Rep once to cut c_loop and queue flush overhead.          }
  232.    $26/$AD/$D0/$CC/$0A/$D8/$0A/$DC/$8B/$01/$89/$44/<-4/$8B/$9F/>Residue/
  233.  
  234.    $E2/$DC);           { loop  H_LOOP           ;do till done.          }
  235.  
  236. {$I-,R-,S-}
  237. {  Make the nine-sums and xor with the original cells, and test. }
  238. procedure VertSum;
  239. var
  240.    I : integer;
  241.    Temp : word;
  242.    HiB, Lob : word;
  243. begin;
  244.    for I :=  40 to (3999 - 40) do begin
  245.       Temp  := Screen[I]                { Xor with screen for code. }
  246.                xor                      { Make sum of nine neighbors. }
  247.                ( Sum3[I-40] + Sum3[I] + Sum3[I+40] );
  248.       Screen[I] := word(LifeTest[hi(Temp)] shl 8)   { Test vitality. }
  249.                      or LifeTest[lo(Temp)];
  250.       end;
  251.    end;
  252. {$I+,R+,S+}
  253.  
  254. { Note: this coding assumes Sum3 is at an offset of 0. }
  255. procedure VertSumEga;            { Avoid slow screen with copy. }
  256.    inline(
  257.    $FC/               { cld                       ;Sting stuff to incr.   }
  258.    $B8/>$B800/        { mov   ax, segScreen       ;Establish screen segs. }
  259.    $8E/$C0/           { mov   es, ax                                      }
  260.    $BB/>LifeTest/     { mov   bx, LifeTest        ;Translate Table        }
  261.    $B9/>1920/         { mov   cx, 3840/2          ;Do all in one line.    }
  262.    $BF/>80/           { mov   di, 80              ;Start one line in.     }
  263.            { V_LOOP                                                       }
  264.    $8B/$45/<-80/      { mov   ax, Sum3 - 80 [di]  ;Get one triple-sum.    }
  265.    $03/$05/           { add   ax, Sum3[di]        ;Add a second,          }
  266.    $03/$45/<+80/      { add   ax, Sum3 + 80[di]   ;And the third.         }
  267.    $33/$85/>Cells/    { xor   ax, Cells[di],      ;Mix with screen.       }
  268.    $D7/               { xlat  bx [al]             ;Change to 2 cells.     }
  269.    $86/$C4/           { xchg  ah, al                                      }
  270.    $D7/               { xlat  bx [al]             ;Change to 2 cells.     }
  271.    $86/$C4/           { xchg  ah, al                                      }
  272.    $89/$85/>Cells/    { mov   Cells[di], ax       ;save new generation.   }
  273.    $26/               { es:                                               }
  274.    $AB/               { stosw                     ;Store image.           }
  275.  
  276.    { Repeat the block once to cut prefetch queue and looping over head. }
  277.    $8B/$45/<-80/$03/$05/$03/$45/<+80/$33/$85/>Cells/
  278.    $D7/$86/$C4/$D7/$86/$C4/$89/$85/>Cells/$26/$AB/
  279.  
  280.    $E2/$CE);          { loop  V_LOOP              ;Do till done.          }
  281.  
  282.  
  283. procedure VertSumCga;       { Work directly with fast screen. }
  284.    inline(
  285.    $FC/               { cld                       ;Sting stuff to incr.   }
  286.    $B8/>$B800/        { mov   ax, segScreen       ;Establish screen segs. }
  287.    $8E/$C0/           { mov   es, ax                                      }
  288.    $BB/>LifeTest/     { mov   bx, LifeTest        ;Translate Table        }
  289.    $B9/>1920/         { mov   cx, 3840/2          ;Do all in one line.    }
  290.    $BF/>80/           { mov   di, 80              ;Start one line in.     }
  291.            { V_LOOP                                                       }
  292.    $8B/$45/<-80/      { mov   ax, Sum3 - 80 [di]  ;Get one triple-sum.    }
  293.    $03/$05/           { add   ax, Sum3[di]        ;Add a second,          }
  294.    $03/$45/<+80/      { add   ax, Sum3 + 80[di]   ;And the third.         }
  295.    $26/               { es:                                               }
  296.    $33/$05/           { xor   ax, Screen[di],     ;Mix with screen.       }
  297.    $D7/               { xlat  bx [al]             ;Change to 2 cells.     }
  298.    $86/$C4/           { xchg  ah, al                                      }
  299.    $D7/               { xlat  bx [al]             ;Change to 2 cells.     }
  300.    $86/$C4/           { xchg  ah, al                                      }
  301.    $26/               { es:                                               }
  302.    $AB/               { stosw                     ;Store image.           }
  303.  
  304.             { Rep once to cut c_loop and queue flush overhead.            }
  305.    $8B/$45/<-80/$03/$05/$03/$45/<+80/             { Form 9 sums.          }
  306.    $26/$33/$05/$D7/$86/$C4/$D7/$86/$C4/$26/$AB/   { Mash and translate.   }
  307.  
  308.    $E2/$D8);          { loop  V_LOOP              ;Do till done.          }
  309.  
  310.  
  311.  
  312.  
  313.    {***************************************************************}
  314.    {*           End of assembly mumbo-jumbo, I promise.           *}
  315.    {***************************************************************}
  316.  
  317.  
  318. { Palette control. }
  319. procedure SetBack(Color : integer);
  320. begin
  321.    Regs.Ax := $B00;
  322.    Regs.Bx := Color and $F;
  323.    intr($10, Regs);
  324.    end;
  325.  
  326. procedure SetFore(Color : integer);
  327. begin
  328.    Regs.Ax := $B00;
  329.    Regs.Bx := $100 + (Color and 1);
  330.    intr($10, Regs);
  331.    end;
  332.  
  333. { Only evey other dot on every other line is used on 320x200 mode 4. }
  334. procedure SetVideoMode(NewMode : integer);
  335. begin
  336.    Regs.Ax := NewMode;
  337.    intr($10, Regs);
  338.    SetFore(ForeGround);
  339.    SetBack(BackGround);
  340.    end;
  341.  
  342. { Save initial video mode. }
  343. function GetVideoMode : integer;
  344. begin
  345.    Regs.Ax := $0F00;
  346.    intr($10, Regs);
  347.    GetVideoMode := Regs.ax and $FF;
  348.    end;
  349.  
  350. { Use Bios to print even those tough-to-print characters. }
  351. procedure BiosOut(PrtStr : str80);
  352. var
  353.    OutChar : char;
  354.    i : integer;
  355. begin
  356.    for i := 1 to length(PrtStr) do begin;
  357.       OutChar := PrtStr[i];
  358.       Regs.ax := $0E00 + ord(OutChar);   { TTY character out. }
  359.       Regs.bx := $0002;
  360.       intr($10,Regs);
  361.       end;
  362.    end;
  363.  
  364. { Add carriage-return and line feed if desired. }
  365. procedure BiosLn(PrtStr : str80);
  366. begin
  367.    BiosOut(PrtStr + #13 + #10);
  368.    end;
  369.  
  370. { Bios Output with automatic highlight on capital letters. }
  371. procedure HighLn(PrtStr : str80);
  372. var
  373.    OutChar : char;
  374.    i : integer;
  375. begin
  376.    PrtStr := PrtStr + #13 + #10;
  377.    for i := 1 to length(PrtStr) do begin;
  378.       OutChar := PrtStr[i];
  379.       Regs.ax := $0E00 + ord(OutChar);   { TTY character out. }
  380.       case OutChar of
  381.          'A'..'Z',
  382.           #20..#30,
  383.           '1'..'9',
  384.           '<', '>'  : Regs.bx := $0003;
  385.           else        Regs.bx := $0002;
  386.           end;
  387.       intr($10,Regs);
  388.       end;
  389.    end;
  390.  
  391. { Recover realtime fractional seconds from BIOS. }
  392. function GetSecs : real;
  393. begin
  394.    regs.ax := $0;
  395.    intr($1A, regs);    { 18.20648 Hz clock counts. }
  396.    GetSecs := ((regs.cx * 65536.0) + regs.dx) * 0.05493;
  397.    end;
  398.  
  399. { Functional-style real format utility. }
  400. function RealToStr(InVal: real; Width, Decimals : integer) : str80;
  401. var
  402.    WorkStr : str80;
  403. begin
  404.    str(InVal :Width:Decimals, WorkStr);
  405.    RealToStr := WorkStr;
  406.    end;
  407.  
  408. { Sync to any new key, and eat it. }
  409. procedure KeySync;
  410. var
  411.    KeyS : char;
  412. begin
  413.    while KeyPressed do KeyS := ReadKey;
  414.    repeat until KeyPressed;
  415.    while KeyPressed do KeyS := ReadKey;
  416.    end;
  417.  
  418. { Put Screen into Saver array. }
  419. procedure SaveScreen;
  420. var
  421.    i : integer;
  422. begin
  423.    Move(Screen, Saver, 8000);
  424.    end;
  425.  
  426. { Redisplay the Saver array on the screen. }
  427. procedure RestoreScreen;
  428. var
  429.    i : integer;
  430. begin
  431.    GotoXY(1,1);
  432.    Move(Saver, Cells, 8000);
  433.    Move(Saver, Screen, 8000);
  434.    FillChar(Screen[4000], 8000, #0);  { Blank unused lines. }
  435.    end;
  436.  
  437. { Clear the life cells out. }
  438. procedure ZeroScreen;
  439. var i : integer;
  440. begin
  441.    for i := 0 to 3999 do begin
  442.        Screen[i] := 0;          { Clear the working lines. }
  443.        Screen[i + 4000] := 0;   { Clear the odd lines too. }
  444.        Cells[i] := 0;
  445.        Saver[i] := 0;
  446.        Sum3[i] := 0;            { Might as well clear sums too. }
  447.        end;
  448.    end;
  449.  
  450. { Logical or data onto the screen. }
  451. procedure OrCell( Xpos: Xindex; Ypos: Yindex; Val: word);
  452. var
  453.    I: integer;
  454.    Mask : word;
  455. begin
  456.    Val := Val and $F;
  457.    Xpos := (Xpos + 160) mod 160;   { Provide wrap around. }
  458.    if Ypos < 100
  459.    then I := (Ypos * 40) + (Xpos shr 2)
  460.    else I := ((Ypos - 100) * 40) + 4096 + (Xpos shr 2);
  461.    case (Xpos mod 4) of
  462.          0 : Mask := Val shl 4 ;
  463.          1 : Mask := Val       ;
  464.          2 : Mask := Val shl 12;
  465.          3 : Mask := Val shl 8 ;
  466.          end;
  467.    Screen[I] := Screen[I] or Mask;
  468.    if Ypos < 100
  469.    then begin
  470.       Saver[I]  := Saver[I]  or Mask;
  471.       Cells[I]  := Saver[I];
  472.       end;
  473.    end;
  474.  
  475. { Logical mask data off of the screen. }
  476. procedure MaskCell( Xpos: Xindex; Ypos: Yindex; Val: word);
  477. var
  478.    I: integer;
  479.    Mask : word;
  480. begin
  481.    Val := Val and $F;
  482.    Xpos := (Xpos + 160) mod 160;
  483.    if Ypos < 100
  484.    then I := (Ypos * 40) + (Xpos shr 2)
  485.    else I := ((Ypos - 100) * 40) + 4096 + (Xpos shr 2);
  486.  
  487.    case (Xpos mod 4) of
  488.       0 : Mask := $FF0F or (Val shl 4 );
  489.       1 : Mask := $FFF0 or (Val       );
  490.       2 : Mask := $0FFF or (Val shl 12);
  491.       3 : Mask := $F0FF or (Val shl 8 );
  492.       end;
  493.    Screen[I] := Screen[I] and Mask;
  494.    if Ypos < 100
  495.    then begin
  496.       Saver[I] := Saver[I] and Mask;
  497.       Cells[I] := Saver[I];
  498.       end;
  499.    end;
  500.  
  501. { Logical or a cursor box onto the screen. }
  502. procedure CursorOn(Xloc: Xindex; Yloc: Yindex);
  503. var
  504.    PreXloc : Xindex;
  505. begin
  506.    PreXloc := (Xloc + 159) mod 160;
  507.  
  508.    OrCell(PreXloc, Yloc + 99,  $3);
  509.    OrCell(Xloc,    Yloc + 99,  $F);
  510.    OrCell(PreXloc, Yloc,       $3);
  511.    OrCell(Xloc,    Yloc,       $3);
  512.    OrCell(PreXloc, Yloc + 100, $3);
  513.    OrCell(Xloc,    Yloc + 100, $F);
  514.    end;
  515.  
  516. { Remove unwanted cursor box from screen. }
  517. procedure CursorOff(Xloc: Xindex; Yloc: Yindex);
  518. var
  519.    PreXloc : Xindex;
  520. begin
  521.    PreXloc := (Xloc + 159) mod 160;
  522.  
  523.    MaskCell(PreXloc, Yloc + 99,  $C);
  524.    MaskCell(Xloc,    Yloc + 99,  $0);
  525.    MaskCell(PreXloc, Yloc,       $C);
  526.    MaskCell(Xloc,    Yloc,       $C);
  527.    MaskCell(PreXloc, Yloc + 100, $C);
  528.    MaskCell(Xloc,    Yloc + 100, $0);
  529.    end;
  530.  
  531. { Logical or a variable size box onto the screen. }
  532. procedure BoxOn(Left, Top, Right, Bot: integer);
  533. var
  534.    I : integer;
  535. begin
  536.    OrCell(Left - 1, Top + 99,  $3);  { Top and Bottom }
  537.    OrCell(Left - 1, Bot + 100, $3);
  538.    for i := Left to Right do begin
  539.       OrCell(i,  Top + 99,  $F);
  540.       OrCell(i,  Bot + 100, $F);
  541.       end;
  542.    for i := Top to Bot do begin      { Two sides. }
  543.       OrCell(Left - 1,       i, $3);
  544.       OrCell(Left - 1, i + 100, $3);
  545.       OrCell(   Right,       i, $3);
  546.       OrCell(   Right, i + 100, $3);
  547.       end;
  548.    end;
  549.  
  550. {Remove a variable size box onto the screen. }
  551. procedure BoxOff(Left, Top, Right, Bot: integer);
  552. var
  553.    I : integer;
  554. begin
  555.    MaskCell(Left - 1, Top + 99,  $C);  { Top and Bottom }
  556.    MaskCell(Left - 1, Bot + 100, $C);
  557.    for i := Left to Right do begin
  558.       MaskCell(i,  Top + 99,  $0);
  559.       MaskCell(i,  Bot + 100, $0);
  560.       end;
  561.    for i := Top to Bot do begin      { Two sides. }
  562.       MaskCell(Left - 1,       i, $C);
  563.       MaskCell(Left - 1, i + 100, $C);
  564.       MaskCell(   Right,       i, $C);
  565.       MaskCell(   Right, i + 100, $C);
  566.       end;
  567.    end;
  568.  
  569.  
  570. { Force a life cell on. }
  571. procedure Birth(Xloc: Xindex; Yloc: Yindex);
  572. begin
  573.   OrCell(Xloc, Yloc, 8);
  574.   end;
  575.  
  576. { Force a life cell off. }
  577. procedure LifeOff(Xloc: Xindex; Yloc: Yindex);
  578. begin
  579.   MaskCell(Xloc, Yloc, 3);
  580.   end;
  581.  
  582.  
  583. { Fetch a cell from the screen. }
  584. function GetCell( Xpos, Ypos : integer) : integer;
  585. var
  586.    I: integer;
  587. begin
  588.    if Ypos < 100
  589.    then I := (Ypos * 40) + (Xpos shr 2)
  590.    else I := ((Ypos - 100) * 40) + 4096 + (Xpos shr 2);
  591.  
  592.    case (Xpos mod 4) of
  593.       0 : GetCell := (Screen[I] shr  4) and $F;
  594.       1 : GetCell := (Screen[I] shr  0) and $F;
  595.       2 : GetCell := (Screen[I] shr 12) and $F;
  596.       3 : GetCell := (Screen[I] shr  8) and $F;
  597.       end;
  598.    end;
  599.  
  600. { Move the current pointer position with checks. }
  601. function IncX(Xpos : Xindex) : Xindex;
  602. begin
  603.    if Xpos >= 159 then IncX := 0 else IncX := Xpos + 1;
  604.    end;
  605. function DecX(Xpos : Xindex) : integer;
  606. begin
  607.    if Xpos <= 0 then DecX := 159 else DecX := Xpos - 1;
  608.    end;
  609. function IncY(Ypos: Yindex) : Yindex;
  610. begin
  611.    if Ypos >= 99 then IncY := 99 else IncY := Ypos + 1;
  612.    end;
  613. function DecY(Ypos : Yindex) : Yindex;
  614. begin
  615.    if Ypos <= 1 then DecY := 1 else DecY:= Ypos - 1;
  616.    end;
  617.  
  618. { Install a pulsar. }
  619. procedure Pulsar(X, Y: integer);
  620. begin
  621.    Birth(X, Y); Birth(X+1, Y); Birth(X+2, Y); Birth(X+3, Y); Birth(X+4, Y);
  622.    Birth(X, Y+1);                                            Birth(X+4, Y+1);
  623.    end;
  624.  
  625. { Install an R pentamino. }
  626. procedure Pentamino(X, Y: integer);
  627. begin
  628.                    Birth(X+1, Y  );   Birth(X+2, Y);
  629.    Birth(X , Y+1); Birth(X+1, Y+1);
  630.                    Birth(X+1, Y+2);
  631.    end;
  632.  
  633. { Determine the existence of a file. }
  634. function FileExists(FileName: str80): boolean;
  635. var
  636.    EXIST : file of byte;
  637. begin
  638.    {$I-}
  639.    assign(EXIST, FileName);
  640.    reset(EXIST);
  641.    close(EXIST);
  642.    {$I+}
  643.    if (IOresult = 0) and (FileName <> '')
  644.    then FileExists := true
  645.    else FileExists := false;
  646.    end;
  647.  
  648.  
  649. { Initial screen is in the default mode so it can always be read. }
  650. procedure IntroScreen;
  651. var KeyI : char;
  652. begin
  653.   writeln;
  654.   writeln('                         PC LIFE version 1.0                       ');
  655.   writeln;
  656.   writeln('        This program plays John Horton Conway''s game of Life at   ');
  657.   writeln('        the rate of more than 300,000 cell-generations/second on   ');
  658.   writeln('        an IBM PS/2 model 50.  You will need a color monitor and a       ');
  659.   writeln('        CGA, EGA, VGA, or other adapter with video mode 4 to play. ');
  660.   writeln('        Send your questions, comments, and gratuities to:          ');
  661.   writeln;
  662.   writeln('                         Robert Norton      ');
  663.   writeln('                         706 Copeland St.   ');
  664.   writeln('                         Madison, WI 53711  ');
  665.   writeln;
  666.   writeln;
  667.   writeln('          To use the menu now, or while running, press <F1>. ');
  668.   writeln;
  669.   writeln;
  670.   writeln;
  671.   end;
  672.  
  673. { Give a brief history of the rules and story of Life. }
  674. procedure History;
  675. var
  676.    KeyH : char;
  677. begin
  678.    SetVideoMode(OldMode);           { Use old mode for text. }
  679.    ClrScr;
  680.    GotoXY(1,1);
  681.    writeln('                                                                       ');
  682.    writeln('                         -- About life --                              ');
  683.    writeln('                                                                       ');
  684.    writeln(' The game of Life mimics the constantly changing status of cells in    ');
  685.    writeln(' a colony over the course of many generations.  Like real cells,       ');
  686.    writeln(' some groups of Life cells have interesting and unexpected properties. ');
  687.    writeln(' A collection of well-known groups is included with this program.      ');
  688.    writeln(' To observe one of these groups in action, read its file (*.LIF) to the');
  689.    writeln(' screen from the edit menu.                                            ');
  690.    writeln('                                                                       ');
  691.    writeln(' The rules of Life are deceptively simple.  The game is played on a    ');
  692.    writeln(' grid of squares, each of which is empty or contains a cell.  Each     ');
  693.    writeln(' square has eight neighbor squares: four orthogonal and four           ');
  694.    writeln(' diagonal.                                                             ');
  695.    writeln('                                                                       ');
  696.    writeln(' The future of each square is determined solely by the number of cells ');
  697.    writeln(' that surround it.  A cell persists into the next generation only if   ');
  698.    writeln(' it has two or three neighbors.  An empty square stays empty unless it ');
  699.    writeln(' has exactly three living neighbors.  If an empty square has three     ');
  700.    writeln(' neighbors, it will be filled with a cell on the next generation.      ');
  701.    writeln('                                                                       ');
  702.    writeln('                                                                       ');
  703.    writeln('                     Press <SPACE> for more . . .                      ');
  704.    KeySync;
  705.    ClrScr;
  706.    GotoXY(1, 1);
  707.    writeln('                                                                       ');
  708.    writeln('                         -- About life --                              ');
  709.    writeln('                                                                       ');
  710.    writeln(' The game of Life is the creation of John Horton Conway, a             ');
  711.    writeln(' distinguished mathematician at the University of Cambridge.  Although ');
  712.    writeln(' I am not sure of the exact date, it appears that this set of rules    ');
  713.    writeln(' was first published in early 1970.                                    ');
  714.    writeln('                                                                       ');
  715.    writeln(' The popular science writer Martin Gardner has done much to bring      ');
  716.    writeln(' this fascinating pastime to the attention of computer enthusiasts. I  ');
  717.    writeln(' recommend his book "Wheels, Life, and Other Mathematical Amusements"  ');
  718.    writeln(' as an enjoyable introduction to the game of Life.  I hope this        ');
  719.    writeln(' program brings you many hours of lively diversion.                    ');
  720.    writeln('                                                                       ');
  721.    writeln(' All of the actual English and much of the user interface of this      ');
  722.    writeln(' program is brought to you through the courtesy of Bennett Berson.     ');
  723.    writeln('                                                                       ');
  724.    writeln('                                        Robert Norton                  ');
  725.    writeln('                                                                       ');
  726.    writeln('                                                                       ');
  727.    writeln('                  Press <SPACE> for the main menu.                     ');
  728.    KeySync;
  729.    SetVideoMode(4);     { 320x200. }
  730.    RestoreScreen;
  731.    end;
  732.  
  733.  
  734. { Save a collection of cells to disk. }
  735. procedure DoWriteFile;
  736. var
  737.    MoveDone : boolean;
  738.    LeftX, RightX,  ScanX: Xindex;
  739.    TopY,  BottomY, ScanY: Yindex;
  740.    Title     : string[40];
  741.    FileName  : string[12];
  742.    WriteFile : text;
  743.    KeyW : char;
  744. begin
  745.    RestoreScreen;
  746.    BiosLn('          -- Write a Life File. --');
  747.    BiosLn(' Give a brief description of the area');
  748.    BiosLn(' that you are going to save on disk: ');
  749.    BiosOut('[                                     ]' + #13);
  750.    BiosOut('['); readln(Title);
  751.    BiosLn(' Give a DOS name for the save file.');
  752.    BiosOut('[_       .LIF]' + #13);
  753.    BiosOut('['); readln(FileName);
  754.    if pos('.', FileName) = 0 then FileName := Filename + '.LIF';
  755.  
  756.    RestoreScreen;
  757.    LeftX := 40; TopY := 50;
  758.    CursorOn(LeftX, TopY);
  759.    GotoXY(1, 1);
  760.    BiosLn('Move to upper left corner of the area ');
  761.    HighLn('to be saved to disk, then press <SPACE>.');
  762.  
  763.    MoveDone := false;
  764.    repeat
  765.       KeyW := ReadKey;
  766.       case KeyW of
  767.          #0 : if keypressed
  768.                then begin
  769.                   KeyW := ReadKey;
  770.                   if KeyW in [#77, #75, #72, #80]
  771.                   then begin
  772.                      CursorOff(LeftX, TopY);
  773.                      case KeyW of
  774.                         #77 : LeftX := IncX(LeftX); { right }
  775.                         #75 : LeftX := DecX(LeftX); { left  }
  776.                         #72 : TopY  := DecY(TopY);  { up    }
  777.                         #80 : TopY  := IncY(TopY);  { down  }
  778.                         end;
  779.                      if TopY < 15 then RestoreScreen;
  780.                      CursorOn(LeftX, TopY);
  781.                      end;
  782.                   end;
  783.  
  784.          ' ', #27 : MoveDone := true;
  785.          else MoveDone := true;
  786.          end {of case on keys };
  787.    until MoveDone;
  788.  
  789.    RestoreScreen;
  790.    RightX := LeftX; BottomY := TopY;
  791.    BoxOn(LeftX, TopY, RightX, BottomY);
  792.  
  793.    GotoXY(1, 1);
  794.    BiosLn('Stretch the box to cover the area to ');
  795.    HighLn('be saved to disk, then press <SPACE>. ');
  796.  
  797.    MoveDone := false;
  798.    repeat
  799.       KeyW := ReadKey;
  800.       case KeyW of
  801.          #0 : if keypressed
  802.                then begin
  803.                   KeyW := ReadKey;
  804.                   if KeyW in [#77, #75, #72, #80]
  805.                   then begin
  806.                      BoxOff(LeftX, TopY, RightX, BottomY);
  807.                      case KeyW of
  808.                         #77 : RightX  := IncX(RightX);    { right }
  809.                         #75 : RightX  := DecX(RightX);    { left  }
  810.                         #72 : BottomY := DecY(BottomY);   { up    }
  811.                         #80 : BottomY := IncY(BottomY);   { down  }
  812.                         end;
  813.                      if TopY < 15 then RestoreScreen;
  814.                      BoxOn(LeftX, TopY, RightX, BottomY)
  815.                      end;
  816.                   end;
  817.           ' ', #27 : MoveDone := true;
  818.           else MoveDone := true;
  819.           end {of case on keys };
  820.    until MoveDone;
  821.    BoxOff(LeftX, TopY, RightX, BottomY);
  822.  
  823.    assign(WriteFile, FileName);     { Scan region for life. }
  824.    rewrite(WriteFile);
  825.    writeln(WriteFile, Title);
  826.    for ScanY := TopY to BottomY
  827.    do begin
  828.       for ScanX := LeftX to RightX
  829.       do begin
  830.          if GetCell(ScanX, ScanY) = 8
  831.          then writeln(WriteFile, ScanX - LeftX, '  ', ScanY - TopY);
  832.          end;
  833.       end;
  834.    close(WriteFile);
  835.    end;
  836.  
  837.  
  838. { Read a previously saved file from the disk. }
  839. procedure DoReadFile;
  840. var
  841.    MoveDone : boolean;
  842.    LeftX,  DeltaX, MaxX: Xindex;
  843.    TopY,   DeltaY, MaxY: Yindex;
  844.    Title    : string[40];
  845.    FileName : string[12];
  846.    ReadFile : text;
  847.    KeyW : char;
  848.    Missing : boolean;
  849. begin
  850.    Missing := false;
  851.    repeat
  852.       RestoreScreen;
  853.       if Missing then BiosLn('Can''t find ' + FileName);
  854.  
  855.       BiosLn('       -- Read a Life File --       ');
  856.       BiosLn('Give the DOS name for the saved file');
  857.       BiosLn('that you wish to restore:     ');
  858.       BiosOut('[_       .LIF]' + #13);
  859.       BiosOut('[');  readln(FileName);
  860.       if pos('.', FileName) = 0 then FileName := Filename + '.LIF';
  861.       if FileExists(FileName)
  862.       then Missing := false
  863.       else Missing := true;
  864.    until not Missing;
  865.  
  866.    MaxX := 1; MaxY := 1;
  867.    assign(ReadFile, FileName);
  868.    reset(ReadFile);
  869.    readln(ReadFile, Title);
  870.    while not EOF(ReadFile)
  871.    do begin
  872.       readln(ReadFile, DeltaX, DeltaY);
  873.       if DeltaX > MaxX then MaxX := DeltaX;
  874.       if DeltaY > MaxY then MaxY := DeltaY;
  875.       end;
  876.    close(ReadFile);
  877.  
  878.    RestoreScreen;
  879.    GotoXY(1, 1);
  880.    BiosLn('[' + Title + ']');
  881.    BiosLn('Move the box to the area you want to   ');
  882.    HighLn('restore from disk, then press <SPACE>. ');
  883.  
  884.    MaxX := 1; MaxY := 1;
  885.    assign(ReadFile, FileName);
  886.    reset(ReadFile);
  887.    readln(ReadFile, Title);
  888.    while not EOF(ReadFile)
  889.    do begin
  890.       readln(ReadFile, DeltaX, DeltaY);
  891.       if DeltaX > MaxX then MaxX := DeltaX;
  892.       if DeltaY > MaxY then MaxY := DeltaY;
  893.       end;
  894.    close(ReadFile);
  895.  
  896.    LeftX := 80 - (MaxX div 2);     { Start at center of screen. }
  897.    TopY := 50 - (MaxY div 2);
  898.    BoxOn(LeftX, TopY, LeftX + MaxX, TopY + MaxY);
  899.    repeat until KeyPressed;
  900.  
  901.    MoveDone := false;
  902.    repeat
  903.       KeyW := ReadKey;
  904.       case KeyW of
  905.          #0 : if keypressed
  906.                then begin
  907.                   KeyW := ReadKey;
  908.                   if KeyW in [#77, #75, #72, #80]
  909.                   then begin
  910.                      BoxOff(LeftX, TopY, LeftX + MaxX, TopY + MaxY);
  911.                      case KeyW of
  912.                         #77 : LeftX := IncX(LeftX); { right }
  913.                         #75 : LeftX := DecX(LeftX); { left  }
  914.                         #72 : TopY  := DecY(TopY);  { up    }
  915.                         #80 : TopY  := IncY(TopY);  { down  }
  916.                         end;
  917.                      if TopY < 15 then RestoreScreen;
  918.                      BoxOn(LeftX, TopY, LeftX + MaxX, TopY + MaxY)
  919.                      end;
  920.                   end;
  921.  
  922.          ' ' : MoveDone := true;
  923.          else MoveDone := true;
  924.          end {of case on keys };
  925.    until MoveDone;
  926.    BoxOff(LeftX, TopY, LeftX + MaxX, TopY + MaxY);
  927.  
  928.    assign(ReadFile, FileName);
  929.    reset(ReadFile);
  930.    readln(ReadFile, Title);
  931.    while not EOF(ReadFile)
  932.    do begin
  933.       readln(ReadFile, DeltaX, DeltaY);
  934.       OrCell(LeftX + DeltaX, TopY + DeltaY, 8);
  935.       end;
  936.    close(ReadFile);
  937.    end;
  938.  
  939.  
  940. { Allow manual entry or removal of cells from screen. }
  941. procedure EditCells;
  942. var
  943.    KeyE       : char;
  944.    i, j       : integer;
  945.    Editing    : boolean;
  946.    CurX, CurY :integer;
  947.    MenuOn : boolean;
  948.  
  949. begin
  950.    CurX := 80; CurY := 50;
  951.    RestoreScreen;
  952.    MenuOn := false;
  953.    Editing := true;
  954.    while Editing do begin
  955.       if (CurY < 25) and MenuOn        { Blank menu when too high. }
  956.       then begin
  957.          RestoreScreen;
  958.          MenuOn := false;
  959.          end;
  960.       if (CurY > 30) and (not MenuOn)  { Restore menu if needed. }
  961.       then begin
  962.          SaveScreen;
  963.          GotoXY(1, 1);
  964.          BiosLn('          -- Edit Menu --             ');
  965.          HighLn( #24 + ' ' + #25 + ' ' + #27 + ' ' +  #26
  966.                      + ' moves box   Clears all cells');
  967.          HighLn('<INS> adds a cell   Reads a disk file ');
  968.          HighLn('<DEL> zaps a cell   Writes a disk file');
  969.          HighLn('Adds random cells   Single step  ');
  970.          HighLn('      <F1> for the main menu. ');
  971.          MenuOn := true;
  972.          end;
  973.  
  974.       CursorOn(CurX, CurY);
  975.       KeyE := ReadKey;
  976.       case KeyE of      { Support MS-mouse with default.com loaded. }
  977.          #0 : begin
  978.                  KeyE := ReadKey;
  979.                  case KeyE of
  980.                     #59 : Editing := false;
  981.  
  982.                     #82 : Birth(CurX, CurY); { insert key. }
  983.                     #83 : LifeOff(CurX, CurY);    { delete }
  984.  
  985.                     #61 : begin  { mouse left button. }
  986.                              if (GetCell(CurX, CurY) and 8) = 0
  987.                              then Birth(CurX, CurY)
  988.                              else LifeOff(CurX, CurY);
  989.                              end;
  990.  
  991.                     #77, #75, #72, #80,
  992.                     #73, #81, #71, #79 :    { cursor moves. }
  993.                          begin
  994.                             CursorOff(CurX, CurY);
  995.                             case KeyE of
  996.                                #77 : CurX := IncX(CurX); { right }
  997.                                #75 : CurX := DecX(CurX); { left  }
  998.                                #72 : CurY := DecY(CurY); { up    }
  999.                                #80 : CurY := IncY(CurY); { down  }
  1000.                                #73 : begin               { pg up }
  1001.                                         CurX := IncX(CurX);
  1002.                                         CurY := DecY(CurY)
  1003.                                         end;
  1004.                                #81 : begin               { pg dn }
  1005.                                         CurX := IncX(CurX);
  1006.                                         CurY := IncY(CurY);
  1007.                                         end;
  1008.                                #71 : begin               { home  }
  1009.                                         CurX := DecX(CurX);
  1010.                                         CurY := DecY(CurY)
  1011.                                         end;
  1012.                                #79 : begin               { end   }
  1013.                                         CurX := DecX(CurX);
  1014.                                         CurY := IncY(CurY);
  1015.                                         end;
  1016.                                end;
  1017.                             end;
  1018.                      else Editing := false;
  1019.                      end;
  1020.                   end;
  1021.  
  1022.          'M', 'm', #27 : Editing := false;
  1023.  
  1024.          #13      :  begin  { mouse right button. }
  1025.                         if (GetCell(CurX, CurY) and 8) = 0
  1026.                         then Birth(CurX, CurY)
  1027.                         else LifeOff(CurX, CurY);
  1028.                         end;
  1029.  
  1030.          'C', 'c' : begin                 { Clear. }
  1031.                        ZeroScreen;
  1032.                        MenuOn := false;
  1033.                        end;
  1034.  
  1035.          'D', 'd' : for i := CurX - 2 to CurX + 2 do begin
  1036.                        for j := CurY - 2 to CurY + 2 do begin
  1037.                           LifeOff((i + 160) mod 160,
  1038.                                   (j + 100) mod 100 );
  1039.                           end;
  1040.                        end;
  1041.  
  1042.          'R', 'r' : begin
  1043.                        CursorOff(CurX, CurY);
  1044.                        DoReadFile;
  1045.                        RestoreScreen;
  1046.                        MenuOn := false;
  1047.                        end;
  1048.  
  1049.          'W', 'w' : begin
  1050.                        CursorOff(CurX, CurY);
  1051.                        DoWriteFile;
  1052.                        RestoreScreen;
  1053.                        MenuOn := false;
  1054.                        end;
  1055.  
  1056.          ' ', 'S', 's' : begin
  1057.                            CursorOff(CurX, CurY);
  1058.                            if MenuOn
  1059.                            then begin
  1060.                               RestoreScreen;
  1061.                               MenuOn := false;
  1062.                               CurX := 20;
  1063.                               CurY := 20;
  1064.                               end;
  1065.                            if SlowScreen
  1066.                            then begin SideSumEga; VertsumEga end
  1067.                            else begin SideSumCga; VertSumCga end;
  1068.                            SaveScreen;
  1069.                            end;
  1070.  
  1071.          'A', 'a' : for i := 1 to 100     { Add random. }
  1072.                     do Birth(Random(160), 2 + random(94));
  1073.  
  1074.          else Editing := false;
  1075.          end {of case on keys };
  1076.       end; { of while Editing. }
  1077.  
  1078.    CursorOff(CurX, CurY);
  1079.    end;
  1080.  
  1081. { Allow manual adjustment of palette. }
  1082. procedure DoPalette;
  1083. var
  1084.    KeyP       : char;
  1085.    I          : integer;
  1086.    PaletteDone   : boolean;
  1087. begin
  1088.    ZeroScreen;
  1089.    Pulsar(100, 50);
  1090.    Pulsar( 80, 50);
  1091.    Pulsar( 60, 50);
  1092.  
  1093.    GotoXY(1, 1);
  1094.    BiosLn('         -- Color Menu --            ');
  1095.    HighLn( #24 + ' or ' + #25 + ' to select background color.');
  1096.    HighLn( #27 + ' or ' + #26 + ' to select foreground color.');
  1097.    BiosLn('Please try to keep this text legible. ');
  1098.    HighLn('      <F1> for the main menu.    ');
  1099.  
  1100.    while keypressed do KeyP := ReadKey;
  1101.    repeat until keypressed;
  1102.  
  1103.    PaletteDone := false;
  1104.    repeat
  1105.       KeyP := ReadKey;
  1106.       case KeyP of
  1107.  
  1108.          #0 : begin
  1109.                  KeyP := ReadKey;
  1110.                  case KeyP of
  1111.                     #59 : PaletteDone := true;
  1112.                     #77 : ForeGround := 1; {rt}
  1113.                     #75 : ForeGround := 0; {lt}
  1114.                     #72 : BackGround := (BackGround + 1) mod 16; {up}
  1115.                     #80 : Background := (BackGround - 1) mod 16; {dn}
  1116.                     end;
  1117.                  SetBack(BackGround);
  1118.                  SetFore(ForeGround);
  1119.                  end;
  1120.  
  1121.          'A'..'P' : begin
  1122.                        BackGround := ord(KeyP) - ord('A');
  1123.                        SetBack(BackGround)
  1124.                        end;
  1125.  
  1126.          'a'..'p' : begin
  1127.                        BackGround := ord(KeyP) - ord('a');
  1128.                        SetBack(BackGround);
  1129.                        end;
  1130.  
  1131.          ' ', #27 : PaletteDone := true;
  1132.  
  1133.          '1', '2' : begin
  1134.                        ForeGround := ord(KeyP) - ord('1');
  1135.                        SetFore(ForeGround);
  1136.                        end;
  1137.  
  1138.          end {of case on keys };
  1139.       until PaletteDone;
  1140.    RestoreScreen;
  1141.    end;
  1142.  
  1143.  
  1144. { 1000 generation speed test; }
  1145. procedure SpeedTest1000(LifeMode : char); { Ega, Cga, or Pascal}
  1146. var
  1147.    i : integer;
  1148.    KeyS : char;
  1149.    StartSecs : real;
  1150.    TotalSecs : real;
  1151.    OutStr : str80;
  1152. begin
  1153.    ZeroScreen;
  1154.    Pulsar(10, 60);
  1155.    Pulsar(10, 80);
  1156.    Pulsar(150, 10);
  1157.    Pulsar(150, 30);
  1158.    Pentamino(70, 40);
  1159. {$I-,R-,S-}
  1160.    if LifeMode = 'E'
  1161.    then begin
  1162.       Sound(220); Delay(100); NoSound;
  1163.       StartSecs := GetSecs;
  1164.       for i := 1 to 200 do begin
  1165.          SideSumEga; VertSumEga;
  1166.          SideSumEga; VertSumEga;
  1167.          SideSumEga; VertSumEga;
  1168.          SideSumEga; VertSumEga;
  1169.          SideSumEga; VertSumEga;
  1170.          end;
  1171.       TotalSecs := Getsecs - StartSecs;
  1172.       Sound(220); Delay(100); NoSound;
  1173.       end;
  1174.  
  1175.    if LifeMode = 'C'
  1176.    then begin
  1177.       Sound(220); Delay(100); NoSound;
  1178.       StartSecs := GetSecs;
  1179.       for i := 1 to 200 do begin
  1180.          SideSumCga; VertSumCga;
  1181.          SideSumCga; VertSumCga;
  1182.          SideSumCga; VertSumCga;
  1183.          SideSumCga; VertSumCga;
  1184.          SideSumCga; VertSumCga;
  1185.          end;
  1186.       TotalSecs := Getsecs - StartSecs;
  1187.       Sound(220); Delay(100); NoSound;
  1188.       end;
  1189.  
  1190.    if LifeMode = 'P'
  1191.    then begin
  1192.       Sound(220); Delay(100); NoSound;
  1193.       StartSecs := GetSecs;
  1194.       for i := 1 to 200 do begin
  1195.          SideSum; VertSum;
  1196.          SideSum; VertSum;
  1197.          SideSum; VertSum;
  1198.          SideSum; VertSum;
  1199.          SideSum; VertSum;
  1200.          end;
  1201.       TotalSecs := Getsecs - StartSecs;
  1202.       Sound(220); Delay(100); NoSound;
  1203.       end;
  1204. {$I+,R+,S+}
  1205.  
  1206.    GotoXY(1,1);
  1207.    BiosLn('        --Test Results--');
  1208.    BiosLn(' ');
  1209.    BiosLn('      Cells per second = '+ RealToStr(16000000.0/TotalSecs, 7, 0));
  1210.    BiosLn('          Elapsed time = '+ RealToStr(TotalSecs, 6, 3));
  1211.    BiosLn('Generations per second = '+ RealToStr(1000.0 /TotalSecs, 6, 3));
  1212.    BiosLn('     1 cell generation = '+ RealToStr(TotalSecs/16.0, 5, 3) + 'uS');
  1213.    BiosLn(' ');
  1214.    if SlowScreen
  1215.    then BiosLn('  Currently in Ega/Vga display mode. ')
  1216.    else BiosLn('  Currently in Cga display mode.');
  1217.    BiosLn(' ');
  1218.    HighLn     ('       <F1> for the main menu.         ');
  1219.  
  1220.    KeySync;
  1221.    end;
  1222.  
  1223. procedure SpeedStuff;
  1224. var
  1225.    KeyS : char;
  1226. begin
  1227.    RestoreScreen;
  1228.    BiosLn     ('          -- Speed Menu --');
  1229.    HighLn     ('Test the speed   Ega/Vga card mode ');
  1230.    HighLn     ('<F1> main menu   Cga card mode  ');
  1231.    BiosLn(' ');
  1232.    if SlowScreen
  1233.    then BiosLn(' Currently in Ega/Vga display mode. ')
  1234.    else BiosLn('   Currently in Cga display mode.');
  1235.  
  1236.    while KeyPressed do KeyS := ReadKey;
  1237.    KeyS := ReadKey;
  1238.    case KeyS of
  1239.       'E', 'e',
  1240.       'V', 'v' : begin
  1241.                     SlowScreen := true;
  1242.                     RestoreScreen;
  1243.                     GotoXY(1,1);
  1244.                     BiosLn ('      -- Now in Ega/Vga mode-- ');
  1245.                     BiosLn ('This mode is optimized to work with');
  1246.                     BiosLn ('display adapters that use tons of');
  1247.                     BiosLn ('wait states, like the Vga or Ega.');
  1248.                     HighLn ('    <F1> for the main menu.');
  1249.  
  1250.                     KeySync;
  1251.                     end;
  1252.  
  1253.       'C', 'c' : begin
  1254.                     SlowScreen := false;
  1255.                     RestoreScreen;
  1256.                     BiosLn ('       -- Now in CGA mode-- ');
  1257.                     BiosLn ('This mode is optimized to work with');
  1258.                     BiosLn ('display adapters that do not add many');
  1259.                     BiosLn ('wait states, like the CGA card.');
  1260.                     HighLn ('     <F1> for the main menu.');
  1261.  
  1262.                     KeySync;
  1263.                     end;
  1264.  
  1265.  
  1266.       'P', 'p' : SpeedTest1000('P');
  1267.  
  1268.       'T', 't' : if SlowScreen
  1269.                  then SpeedTest1000('E')
  1270.                  else SpeedTest1000('C');
  1271.  
  1272.       end;
  1273.  
  1274.    while KeyPressed do KeyS := ReadKey;
  1275.    RestoreScreen;
  1276.    end;
  1277.  
  1278.  
  1279.  
  1280.  
  1281. { This is the main level menu. }
  1282. procedure HandleMenu;
  1283. var
  1284.    i : integer;
  1285.    KeyM : char;
  1286.    MenuDone : boolean;
  1287. begin
  1288.    while keypressed do KeyM := ReadKey;
  1289.    if KeyM = ' ' then KeyM := '?';   { suppress initial single step spaces. }
  1290.    MenuDone := false;
  1291.    SaveScreen;
  1292.    repeat
  1293.  
  1294.       Biosln ('            -- Main Menu --           ');
  1295.       HighLn ('   Edit image   Colors        Speed   ');
  1296.       HighLn ('   Run life     About life    Quit    ');
  1297.       KeyM := ReadKey;
  1298.       case KeyM of
  1299.           #0 : begin
  1300.                   KeyM := ReadKey;
  1301.                   MenuDOne := true;
  1302.                   end;
  1303.  
  1304.          'Q', 'q' : begin
  1305.                        SaveScreen;    { Saves the text, too! }
  1306.                        AllDone := true;
  1307.                        MenuDone := true;
  1308.                        end;
  1309.  
  1310.          'E', 'e' : EditCells;
  1311.  
  1312.          'A', 'a' : History;
  1313.  
  1314.          'R', 'r' : begin
  1315.                        MenuDone := true;
  1316.                        end;
  1317.  
  1318.          ' '      : begin
  1319.                       RestoreScreen;
  1320.                       if SlowScreen
  1321.                       then begin SideSumEga; VertSumEga; end
  1322.                       else begin SideSumCga; VertSumCga; end;
  1323.                       SaveScreen;
  1324.                       end;
  1325.  
  1326.          'C', 'c' : DoPalette;
  1327.  
  1328.          'S', 's' : SpeedStuff;
  1329.  
  1330.          end;
  1331.  
  1332.       RestoreScreen;
  1333.    until MenuDone;
  1334.    end;
  1335.  
  1336.  
  1337. procedure Final;   { Play with the menu text as a life array. }
  1338. var
  1339.    i : integer;
  1340. begin
  1341.    if SlowScreen
  1342.    then for i := 1 to 30 do begin
  1343.       SideSumEga; VertSumEga;
  1344.       end
  1345.    else for i := 1 to 30 do begin
  1346.       SideSumCga; VertSumCga;
  1347.       end;
  1348.    end;
  1349.  
  1350.  
  1351. begin
  1352.    OldMode := GetVideoMode;
  1353.  
  1354.    IntroScreen;
  1355.  
  1356.    InitResidue;   { Initialize look-up tables. }
  1357.    InitSideSum;
  1358.    InitLifeTest;
  1359.  
  1360.    SlowScreen := true;
  1361.    if MachineId = $FD
  1362.    then begin
  1363.       ForeGround := 1;
  1364.       BackGround := 0;
  1365.       end
  1366.    else begin
  1367.       ForeGround := 1;
  1368.       BackGround := 15;
  1369.       end;
  1370.  
  1371.    repeat until keypressed;
  1372.  
  1373.    SetVideoMode(4);       { 320x200, clear the way. }
  1374.    ZeroScreen;
  1375.  
  1376.    Pulsar(10, 85);
  1377.    Pentamino(80, 50);
  1378.    AllDone := false;
  1379.  
  1380.    HandleMenu;
  1381.    if SlowScreen
  1382.    then repeat
  1383.  
  1384.       SideSumEga; VertSumEga;
  1385.       SideSumEga; VertSumEga;
  1386.       SideSumEga; VertSumEga;
  1387.  
  1388.       if keypressed then HandleMenu;
  1389.  
  1390.    until AllDone
  1391.    else repeat
  1392.  
  1393.       SideSumCga; VertSumCga;
  1394.       SideSumCga; VertSumCga;
  1395.       SideSumCga; VertSumCga;
  1396.  
  1397.       if keypressed then HandleMenu;
  1398.  
  1399.    until AllDone;
  1400.  
  1401.    Final;
  1402.    SetVideoMode(OldMode);  { Nice guys restore the mode. }
  1403.    end.
  1404.