home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / BOI120.ZIP / UNITS.ZIP / SUPPORT.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1990-12-12  |  15.1 KB  |  451 lines
  1. {$D-}  { Disable Debug Information }
  2. {$S-}  { Disable Stack Checking }
  3. {$V-}  { Disable String Checking }
  4.  
  5. Unit Support;
  6. { Part of BBS Onliner Interface }
  7. { Copyright (C) 1990 Andrew J. Mead
  8.   All Rights Reserved. }
  9.  
  10. { original version 9/5/90
  11.   history found in IOLIB.PAS }
  12.  
  13. INTERFACE
  14.  
  15. Var
  16.   playerpoints : longint;  { player score variable }
  17.  
  18. Procedure ABORTGAME(       { notify player that his screen is not big enough }
  19.     limit : byte);         { minimum screen lines needed }
  20.  
  21. Procedure LINEWRITE(       { write a menu option }
  22.     lstr : string;         { menu selection to write }
  23.     lcheck : boolean);     { highlight option indicator }
  24.  
  25. Procedure QUERYUSER;       { prompt player for color choice }
  26.  
  27. Function WRITECOPY(        { display copyright screen }
  28.     gamename,              { name of current game }
  29.     version,               { version of current game }
  30.     regnum,                { regisration number of current game }
  31.     regstr,                { name of BBS }
  32.     homestr   : string;    { name of at home version of game }
  33.     isreg,                 { registered game indicator }
  34.     ishome,                { at home version of game exists indicator }
  35.     askq      : boolean)   { check for Instructions request indicator }
  36.               : boolean;   { returns true if Instructions are requested }
  37.  
  38. Procedure ENDGAME(         { Do Hall of Fame Housekeeping }
  39.     gamename,              { name of current program }
  40.     playstr,               { classification string (Player,Trader,etc...) }
  41.     regstr,                { name of BBS }
  42.     hoffile   : string;    { name of Text Hall of Fame }
  43.     isreg,                 { registered game indicator }
  44.     isvalid,               { game results are valid for HOF listing indicator }
  45.     iscash,                { cash/points value indicator }
  46.     gethigh   : boolean);  { higher/lower scores are better }
  47.  
  48. IMPLEMENTATION
  49.  
  50. Uses
  51.   boidecl,
  52.   getcmbbs,
  53.   iolib,
  54.   dos;
  55.  
  56. Var
  57.   inchar : char;                 { standard input character }
  58.   etemp  : boolean;
  59.  
  60. Procedure ABORTGAME;
  61.   begin {* AbortGame *}
  62.     ClrPortScr;
  63.     PortBackground(black);
  64.     TextPortColor(white);
  65.     TextPortColor(lightgray);
  66.     SendString('Your setup shows that your screen only displays ',false);
  67.     TextPortColor(white);
  68.     SendString(IntStr(pagelength,0),false);
  69.     TextPortColor(lightgray);
  70.     SendString(' lines.',true);
  71.     SendString('This game requires a minimum of ',false);
  72.     TextPortColor(white);
  73.     SendString(IntStr(limit,0),false);
  74.     TextPortColor(lightgray);
  75.     SendString(' lines.',true);
  76.     SendString('Check your BBS settings and make the needed changes before trying again.',true);
  77.     SendString('Thank you.  Please press almost any key to return to your BBS. ',false);
  78.     ClearBuffers;
  79.     inchar := ReadPortKey;
  80.     SendString('',true);
  81.     SendString('',true);
  82.     SendString('Please wait... returning to the BBS.',true);
  83.     EndPort;
  84.     Halt
  85.   end;  {* AbortGame *}
  86.  
  87. Procedure LINEWRITE(lstr : string; lcheck : boolean);
  88.   begin {* LineWrite *}
  89.     SendString(lstr[1],false);
  90.     if lcheck then TextPortColor(white);
  91.     SendString(lstr[2],false);
  92.     TextPortColor(lightgray);
  93.     SendString(copy(lstr,3,length(lstr)),false)
  94.   end;  {* LineWrite *}
  95.  
  96. Procedure QUERYUSER;
  97.   begin {* QueryUser *}
  98.     ClrPortScr;
  99.     TextPortColor(white);
  100.     SendString('Before we get started, please answer the following question.',true);
  101.     SendString('',true);
  102.     TextPortColor(lightgray);
  103.     SendString('Do you want color? [Y/N] ',false);
  104.     repeat inchar := upcase(ReadPortKey) until inchar in ['Y','N'];
  105.     if inchar = 'Y' then
  106.       begin
  107.         DoColor := true;
  108.         PortColor(lightblue,white);
  109.         SendString('Yes',true)
  110.       end
  111.     else
  112.       begin
  113.         DoColor := false;
  114.         TextPortColor(white);
  115.         SendString('No',true)
  116.       end;
  117.     SendString('',true);
  118.     TextPortColor(white);
  119.     SendString('Thank you.  Please enjoy the game.',true)
  120.   end;  {* QueryUser *}
  121.  
  122. Function WRITECOPY;
  123.   begin {* WriteCopy *}
  124.     etemp := doecho;
  125.     if not dolocal then doecho := true;
  126.     ClrPortScr;
  127.     PortBackground(black);
  128.     PortColor(yellow,white);
  129.     SendString(gamename,false);
  130.     PortColor(cyan,lightgray);
  131.     SendString(' version ' + version + '.',true);
  132.     SendString('Program Copyright (C) 1990 Andrew J. Mead',true);
  133.     SendString('All Rights Reserved.',true);
  134.     SendString('',true);
  135.     TextPortColor(white);
  136.     SendString('BBS Onliner Interface',false);
  137.     PortColor(cyan,lightgray);
  138.     SendString(' version ' + interfaceversion + '.',true);
  139.     SendString('Copyright(C) 1990 Andrew J. Mead',true);
  140.     SendString('All Rights Reserved.',true);
  141.     SendString('Contact: POB 1155 Chapel Hill, NC 27514-1155',true);
  142.     SendString('',true);
  143.     if isreg then
  144.       begin
  145.         SendString('Your SysOp has registered this game.  SN: '+regnum,true);
  146.         PortColor(random(7) + 1,white);
  147.         SendString(regstr,true);
  148.         PortColor(cyan,lightgray);
  149.         SendString('Support your local BBSs that support ShareWare.',true)
  150.       end
  151.     else SendString('This is a Test Copy of '+gamename+'.  If you like it, please register.',true);
  152.     SendString('',true);
  153.     if ishome then
  154.         SendString('Ask your SysOp for '+homestr+', the home version of this popular game.',true);
  155.     GotoPorTXY(1,pagelength);
  156.     PortColor(lightmagenta,lightgray);
  157.     if askq then SendString('Press ''I'' for instructions, or any other key to begin. ',false)
  158.     else SendString('Press almost any key to begin. ',false);
  159.     ClearBuffers;
  160.     inchar := upcase(ReadPortKey);
  161.     doecho := etemp;
  162.     WriteCopy := inchar = 'I'
  163.   end;  {* WriteCopy *}
  164.  
  165. Procedure ENDGAME;
  166.   type
  167.     str40    = string [40];
  168.     hofrec   = record
  169.         hname  : str40;
  170.         amount : longint;
  171.         month  : word;
  172.         date   : word;
  173.         year   : word
  174.       end;
  175.     hofarr   = array [1..24] of hofrec;
  176.  
  177.   var
  178.     e        : file of hofarr;
  179.     et       : text;
  180.     hof      : hofarr;
  181.     eloop    : byte;
  182.     etemp    : byte;
  183.     dohof    : boolean;
  184.     dummy    : word;
  185.     tempname : str40;
  186.     hofdex   : byte;
  187.     alltimehigh : boolean;
  188.     updatetext : boolean;
  189.     nextmonth : boolean;
  190.     usetemp  : boolean;
  191.     topten   : boolean;
  192.     noalt    : boolean;
  193.     eyear    : word;
  194.     emonth   : word;
  195.     edate    : word;
  196.     edow     : word;
  197.     workline : string;
  198.     firstmatch : byte;
  199.     totalmatch : byte;
  200.  
  201.   Function HOFCHECK : boolean;
  202.     var
  203.       hloop : byte;
  204.  
  205.     begin {* HofCheck *}
  206.       if usename then
  207.         begin
  208.           for hloop := 1 to 20 do if username = hof[hloop].hname then
  209.             begin
  210.               Inc(totalmatch);
  211.               if totalmatch = hoflim then firstmatch := hloop
  212.             end;
  213.           HofCheck := playerpoints > hof[firstmatch].amount
  214.         end
  215.       else HofCheck := true
  216.     end;  {* HofCheck *}
  217.  
  218.   Function GOODSCORE : boolean;
  219.     begin {* EndGame,fGoodScore *}
  220.       if gethigh then GoodScore := (playerpoints > hof[20].amount)
  221.       else GoodScore := (playerpoints < hof[20].amount) or (hof[20].amount = 0)
  222.     end;  {* EndGame,fGoodScore *}
  223.  
  224.   Function BETTERSCORE : boolean;
  225.     begin {* EndGame,fBetterScore *}
  226.       if gethigh then BetterScore := (playerpoints > hof[hofdex - 1].amount)
  227.       else BetterScore := (playerpoints < hof[hofdex - 1].amount) or (hof[20].amount = 0)
  228.     end;  {* EndGame,fBetterScore *}
  229.  
  230.   begin {* EndGame *}
  231.     updatetext := false;
  232.     nextmonth := false;
  233.     firstmatch := 20;
  234.     totalmatch := 0;
  235.     usetemp := usename;
  236.     GetDate(eyear,emonth,edate,edow);
  237.     assign(e,gamepath + hoffile);
  238.     if Exist(gamepath + hoffile) then
  239.       begin
  240.         reset(e);
  241.         read(e,hof);
  242.         close(e);
  243.         if (hof[1].amount > 0) and (emonth <> hof[1].month) then
  244.           begin
  245.             nextmonth := true;
  246.             updatetext := true;
  247.             move(hof[1],hof[21],3*sizeof(hof[21]));
  248.             for eloop := 1 to 20 do with hof[eloop] do
  249.               begin
  250.                 hname := '';
  251.                 amount := 0;
  252.                 month := emonth;
  253.                 date := edate;
  254.                 year := eyear
  255.               end;
  256.             rewrite(e);
  257.             write(e,hof);
  258.             close(e)
  259.           end
  260.       end
  261.     else
  262.       begin
  263.         fillchar(hof,sizeof(hof),0);
  264.         for eloop := 1 to 24 do with hof[eloop] do
  265.           begin
  266.             hname := '';
  267.             amount := 0;
  268.             month := emonth;
  269.             date := edate;
  270.             year := eyear
  271.           end
  272.       end;
  273.     if iscash then
  274.       begin
  275.         SendString('Your game has ended.  Your final holdings are worth ',false);
  276.         TextPortColor(white);
  277.         SendString('$' + IntStr(playerpoints,0),false);
  278.         TextPortColor(lightgray);
  279.         SendString('.',true)
  280.       end
  281.     else
  282.       begin
  283.         SendString('Your game has ended. Your final score is ',false);
  284.         TextPortColor(white);
  285.         SendString(IntStr(playerpoints,0),false);
  286.         TextPortColor(lightgray);
  287.         SendString(' points.',true)
  288.       end;
  289.     dohof := false;
  290.     if GoodScore and isvalid and HofCheck then
  291.       begin
  292.         dohof := true;
  293.         SendString('You have qualified for the Hall of Fame',false);
  294.         if usename then
  295.           begin
  296.             tempname := username;
  297.             SendString('.',true)
  298.           end
  299.         else
  300.           begin
  301.             SendString(', please enter your name:',true);
  302.             tempname[0] := chr(0);
  303.             TextPortColor(white);
  304.             GetString(tempname)
  305.           end;
  306.         TextPortColor(lightgray);
  307.         hofdex := 21;
  308.         while BetterScore and (hofdex > 1) do Dec(hofdex);
  309.         move(hof[hofdex],hof[hofdex + 1],(firstmatch - hofdex) * sizeof(hofrec));
  310.         hof[hofdex].hname := tempname;
  311.         hof[hofdex].amount := playerpoints;
  312.         GetDate(hof[hofdex].year,hof[hofdex].month,hof[hofdex].date,dummy)
  313.       end;
  314.     SendString('',true);
  315.     SendString('',true);
  316.     PortWindow(1,1,80,pagelength);
  317.     GotoPortXY(1,Min(24,pagelength));
  318.     SendString('Press almost any key to see the Hall of Fame. ',false);
  319.     ClearBuffers;
  320.     inchar := ReadPortKey;
  321.     usename := false;
  322.     ClrPortScr;
  323.     TextPortColor(white);
  324.     etemp := length(gamename);
  325.     while length(gamename) < 50 do gamename := ' ' + gamename;
  326.     SendString(gamename + ' Hall Of Fame',true);
  327.     Delete(gamename,1,length(gamename) - etemp);
  328.     TextPortColor(lightgray);
  329.     SendString('                                  Player  Rank       Amount    Date',true);
  330.     for eloop := 1 to 20 do with hof[eloop] do if amount > 0 then
  331.       begin
  332.         if dohof and (eloop = hofdex) then PortColor(lightblue,white)
  333.         else if eloop = 1 then TextPortColor(white) else TextPortColor(lightgray);
  334.         SendString(PadStr(hname,40) + IntStr(eloop,5) + IntStr(amount,14) +
  335.             IntStr(month,5) + '/' + IntStr(date,0) +'/' + IntStr(year,0),false);
  336.         if dohof and (eloop = hofdex) then SendString(' <--',true)
  337.         else SendString('',true)
  338.       end;
  339.     SendString('',true);
  340.     alltimehigh := false;
  341.     if dohof then
  342.        begin
  343.         if (hofdex = 1) and (playerpoints > hof[24].amount) then
  344.           begin
  345.             alltimehigh := true;
  346.             move(hof[hofdex],hof[24],sizeof(hof[24]));
  347.             updatetext := true;
  348.           end
  349.         else if hofdex <= 10 then
  350.           begin
  351.             topten := true;
  352.             updatetext := true
  353.           end;
  354.         rewrite(e);
  355.         write(e,hof);
  356.         close(e)
  357.       end;
  358.     if updatetext then
  359.       begin
  360.         assign(et,texthof);
  361.         rewrite(et);
  362.         workline := regstr + ' - ' + gamename + ' - Hall Of Fame';
  363. { 1}    writeln(et,workline:length(workline) div 2 + 40);
  364. { 2}    writeln(et);
  365.         if hof[24].amount > 0 then
  366.           begin
  367.             workline := '- All Time High Score -';
  368. { 3}        writeln(et,workline:length(workline)div 2 + 45);
  369. { 4}        writeln(et,hof[24].hname:40,' ',hof[24].amount:10,' ',
  370.                 hof[24].month:0,'/',hof[24].date:0,'/',hof[24].year:0)
  371.           end;
  372. { 5}    writeln(et);
  373.         if hof[21].amount > 0 then
  374.           begin
  375.             workline := '- Last Month''s Top Three -';
  376. { 6}        writeln(et,workline:length(workline) div 2 + 45);
  377.             for eloop := 21 to 23 do if hof[eloop].amount > 0 then
  378. { 7- 9}         writeln(et,hof[eloop].hname:40,' ',hof[eloop].amount:10,' ',
  379.                 hof[eloop].month:0,'/',hof[eloop].date:0,'/',hof[eloop].year:0);
  380. {10}         writeln(et)
  381.           end;
  382.         workline := '- This Month''s Top ' + playstr + ' -';
  383. {11}    writeln(et,workline:length(workline) div 2 + 45);
  384.         for eloop := 1 to 10 do if hof[eloop].amount > 0 then
  385. {12-21}     writeln(et,hof[eloop].hname:40,' ',hof[eloop].amount:10,' ',
  386.             hof[eloop].month:0,'/',hof[eloop].date:0,'/',hof[eloop].year:0);
  387.         close(et)
  388.       end;
  389.     SendString('',true);
  390.     TextPortColor(lightgray);
  391.     if alltimehigh then SendString('Your final amount was the ALL-TIME HIGH!!',true)
  392.     else
  393.       begin
  394.         SendString('Your final amount was ',false);
  395.         TextPortColor(white);
  396.         if iscash then
  397.           begin
  398.             SendString('$' + IntStr(playerpoints,0),false);
  399.             TextPortColor(lightgray);
  400.             SendString('.',true)
  401.           end
  402.         else
  403.           begin
  404.             SendString(IntStr(playerpoints,0),false);
  405.             TextPortColor(lightgray);
  406.             SendString(' points.',true)
  407.           end
  408.       end;
  409.     if doagain and ((not usetime) or ((not timexp) and (againtime < LeftTime))) then
  410.       begin
  411.         TextPortColor(lightgray);
  412.         if usetime then SendString('You have less than '+IntStr(LeftTime,0)+' minutes remaining.',true);
  413.         SendString('Would you like to play again? [Y/N] ',false);
  414.         ClearBuffers;
  415.         TextPortColor(white);
  416.         repeat inchar := ReadPortKey until upcase(inchar) in ['Y','N'];
  417.         SendString(inchar,true);
  418.         if upcase(inchar) = 'N' then doagain := false else usename := usetemp
  419.       end
  420.     else doagain := false;
  421.     if not doagain then
  422.       begin
  423.         TextPortColor(lightgray);
  424.         if isreg then
  425.           begin
  426.             SendString('Press almost any key to return to ',false);
  427.             PortColor(random(7) + 1,white);
  428.             SendString(regstr,false);
  429.             TextPortColor(lightgray);
  430.             SendString('.',false)
  431.           end
  432.         else SendString('Press almost any key to return to your BBS.',false);
  433.         ClearBuffers;
  434.         inchar := ReadPortKey;
  435.         SendString('',true);
  436.         SendString('',true);
  437.         TextPortColor(lightgray);
  438.         if isreg then
  439.           begin
  440.             SendString('Please wait.  Returning to ',false);
  441.             PortColor(random(7) + 1,white);
  442.             SendString(regstr,false);
  443.             TextPortColor(lightgray);
  444.             SendString('.',true)
  445.            end
  446.          else SendString('Please wait.  Returning to the BBS.',true)
  447.       end
  448.   end;  {* EndGame *}
  449.  
  450. end. Unit
  451.