home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB20.ZIP / SC.INC < prev    next >
Encoding:
Text File  |  1985-10-09  |  8.2 KB  |  289 lines
  1. {-------------------------------------------------------------------------}
  2. {                    SC.INC     Screen Counter                            }
  3. {-------------------------------------------------------------------------}
  4. {                Copyright 1985                                           }
  5. {                               by Lynn A. Canning                        }
  6. {                                  9107 Grandview Dr.                     }
  7. {                                  Overland Park, Ks 66212                }
  8. {       This program was placed in the public domain by the author.       }
  9. {       It may be used and copied as desired, but it may not be sold.     }
  10. {-------------------------------------------------------------------------}
  11.  
  12. const
  13.   Menu = 'X = Exit   Line     Column     HTrip    VTrip    F2 = Trip Reset  F1 = Help ';
  14.  
  15. type
  16.   char_cell   = record
  17.                   code : char;
  18.                   attr : byte;
  19.                   end;
  20.  
  21.   screen_type = array[1..25] of array[1..80] of char_cell;
  22.  
  23. var
  24.   ch              : char;
  25.   i,j,l,m,n,o,b,f : byte;
  26.   cx,cy           : byte;
  27.   htrip,vtrip     : byte;
  28.   saveattr        : byte;
  29.   video_mode      : byte;
  30.   cursor_color    : byte;
  31.   screen          : screen_type;
  32.   real_screen     : ^screen_type;
  33.   previous        : boolean;
  34.   counter_color   : byte;
  35.   menu_color      : byte;
  36.  
  37. procedure update_screen(y,lines : byte);
  38.  
  39.   begin
  40.   if video_mode <> 7 then
  41.     repeat until (port[$3da] and 8) = 8;      {is raster in vertical retrace}
  42.   if video_mode <> 7 then
  43.     port[$3d8] := 1;                          {disable video signal}
  44.   move(screen[y],real_screen^[y],lines * 160); {write to screen memory}
  45.   if video_mode <> 7 then
  46.     port[$3d8] := 9;                          {enable video signal}
  47.   end;
  48.  
  49. procedure read_screen(y,lines : byte);
  50.  
  51.   begin
  52.   if video_mode <> 7 then
  53.     repeat until (port[$3da] and 8) = 8;
  54.   if video_mode <> 7 then
  55.     port[$3d8] := 1;
  56.   move(real_screen^[y],screen[y],lines * 160); {read screen memory}
  57.   if video_mode <> 7 then
  58.     port[$3d8] := 9;
  59.   end;
  60.  
  61. procedure move_cursor;
  62.   begin
  63.     if (i = 0) or (i = 25) then begin
  64.       i := l;
  65.       j := m;
  66.       htrip := n;
  67.       vtrip := o;
  68.       write(Chr(7));  {no screen wrap allowed, ring bell}
  69.       end
  70.     else begin
  71.       screen[l,m].attr := saveattr;
  72.       saveattr := screen[i,j].attr;
  73.       screen[i,j].attr := cursor_color;
  74.       update_screen(i,1);
  75.       update_screen(l,1);
  76.     end
  77. end;
  78.  
  79. procedure update_menu;     {update the menu counters}
  80. begin
  81.   if video_mode = 7 then
  82.     textbackground(white)
  83.   else
  84.     textbackground(yellow);
  85.   gotoxy(17,25);
  86.   write(i:2);
  87.   gotoxy(28,25);
  88.   write(j:2);
  89.   gotoxy(38,25);
  90.   if htrip = 0 then
  91.     htrip := j;
  92.   write(htrip:2);
  93.   gotoxy(47,25);
  94.   if vtrip = 0 then
  95.     vtrip := i;
  96.   write(vtrip:2);
  97.   end;
  98.  
  99. procedure CheckInput;
  100. begin
  101.  
  102.   l := i;
  103.   m := j;
  104.   n := htrip;
  105.   o := vtrip;
  106.  
  107.   Read(Kbd,Ch);
  108.  
  109.   if Ch = chr(27)  then begin                 {check for cursor keys -(ESC x)}
  110.     previous := True;
  111.     Read(Kbd,Ch);
  112.   end
  113.   else previous := False;
  114.  
  115.   if previous and (Ch = '<') then begin      {check for F2 key, if found }
  116.     htrip := 1;                               {reset htrip counter}
  117.     vtrip := 1;
  118.     update_menu;
  119.     end;
  120.  
  121.   if previous and (Ch = ';') then begin      {check for F1 key, if found }
  122.     MkWin(1,1,80,25,2,f,b);                              {pop-up help menu.}
  123.     gotoxy(1,1);
  124.     ClrScr;
  125.     Writeln('  Screen Counter               (C) Copyright 1985 by Lynn A. Canning');
  126.     Writeln('  Version 1.00                                       9107 Grandview');
  127.     Writeln('                                                     Overland Park, Ks 66212');
  128.     Writeln;
  129.     Writeln('         WELCOME TO THE SCREEN COUNTER HELP MENU');
  130.     Writeln;
  131.     Writeln('                  CURSOR MOVEMENT KEYS');
  132.     Writeln('  Arrow Keys - move one position in specified direction');
  133.     Writeln('  Home Key   - move to beginning of current line');
  134.     Writeln('  End Key    - move to end of current line');
  135.     Writeln('  Cntl End   - move to beginning of last line');
  136.     Writeln('  Cntl Home  - move to beginning of first line');
  137.     Writeln('  Screen Wrap is allowed except at columns 1 and 80');
  138.     Writeln;
  139.     Writeln('                  USE OF TRIP COUNTERS');
  140.     Writeln('  Move cursor to the first position to be counted, reset Trip Counters,');
  141.     Writeln('  move cursor to the last position to be counted.');
  142.     Writeln('  F2 - resets Trip Counters');
  143.     Writeln('  X - exits program Screen Counter');
  144.     Writeln('  Note that the Column and Line Counters are the X & Y screen coordinates.');
  145.     Writeln;
  146.     Writeln('               Press Any Key To Continue');
  147.     repeat until keypressed;
  148.     RmWin;
  149.     Textcolor(counter_color);
  150.     end;
  151.  
  152.   if previous  and (Ch = 'M') then begin      {check for right arrow (ESC M)}
  153.     if j = 80 then begin
  154.       j := 1;
  155.       htrip := 1;
  156.       vtrip := vtrip+1;
  157.       i := i+1;
  158.       end
  159.     else begin
  160.       j := j+1;
  161.       htrip := htrip+1;
  162.     end;
  163.   move_cursor;
  164.   update_menu;
  165.   end;
  166.  
  167.   if previous and (Ch = 'K') then begin        {check for left arrow (ESC K)}
  168.     if j = 1 then begin
  169.       j := 80;
  170.       htrip := j;
  171.       vtrip := vtrip-1;
  172.       i := i-1;
  173.       end
  174.     else begin
  175.       j := j-1;
  176.       htrip := htrip-1;
  177.     end;
  178.   move_cursor;
  179.   update_menu;
  180.   end;
  181.  
  182.   if previous and (Ch = 'P') then begin        {check for down arrow (ESC P)}
  183.     if i = 24 then begin
  184.       i := 1;
  185.       vtrip := i;
  186.       end
  187.     else begin
  188.       i := i+1;
  189.       vtrip := vtrip+1;
  190.       end;
  191.   move_cursor;
  192.   update_menu;
  193.   end;
  194.  
  195.   if previous and (Ch = 'H') then begin        {check for up arrow (ESC H)}
  196.     if i = 1 then begin
  197.       i := 24;
  198.       vtrip := i;
  199.       end
  200.     else begin
  201.       i := i-1;
  202.       vtrip := vtrip-1;
  203.       end;
  204.   move_cursor;
  205.   update_menu;
  206.   end;
  207.  
  208.   if previous and (Ch = 'G') then begin        {check for home key (ESC G)}
  209.     j := 1;
  210.     htrip := 1;
  211.   move_cursor;
  212.   update_menu;
  213.   end;
  214.  
  215.   if previous and (Ch = 'O') then begin        {check for end key (ESC G)}
  216.     j := 80;
  217.     htrip := 80;
  218.   move_cursor;
  219.   update_menu;
  220.   end;
  221.  
  222.   if previous and (Ch = 'u') then begin        {check for cntl end key (ESC G)}
  223.     i := 24;
  224.     j := 1;
  225.     htrip := 1;
  226.     vtrip := i;
  227.   move_cursor;
  228.   update_menu;
  229.   end;
  230.  
  231.   if previous and (Ch = 'w') then begin       {check for cntl home key (ESC G)}
  232.     i := 1;
  233.     j := 1;
  234.     htrip := 1;
  235.     vtrip := 1;
  236.   move_cursor;
  237.   update_menu;
  238.   end;
  239.  
  240. end;
  241.  
  242. {-------------------------------------------------------------------------}
  243. {                               Main Program                              }
  244. {-------------------------------------------------------------------------}
  245. begin
  246.   video_mode := Mem[0000:$0449];
  247.   if video_mode = 7 then begin     {7 is monochrome 3 is color graphics 80X25}
  248.     real_screen := ptr($b000,0);   {set page offset address for monochrome}
  249.     cursor_color := 240;           {black on white}
  250.     counter_color := 0;            {black}
  251.     menu_color := 15;              {white}
  252.     b := 15;                       {help menu background - white}
  253.     f := 0;                        {help menu text - black}
  254.     end
  255.   else begin;
  256.     real_screen := ptr($b800,0);   {set page offset address for color graphics}
  257.     cursor_color := 97;            {blue on brown}
  258.     counter_color := 1;            {blue}
  259.     menu_color := 4;               {red}
  260.     b := 0;                        {help menu background - black}
  261.     f := 6;                        {help menu test - yellow}
  262.     end;
  263.   fillchar(screen,4000,0);
  264.   cy := wherey;
  265.   cx := wherex;
  266.   I := cy;
  267.   J := cx;
  268.   htrip := J;
  269.   if I = 25 then
  270.     I := 24;
  271.   vtrip := I;
  272.   read_screen(1,25);
  273.   saveattr := screen[i,j].attr;
  274.   screen[i,j].attr := cursor_color;
  275.   update_screen(I,1);
  276.   gotoxy(1,25);
  277.   textcolor(menu_color);
  278.   write(menu);
  279.   textcolor(counter_color);
  280.   update_menu;
  281.  
  282.   repeat
  283.     CheckInput;
  284.   until UpCase(Ch) = 'X';
  285.   screen[i,j].attr := saveattr;
  286.   textbackground(black);
  287.   update_screen(1,25);
  288.   GOTOXY(cx,cy);
  289. end;