home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / QWIK30.ZIP / QWIKDEMO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-08-31  |  13.7 KB  |  395 lines
  1. { QwikDemo.pas - Demo program for QWIK screen procedures.   ver 3.0, 08-31-87 }
  2. { Demo has been programmed best for color cards.  EGA and VGA should be in
  3.   25-line mode. }
  4.  
  5. {$I qwik30.inc}
  6.  
  7. type
  8.   BrdrRec = record                 { For Qbox procedure }
  9.               TL,TH,TR,LV,RV,BL,BH,BR: string[1];
  10.             end;
  11.  
  12. var
  13.   Row,Rows,Col,Cols,Ctr,Step,Rstep,ColMax,
  14.   Count,Attrib,i,wait,CRTCols: integer;
  15.   OldCursor,Fgrnd,Bgrnd:       integer;
  16.   BrdrAttr, WndwAttr:          integer;
  17.   SavedBlock, PopUpBlock: array [1..4000] of byte;
  18.   BlkRow,BlkCol,V:                           byte;
  19.   Tattr: byte absolute Dseg:$0008;   { Location of Turbo's attribute }
  20.   ColL,ColR: array [1..3] of byte;
  21.   Strng,Strng2,NumStr:   string[75];
  22.   Data: array [1..9 ] of string[40];
  23.   PC:   array [1..13] of string[40];
  24.   Rnum:                  Real;
  25.   Ch:                    char;
  26.  
  27. const      { These are double lines for Qbox }
  28.   Border: BrdrRec =  (TL:'╔';TH:'═';TR:'╗';
  29.                       LV:'║';       RV:'║';
  30.                       BL:'╚';BH:'═';BR:'╝');
  31.  
  32. { Qbox is an application of QWIK screen procedures.  It can make fast
  33.   pop-up menus.  See WINDOWxx.ARC for more applications. }
  34. procedure Qbox (Row,Col,Rows,Cols: byte; WndwAttr,BrdrAttr: integer;
  35.                                                       Brdr: BrdrRec);
  36. begin
  37.   if (Rows>=2) and (Cols>=2) then
  38.   begin
  39.     with Brdr do
  40.     begin
  41.       QwriteV (Row       ,Col                     ,BrdrAttr,TL);
  42.       Qfill   (Row       ,Col+1     ,1     ,Cols-2,BrdrAttr,TH);
  43.       QwriteV (Row       ,Col+Cols-1              ,BrdrAttr,TR);
  44.       Qfill   (Row+1     ,Col       ,Rows-2,1     ,BrdrAttr,LV);
  45.       Qfill   (Row+1     ,Col+Cols-1,Rows-2,1     ,BrdrAttr,RV);
  46.       QwriteV (Row+Rows-1,Col                     ,BrdrAttr,BL);
  47.       Qfill   (Row+Rows-1,Col+1     ,1     ,Cols-2,BrdrAttr,BH);
  48.       QwriteV (Row+Rows-1,Col+Cols-1              ,BrdrAttr,BR);
  49.       Qfill   (Row+1     ,Col+1     ,Rows-2,Cols-2,WndwAttr,' ')
  50.     end
  51.   end
  52. end;
  53.  
  54. procedure PromptKey;
  55. begin
  56.   Qwrite (25,CRTcols-19,-1,'press any key ...');
  57.   read (kbd,ch);
  58. end;
  59.  
  60. procedure CheckCursor;
  61. var CursorMode: integer absolute $0040:$0060;
  62. begin
  63.   if ActiveDD=MDAmono then
  64.     if CursorMode=$0607 then
  65.       CursorChange($0B0C,OldCursor);
  66. end;
  67.  
  68. begin
  69. { --- Set up data --- }
  70.                              { If you set a mode, do it first before Qinit! }
  71.                              { Please!  Test a mode first to see if it is
  72.                                different than what you want; then change if
  73.                                necessary.  Otherwise, the screen jumps. }
  74.   Qinit;                     { << <<  Required intializing statement !! }
  75.   CRTCols:=CRTColumns;
  76.   if Vmode<>7 then
  77.     begin
  78.       Qfill   (1,1,25,CRTcols,7,' ');
  79.       QwriteC (11,1,CRTcols,-1,'(1) 40 column mode');
  80.       QwriteC (12,1,CRTcols,-1,'(2) 80 column mode');
  81.       QwriteC (14,1,CRTcols,-1,'Which mode [1,2]? ');
  82.       GotoRC  (14,CRTcols div 2 + 9);
  83.       repeat
  84.         read (kbd,ch);
  85.       until ch in ['1','2'];
  86.       V:=Vmode;
  87.       case ch of
  88.         '1': case V of
  89.                BW80: V:=BW40;
  90.                C80:  V:=C40;
  91.              end;
  92.         '2': case V of
  93.                BW40: V:=BW80;
  94.                C40:  V:=C80;
  95.              end;
  96.       end;
  97.       if V<>Vmode then
  98.         begin
  99.           TextMode(V);
  100.           Qinit;           { << Do Qinit again after change of mode!! }
  101.         end;
  102.     end;
  103.   Wait:=500;               { One unit of wait in milliseconds for demo. }
  104.   Strng:=   ' Q Screen Procedure ';
  105.   Strng2:=  ' QWIK Screen Procedures ';
  106.   Data[1]:= '1';
  107.   Data[2]:= '22';
  108.   Data[3]:= '333';
  109.   Data[4]:= Strng;
  110.   Data[5]:= 'Odd  Length';
  111.   Data[6]:= 'Even  Length';
  112.   Data[7]:= '18 characters wide';
  113.   Data[8]:= '19 characters width';
  114.   Data[9]:= 'Margin to Margin width';
  115.   PC[1]:=  'COMPUTERS:           ADAPTERS:';
  116.   PC[2]:=  '------------------   ---------';
  117.   PC[3]:=  'IBM PC               MDA';
  118.   PC[4]:=  'IBM XT               CGA';
  119.   PC[5]:=  'IBM AT               EGA';
  120.   PC[6]:=  'IBM PCjr             MCGA';
  121.   PC[7]:=  'IBM PC Convertible   VGA';
  122.   PC[8]:=  'IBM PS/2 Model 25    8514/A';
  123.   PC[9]:=  'IBM PS/2 Model 30';
  124.   PC[10]:= 'IBM PS/2 Model 50';
  125.   PC[11]:= 'IBM PS/2 Model 60';
  126.   PC[12]:= 'IBM PS/2 Model 80';
  127.   PC[13]:= 'IBM 3270';
  128.  
  129. { --- Initial screen --- }
  130.   CheckCursor;
  131.   CRTCols:=CRTColumns;
  132.   CursorOff;
  133.   Qfill    ( 1, 1,25,CRTCols,blue shl 4 + white,' ');      {  Clear Screen }
  134.   QwriteCV (11, 1,CRTCols,blue shl 4 + yellow, Strng2);
  135.   QwriteC  (13, 1,CRTCols, -1,'Your screen is about to explode.');
  136.   QwriteC  (14, 1,CRTCols, -1,'Hold on to your seat ...');
  137.   Delay    (Wait*5);
  138.  
  139. { --- Explosion of Boxes --- }
  140.   Qfill    (11, 1, 4,CRTCols, -1,' ');          {  Clear Lines }
  141.   Qattr    ( 1, 1,25,CRTCols,LightGray shl 4);  {  Change screen attribute }
  142.   Ctr:=CRTCols div 2;
  143.   for step:=2 to Ctr-2 do
  144.   begin
  145.     if Step>24 then Rstep:=12 else Rstep:=Step shr 1;
  146.     for Count:=1 to 20 do
  147.     begin
  148.       Row:= 13 - Rstep + random(Rstep+2);
  149.       Rows:= Rstep;
  150.       Cols:= Rstep + Rstep + Rstep shr 2;
  151.       if step<=24 then Col:=Ctr-Cols+random(Cols+1)
  152.         else  Col:= Ctr - 1 - step + random(step+step-22);
  153.       Fgrnd:= random (16);
  154.       Bgrnd:= random (8);
  155.       if Bgrnd=Fgrnd then Fgrnd:=Fgrnd + 1;
  156.       Attrib:= (Bgrnd shl 4) + Fgrnd;
  157.       Qfill (Row,Col,Rows,Cols,Attrib,#178);
  158.     end
  159.   end;
  160.  
  161.   QfillC  (10, 1,CRTCols, 6,34,Red   shl 4,' ');
  162.   QfillC  (11, 1,CRTCols, 4,30,Brown shl 4,' ');
  163.   Tattr:= Red shl 4 + yellow;
  164.   QwriteCV(12, 1,CRTCols,Tattr,Strng2);
  165.   QwriteC (13, 1,CRTCols,Tattr,'      Version  3.0      ');
  166.  
  167.   { --- Save Screen for Page Demo --- }
  168.   if MaxPage>0 then
  169.   begin
  170.     QstoreToMem ( 1, 1,25,CRTCols,SavedBlock);
  171.     QwritePage  (1);
  172.     QstoreToScr ( 1, 1,25,CRTCols,SavedBlock);
  173.     QwritePage  (0);
  174.   end;
  175.   { --- End of Save Screen --- }
  176.   Delay   (Wait*4);
  177.   Tattr:= Blue shl 4 + white;
  178.   QwriteC ( 6, 1,CRTCols,Tattr,' Qwrite will write with new attributes ');
  179.   QwriteC ( 7, 1,CRTCols,Tattr,' that you specify direct to the screen.');
  180.   Delay   (Wait*6);
  181.   QwriteC (18, 1,CRTCols, -1,'Qwrite will also use existing attributes');
  182.   QwriteC (19, 1,CRTCols, -1,'   when you do not even know or care.   ');
  183.                         { highlight the word 'existing' }
  184.   QattrC  (18, 6,CRTCols+5,1,10,LightRed shl 4 + white);
  185.   Delay   (wait*10);
  186.   QwriteC (21, 1,CRTCols,Tattr,' Say Goodbye to this screen. ');
  187.  
  188.   Delay   (wait*3);
  189.   { --- Disintigrate Screen --- }
  190.   for i:=1 to 5000 do
  191.   begin
  192.     Row:=random(25)+1;
  193.     Col:=random(CRTCols)+1;
  194.     Qfill (row,col, 1, 1,Black,' ');
  195.   end;
  196.  
  197. { --- Compatible computer and adapter list --- }
  198.   Qfill   ( 1, 1,25,CRTCols,white,' ');       {  Clear Screen }
  199.   QwriteC ( 4, 1,CRTCols, -1,'QWIK Screen Procedures work on these IBM');
  200.   QwriteC ( 5, 1,CRTCols, -1,'or compatible computers and adapters:');
  201.   delay   (wait*5);
  202.   Col:=(CRTCols-30) shr 1;
  203.   for Row:=7 to 19 do
  204.     QwriteV (Row,Col, -1,PC[Row-6]);
  205.   QwriteC ( 22, 1,CRTcols, -1,'Working text modes 0,1,2,3, or 7!');
  206.   PromptKey;
  207.  
  208. { --- Qwrite with Str on Reals Demo --- }
  209.   Qfill   ( 1, 1,25,CRTCols,yellow,' ');       {  Clear Screen }
  210.   QwriteC ( 2, 1,CRTCols, -1,'QwriteV with Turbo''s Str will write');
  211.   QwriteC ( 3, 1,CRTCols, -1,'reals and integers faster:');
  212.   Delay   (wait*7);
  213.   Rnum:=1.23E+05;
  214.   for col:=0 to CRTCols div 20 -1 do
  215.   for row:=5 to 24 do
  216.   begin
  217.     Rnum:=Rnum+1;
  218.     Str(Rnum:12,NumStr);
  219.     QwriteV (row,col*20+4, -1,NumStr);
  220.   end;
  221.   PromptKey;
  222.  
  223. { --- Centering Demo --- }
  224.   Qfill   ( 1, 1,25,CRTCols,LightGray shl 4,' ');       {  Clear Screen }
  225.   QwriteC ( 2, 1,CRTCols, -1,'QwriteC and QwriteCV will automatically');
  226.   QwriteC ( 3, 1,CRTCols, -1,'center your data ...');
  227.   QwriteC ( 4, 1,CRTCols, -1,'(Odd breaks are shifted to the left.)');
  228.   Delay   (wait*6);
  229.  
  230.   { - Set up columns for varying column modes - }
  231.   ColL[2]:=1; ColR[2]:=CRTCols;
  232.   if CRTCols<80 then
  233.   begin
  234.     ColL[1]:=ColL[2]; ColL[3]:=CRTCols div 2;
  235.     ColR[1]:=ColR[2]; ColR[3]:=CRTCols div 2;
  236.   end
  237.   else
  238.   begin
  239.     ColL[1]:=3; ColR[1]:=26; ColL[3]:=CRTCols-14; ColR[3]:=CRTCols-14;
  240.   end;
  241.  
  242.   QwriteC ( 7,ColL[1],ColR[1], -1,'between margins ...');
  243.   Qbox    ( 8,(ColL[1]+ColR[1]) shr 1 -12,15,26,white,LightGray,Border);
  244.   Delay   (wait*3);
  245.   for row:=11 to 19 do
  246.     QwriteCV (row,ColL[1],ColR[1], -1, Data[row-10]);
  247.   Delay   (wait*5);
  248.  
  249.   QwriteC ( 7,ColL[2],ColR[2], -1,'between two columns ...');
  250.   QfillC  ( 9,ColL[2],ColR[2],13,24,yellow,' ');     {  Clear window }
  251.   for row:= 9 to 21 do
  252.     QwriteC  (row,ColL[2],ColR[2], -1,'><');         {  Show two columns  }
  253.   Delay   (wait*3);
  254.   for row:=11 to 19 do
  255.     QwriteCV (row,ColL[2],ColR[2],LightRed, Data[row-10]);
  256.   Delay   (wait*5);
  257.  
  258.   QwriteC ( 7,ColL[3],ColR[3], -1,'or on a center line ...');
  259.   QfillC  ( 8,ColL[3],ColR[3],15,27,LightGray shl 4,' ');     {  Clear window }
  260.   for row:=09 to 21 do                 {  Show center line  }
  261.     QwriteC  (row,ColL[3],ColR[3],LightGray shl 4,'|');
  262.   Delay   (wait*3);
  263.   for row:=11 to 19 do
  264.     QwriteCV (row,ColL[3],ColR[3], -1, Data[row-10]);
  265.   PromptKey;
  266.  
  267. { --- Qfill Demo --- }
  268.   Qfill   ( 1, 1,25,CRTCols,white,' ');       {  Clear Screen }
  269.   QwriteC ( 2, 1,CRTCols, -1,'Qfill as well as Qattr can fill');
  270.   QwriteC ( 3, 1,CRTCols, -1,'your screen in several ways.');
  271.   Delay   (wait*7);
  272.  
  273.   QwriteC ( 7, 1,CRTCols, -1,'by rows ...');
  274.   Delay   (wait*3);
  275.   for row:= 9 to 24 do
  276.     Qfill (row, 2, 1,CRTCols-2,9+row,Chr(row+56));
  277.   Delay   (wait*5);
  278.  
  279.   Qfill   ( 7, 1,19,CRTCols,white,' ');       {  Clear Lines }
  280.   QwriteC ( 7, 1,CRTCols, -1,'by columns ...');
  281.   Delay   (wait*3);
  282.   for col:=2 to CRTCols-2 do
  283.     Qfill ( 9,col,16,1,16+col,chr(col+63));
  284.   Delay   (wait*5);
  285.  
  286.   Qfill   ( 7, 1,19,CRTCols,white,' ');       {  Clear Lines }
  287.   QwriteC ( 7, 1,CRTCols, -1,'or by row-by-column blocks ...');
  288.   Delay   (wait*3);
  289.     Qfill ( 9,2,16,CRTCols-2,Blue shl 4 + yellow,'!');
  290.   Delay   (wait*5);
  291.  
  292. { --- Qbox demo --- }
  293.   Qfill   ( 1, 1,25,CRTCols,LightGray shl 4,' ');       {  Clear Screen }
  294.   QwriteC ( 2, 1,CRTCols, -1,'Qbox is an application procedure made');
  295.   QwriteC ( 3, 1,CRTCols, -1,'from QwriteV and Qfill.  Together they');
  296.   QwriteC ( 4, 1,CRTCols, -1,'can make windows with borders easy.');
  297.   Delay   (wait*9);
  298.   QwriteC (14, 1,CRTCols, -1,'How about 100 of them? ... ');
  299.   Delay   (wait*4);
  300.   ColMax:=CRTCols-21;
  301.   for i:=1 to 100 do
  302.   begin
  303.     row:=random (10)+6;
  304.     col:=random (ColMax)+2;
  305.     BrdrAttr:=random (128);
  306.     WndwAttr:=random (128);
  307.     Qbox (row,col,10,20,BrdrAttr,WndwAttr,Border);
  308.   end;
  309.   Delay   (wait*10);
  310.  
  311. { --- Block Transfer and PopUp Demo --- }
  312.   Qfill   ( 1, 1,25,CRTCols,yellow,'?');       {  Clear Screen }
  313.   QfillC  (10, 1,CRTCols, 6,40,Brown shl 4,' ');    {  Clear Block }
  314.   QwriteC (11, 1,CRTCols, -1,'Qstore will save and restore');
  315.   QwriteC (12, 1,CRTCols, -1,'Row-by-Column blocks on your display.');
  316.   QwriteC (13, 1,CRTCols, -1,'It is so fast, I have to slow it down');
  317.   QwriteC (14, 1,CRTCols, -1,'so you can see it.');
  318.     Delay (wait*11);
  319.     BlkRow:=8;
  320.     BlkCol:=CRTCols div 2 - 9;
  321.   QstoreToMem(BlkRow,BlkCol,10,20,SavedBlock);
  322.   { --- Make a Pop Up Menu --- }
  323.   Qbox (BlkRow,BlkCol,10,20,Blue shl 4 + yellow,Blue shl 4 + Brown,Border);
  324.   QwriteC (BlkRow+4,BlkCol,BlkCol+20, -1,'Pop Up');
  325.   QwriteC (BlkRow+5,BlkCol,BlkCol+20, -1,'Menu');
  326.   { --- End of Pop Up Menu --- }
  327.   QstoreToMem(BlkRow,BlkCol,10,20,PopUpBlock);
  328.     Delay (wait*4);
  329.   ColMax:=CRTCols-20;
  330.   for i:=1 to 30 do
  331.   begin
  332.     Delay (Wait div 2);
  333.     QstoreToScr(BlkRow,BlkCol,10,20,SavedBlock);
  334.     BlkRow:=random(15)+1;
  335.     BlkCol:=random(ColMax)+1;
  336.     QstoreToMem(BlkRow,BlkCol,10,20,SavedBlock);
  337.     QstoreToScr(BlkRow,BlkCol,10,20,PopUpBlock);
  338.   end;
  339.  
  340. { --- Page Demo --- }
  341.   if MaxPage>0 then
  342.   begin
  343.     QviewPage  (1);
  344.     QwritePage (1);
  345.     Tattr:= Blue shl 4 + yellow;
  346.     QwriteC (20, 1,CRTCols,Tattr,' Remember this page?  ');
  347.     QwriteC (21, 1,CRTCols,Tattr,' It wasn''t destroyed, but saved using ');
  348.     QwriteC (22, 1,CRTCols,Tattr,' Qstores and placed on a new page. ');
  349.     Delay (wait*14);
  350.     QwritePage (0);
  351.     QviewPage  (0);
  352.   end;
  353.  
  354. { --- Attribute Demo --- }
  355.   Qfill   ( 1, 1,25,CRTCols,green shl 4 + green,' ');    {  Clear Screen }
  356.   Tattr:= green shl 4 + white;
  357.   QwriteC ( 2, 1,CRTCols,Tattr,'QWIK Screen Procedures are hiding data');
  358.   QwriteC ( 3, 1,CRTCols,Tattr,'on your screen ...');
  359.   Cols:=CRTCols div 20;
  360.   if Vmode=7 then Tattr:=0 else Tattr:= green shl 4 + green;
  361.   for col:=0 to Cols-1 do
  362.   for row:=5 to 20 do
  363.     QwriteV (row,20*col+1,Tattr,Strng);
  364.   Delay   (wait*8);
  365.  
  366.   Qfill   ( 2, 1, 2,CRTCols,-1,' ');        {  Clear Lines }
  367.   Tattr:= green shl 4 + white;
  368.   QwriteC ( 2, 1,CRTCols,Tattr,'Qattr can show them -');
  369.   QwriteC ( 3, 1,CRTCols,Tattr,'by merely changing the attribute!');
  370.   Delay   (wait*6);
  371.  
  372.   { --- Try using Turbo's color procedures this time --- }
  373.   TextColor (Black); TextBackground (Green);
  374.   Qattr   ( 5, 1,16,CRTCols,Tattr);         {  Reveal Data }
  375.   Delay   (wait*5);
  376.  
  377.   Qfill   ( 2, 1, 2,CRTCols,-1,' ');        {  Clear Lines }
  378.   TextColor (yellow); TextBackground (Green);
  379.   QwriteC ( 2, 1,CRTCols,Tattr,'Or even just emphasize what''s seen ...');
  380.   for i:=1 to 500 do
  381.   begin
  382.     Row:= random(16) + 5;
  383.     Col:= random(Cols)*20+1;
  384.     Qattr (Row,Col, 1,20,46);
  385.     Delay (3);
  386.     Qattr (Row,Col, 1,20,32);
  387.   end;
  388.   for i:=1 to Cols do     {  Emphasize Data }
  389.     Qattr ( 5*i,(i-1)*20+1, 1,20,LightGreen shl 4 + yellow);
  390.   Qattr   (21, 1, 5,CRTCols,Tattr);
  391.   QwriteC (22, 1,CRTCols,Tattr,' (c) 1986,1987 James H. LeMay ');
  392.   GotoRC  (23, 1);
  393.   CursorOn;
  394. end.
  395.