home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TABUG.ZIP / REPORT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-03-18  |  5.4 KB  |  191 lines
  1. {$R+}
  2. program tareport; {test turbo database toolkit }
  3.  
  4. uses
  5. dos,crt,taccess,printer;
  6.  
  7. CONST
  8. {***** key code constants - 2 byte keys *****
  9.  ***** have null stripped and 128 added *****}
  10. f1     = #187; f2    = #188; f3    = #189;  f4    = #190; f5     = #191;
  11. f6     = #192; f7    = #193; f8    = #194;  f9    = #195; f10    = #196;
  12. csr_r  = #205; pgup  = #201; pgdn   = #209; Ins   = #210; del    = #211;
  13. _home  = #199; _end  = #207; tab    = #9  ; esc   = #27 ; Bksp   = #8  ;
  14. csr_up = #200; csr_dn= #208; sh_tab = #143; Altf2 = #233; csr_l  = #203;
  15. enter  = #13; SubMenu = #255;
  16.  
  17.  
  18. TYPE
  19. ketstr = string[1];
  20.  
  21. DataRec = record
  22.   RecStatus  : longint;
  23.   dstate     : byte;
  24.   dummy      : array[1..3] of byte; {dummy out other keys}
  25.   dcount     : longint;
  26.   dummy2     : integer;
  27.   end;{DataRec}
  28.  
  29. MaxDataType = DataRec;
  30. MaxKeyType  = ketstr;
  31.  
  32. flagarray = array[0..11000] of byte;
  33. flagptr   = ^flagarray;
  34.  
  35. VAR
  36. ibuff   : DataRec;
  37. DugFile : DataFile;
  38. StateIdx,
  39. Sicidx,
  40. empidx,
  41. dugidx   : IndexFile;
  42. recnum   : longint;
  43. done     : boolean;
  44. keystate : array[0..52] of boolean;
  45. keydug    : array[0..3] of boolean;
  46. keystr    : string[1];
  47. cmd       : char;
  48. searchrec : flagptr;
  49. c         : byte;
  50.  
  51. {*************************
  52.    test a bit in a byte
  53. *************************}
  54. function  bit( n,b : byte) : boolean;     { test nth bit of b }
  55.  
  56. BEGIN
  57. bit := ((b shr (n-1)) and 1 = 1);
  58. END;{bit}
  59.  
  60. {*************************
  61.    set a bit in a byte
  62. *************************}
  63. procedure set_bit(n : byte; b : integer; flag : flagptr);
  64.  
  65. var
  66. work : ^byte;
  67.  
  68. BEGIN
  69. work := ptr(seg(flag^),ofs(flag^)+b);
  70. work^ := work^ or (1 shl (n-1));
  71. END;{set_bit}
  72.  
  73. {***************************
  74.       WAIT FOR A KEY
  75. ***************************}
  76. procedure waitforkey;
  77. BEGIN
  78. if not keypressed then
  79.   repeat until keypressed;
  80. cmd := readkey;
  81. if (cmd = #0) then begin
  82.   cmd := readkey;
  83.   cmd := char(ord(cmd)+128);
  84.   end;{if}
  85. END;
  86.  
  87. {***************************
  88.      search database
  89. ***************************}
  90. procedure report;
  91.  
  92. VAR
  93. x : byte;
  94. subtot,
  95. total   : real;
  96. c,
  97. first,
  98. last,
  99. recnum : longint;
  100. b      : byte;
  101.  
  102. begin
  103. x := 0;
  104. total := 0.0;
  105. for c :=  0 to 52 do                 {loop by state}
  106.   if keystate[c] then begin          {selected state ?}
  107.     fillchar(searchrec^,11000,0);    {reset flags}
  108.     subtot := 0.0;                   {reset}
  109.     first := 0;                      {counters &}
  110.     last := 0;                       {totals}
  111.     keystr[1] := char(c);            {set search key}
  112.     findkey(stateidx,recnum,keystr); {do search for 1st key}
  113.     if ok then begin                 {successfull search ?}
  114.       set_bit(1+(recnum mod 8),trunc(recnum/8),searchrec); {flag record}
  115.       first := trunc(recnum/8);                            {store pos}
  116.       last := trunc(recnum/8);                             {in flag array}
  117.       writeln('key found - record number is ',recnum);
  118.       end
  119.     else begin
  120.       writeln('key not found');
  121.       first := 1;                {disable}
  122.       last := 0;                 {search}
  123.       end;
  124.  
  125.     while (ord(keystr[1]) = c) and ok do begin  {while we find the current key}
  126.       NextKey(stateidx,recnum,keystr);          {get next key}
  127.       if ok and (ord(keystr[1]) = c) then begin {still ok ?}
  128.         set_bit(1+(recnum mod 8),trunc(recnum/8),searchrec); {flag recnum}
  129.         if first > trunc(recnum/8) then                      {test for new}
  130.           first := trunc(recnum/8);                          {start}
  131.         if last < trunc(recnum/8) then                       {test for new}
  132.           last := trunc(recnum/8);                           {end}
  133.         end;
  134.       end;{while}
  135.     writeln('first ',first,'  last = ',last);   {dump 1st & last flag bytes}
  136.     for recnum := first to last do              {loop for searching flags}
  137.       for b := 1 to 8 do                        {loop by bit}
  138.         if bit(b,searchrec^[recnum]) then begin {was record # flagged ?}
  139.           getrec(DugFile,recnum*8+b-1,ibuff);   {get it}
  140.           subtot := subtot + ibuff.dcount;      {increment subtotal}
  141.           end;
  142.     writeln('total for state ',c,' is ',subtot:10:0);      {dump}
  143.     writeln(lst,'total for state ',c,' is ',subtot:10:0);  {it}
  144.     total := total + subtot;                               {increment total}
  145.     end;{if}
  146. writeln('total = ',total:10:0);
  147. end;
  148.  
  149. {***************************
  150.        main
  151. ***************************}
  152. BEGIN
  153. new(searchrec);
  154. fillchar(keystate,sizeof(keystate),1); {for test - set all states to TRUE}
  155. OpenFile(DugFile,'tatest.dat',sizeof(DataRec));
  156. OpenIndex(StateIdx,'state.idx',1,duplicates);
  157. if not ok then begin
  158.   writeln('file error ',#7);
  159.   halt;
  160.   end;
  161. done := false;
  162. keystr := ' ';
  163. repeat
  164.   clrscr;
  165.   write('states : ');
  166.   for c := 0 to 52 do if keystate[c] then write(c:4);
  167.   writeln;
  168.   writeln(' 1 - specify state ');
  169.   writeln(' 2 - run report    ');
  170.   writeln(' 3 - clear states  ');
  171.   writeln(' 4 - quit (Esc)    ');
  172.   writeln;
  173.   waitforkey;
  174.   case cmd of
  175.     f1,'1' : begin
  176.              repeat
  177.                write('Enter state # (0-52) =>');
  178.                readln(c);
  179.              until c in [0..52];
  180.              keystate[c] := true;
  181.              end;
  182.     f2,'2' : report;
  183.     f3,'3' : fillchar(keystate,sizeof(keystate),0); {set all states to FALSE}
  184.     f4,'4',
  185.     Esc    : done := true;
  186.     end;{case}
  187. until done;
  188. closefile(DugFile);
  189. closeindex(StateIdx);
  190. END.
  191.