home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / GSDB21.ZIP / GS_PICK.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-11-23  |  7.3 KB  |  251 lines
  1. UNIT GS_Pick;
  2.  
  3. INTERFACE
  4.  
  5. USES
  6.    Crt,
  7.    Dos,
  8.    GS_Scrn,
  9.    GS_Error,
  10.    GS_KeyI,
  11.    GS_dBase,
  12.    GS_Strng,
  13.    GS_Wind;
  14.  
  15. function GS_Pick_Row_Item (var tabl; clth : integer;
  16.                            icnt, sitem : longint): longint;
  17. function GS_Pick_Line_Item (var tabl; clth : integer;
  18.                             icnt, sitem : longint) : longint;
  19. procedure GS_Pick_Item_Sort (var tabl; clth : integer; icnt : longint);
  20.  
  21. {tabl = starting location of the array}
  22. {clth = length of entry (for a string, it is length(string)+1 to include the}
  23. {        length byte.  Recommend passing sizeof(entry) for accuracy)}
  24. {icnt = number of entries}
  25. {sitem = entry number to highlight.  Can be any number form 1 to icnt.  This}
  26. {        can be used to "remember" the last item selected.  for example:    }
  27. {                                                                           }
  28. {        i := 1;                                                            }
  29. {        while i <> 0 do                                                    }
  30. {        begin                                                              }
  31. {           i := GS_Pick_Line_Item(dataarray,sizeof(dataentry),25,i);       }
  32. {           case i of                                                       }
  33. {                    .                                                      }
  34. {                    .                                                      }
  35. {                    .                                                      }
  36. {           end;                                                            }
  37. {        end;                                                               }
  38.  
  39.  
  40.  
  41. implementation
  42.  
  43. var
  44.    txc,
  45.    bgc,
  46.    fgc,
  47.    txh,
  48.    bgh           : byte;
  49.  
  50. procedure FindColors;
  51. begin
  52.    GS_Wind_GetColors(txc,bgc,fgc,txh,bgh);
  53. end;
  54.  
  55. function GS_Pick_Row_Item (var tabl; clth : integer;
  56.                            icnt, sitem : longint): longint;
  57. var
  58.    ci, cw, ct, l : longint;
  59.    cj, cis,
  60.    cih           : longint;
  61.    lins,
  62.    wdth, fl,
  63.    x, y, k       : integer;
  64.    chrr          : char;
  65.    strng         : string[255];
  66.    z             : array [0..maxint-1] of char absolute tabl;
  67. begin
  68.    GS_KeyI_Fuc := false;
  69.    GS_Scrn_HideCursor;
  70.    FindColors;
  71.    lins := (hi(windmax)) - (hi(windmin));
  72.    wdth := ((lo(windmax)) - (lo(windmin))) + 1;
  73.    l := icnt;
  74.    ci := sitem div lins;
  75.    ci := ci * lins;
  76.    fl := sitem;
  77.    cih := 0;
  78.    cis := 1;
  79.    repeat
  80.       if ci + (lins-1) > l then ci := l - (lins-1);
  81.       if ci < 1 then ci := 1;
  82.       if (not GS_KeyI_Fuc) and (fl <= icnt) then cis := (fl - ci)+1;
  83.       cj := ci;
  84.       if ci <> cih then
  85.       begin
  86.          k := 1;
  87.          cih := ci;
  88.          while cj < ci+lins do
  89.          begin
  90.             if cj <= l then
  91.             begin
  92.                y := k;
  93.                x := 2;
  94.                gotoxy(x,y);
  95.                move(z[((cj-1)*(clth))],strng[0],clth);
  96.                fillchar(strng[length(strng)+1],clth-length(strng),' ');
  97.                strng[0] := chr(clth);
  98.                write(strng);
  99.                inc(cj);
  100.                inc(k);
  101.             end else cj := 9999;
  102.          end;
  103.          gotoxy(1,lins+1);
  104.          if cj-1 < l then write('':(wdth-10) div 2,'-- more --')
  105.             else write('':wdth-1);
  106.       end;
  107.       GS_Scrn_Put_Atr(1,cis,wdth,cis,txh,bgh);
  108.       chrr := GS_KeyI_GetKey;
  109.       GS_Scrn_Put_Atr(1,cis,wdth,cis,txc,bgc);
  110.       if GS_KeyI_Fuc then
  111.       begin
  112.          case chrr of
  113.             Kbd_Home : begin
  114.                         ci := 1;
  115.                         cis := 1;
  116.                      end;
  117.             Kbd_End  : begin
  118.                           ci := l;
  119.                           cis := lins;
  120.                        end;
  121.             Kbd_PgUp : begin
  122.                           ci := ci - lins;
  123.                        end;
  124.             Kbd_PgDn : begin
  125.                           ci := ci + lins;
  126.                        end;
  127.             Kbd_UpAr : begin
  128.                           if cis = 1 then ci := ci - 1 else cis := cis - 1;
  129.                        end;
  130.             Kbd_DnAr : begin
  131.                           if cis = lins then ci := ci + 1 else cis := cis + 1;
  132.                        end;
  133.             else SoundBell(BeepTime, BeepFreq);
  134.          end;
  135.          if cis > l then cis := l;
  136.       end else
  137.       begin
  138.          case chrr of
  139.             Kbd_Ret :  GS_Pick_Row_Item := ci+cis-1;
  140.             Kbd_Esc :  GS_Pick_Row_Item := 0;
  141.             else
  142.                begin
  143.                   fl := 1;
  144.                   while (z[((fl-1)*(clth))+1] <> chrr) and
  145.                         (z[((fl-1)*(clth))+1] <> upcase(chrr)) and
  146.                         (fl <= icnt) do inc(fl);
  147.                   if fl <= icnt then ci := fl
  148.                      else SoundBell(BeepTime, BeepFreq);
  149.                end;
  150.          end;
  151.       end;
  152.    until chrr in [Kbd_Ret,Kbd_Esc];
  153.    GS_Scrn_ShowCursor;
  154. end;
  155.  
  156. function GS_Pick_Line_Item (var tabl; clth : integer;
  157.                             icnt, sitem : longint) : longint;
  158. var
  159.    ci,
  160.    x, y, k, l    : integer;
  161.    chrr          : char;
  162.    strng         : string[255];
  163.    z             : array [0..maxint-1] of char absolute tabl;
  164. begin
  165.    GS_Scrn_HideCursor;
  166.    FindColors;
  167.    l := icnt;
  168.    y := 1;
  169.    ci := succ(pred(sitem)*clth);
  170.    if ci > l*clth then ci := ((l-1)*clth)+1;
  171.    if ci < 1 then ci := 1;
  172.    repeat
  173.       k := 1;
  174.       while k <= l do
  175.       begin
  176.          x := ((k-1) * clth)+1;
  177.          gotoxy(x,y);
  178.          move(z[((k-1)*(clth))],strng[0],clth);
  179.          if length(strng) > pred(clth) then
  180.             ShowError(851,'Error in GS_Pick_Line_Item Length');
  181.          fillchar(strng[length(strng)+1],clth-length(strng),' ');
  182.          strng[0] := chr(pred(clth));
  183.          write(strng);
  184.          inc(k);
  185.       end;
  186.       GS_Scrn_Put_Atr(ci,y,ci+clth-1,y,txh,bgh);
  187.       chrr := GS_KeyI_GetKey;
  188.       GS_Scrn_Put_Atr(ci,y,ci+clth-1,y,txc,bgc);
  189.       if GS_KeyI_Fuc then
  190.       begin
  191.          case chrr of
  192.             Kbd_Home :  ci := 1;
  193.             Kbd_LfAr :  ci := ci - clth;
  194.             Kbd_RtAr :  ci := ci + clth;
  195.             Kbd_End  :  ci := ((l-1) * clth) + 1;
  196.          end;
  197.          if ci > l*clth then ci := 1;
  198.          if ci < 1 then ci := ((l-1)*clth)+1;
  199.       end;
  200.    until chrr in [Kbd_Ret,Kbd_Esc];
  201.    if chrr = Kbd_Ret then
  202.    begin
  203.       GS_Pick_Line_Item := (ci div clth) + 1 ;
  204.    end else GS_Pick_Line_Item := 0;
  205.    GS_Scrn_ShowCursor;
  206. end;
  207.  
  208. procedure GS_Pick_Item_Sort (var tabl; clth : integer;
  209.                             icnt : longint);
  210. var
  211.    z : array [0..maxint-1] of char absolute tabl;
  212.    y,
  213.    w : string;
  214.  
  215. function valu(i : integer) : string;
  216. begin
  217.     move(z[((i-1)*(clth))],w[0],clth);
  218.     valu := w;
  219. end;
  220.  
  221. procedure sort(l,r: integer);
  222. var
  223.    i,j : integer;
  224.    x : ^string;
  225. begin
  226.   i := l;
  227.   j := r;
  228.   GetMem(x,255);
  229.   x^ := valu((l+r) DIV 2);
  230.   repeat
  231.     while valu(i)<x^ do i:=i+1;
  232.     while x^<valu(j) do j:=j-1;
  233.     if i<=j then
  234.     begin
  235.       move(z[((i-1)*(clth))],y[0],clth);
  236.       move(z[((j-1)*(clth))],w[0],clth);
  237.       move(y[0],z[((j-1)*(clth))],clth);
  238.       move(w[0],z[((i-1)*(clth))],clth);
  239.       i:=i+1; j:=j-1;
  240.     end;
  241.   until i>j;
  242.   if l<j then sort(l,j);
  243.   if i<r then sort(i,r);
  244.   FreeMem(x,255);
  245. end;
  246.  
  247. begin {quicksort};
  248.    if icnt > 1 then sort(1,icnt);
  249. end;
  250.  
  251. end.