home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / BIX03.ZIP / STRINGS.SYS < prev    next >
Encoding:
Text File  |  1986-08-04  |  8.1 KB  |  251 lines
  1. {$V-}
  2. (************************************************************************)
  3. (*                                                                      *)
  4. (*                         STRINGS.LIB                                  *)
  5. (*                                                                      *)
  6. (*     A compendium of string utilitys, including:                      *)
  7. (*                                                                      *)
  8. (*   --NAME--   -TYPE-     --DESCRIPTION--                              *)
  9. (*                                                                      *)
  10. (*    Noise      -P-   Procedure to generate sound.                     *)
  11. (*    Beep       -P-   Short, High pitched sound.                       *)
  12. (*    Burp       -P-   Short, Low pitched sound.                        *)
  13. (*    ConstStr   -F-   Function to return a string of characters.       *)
  14. (*    UpcaseStr  -F-   Function to convert a string to Upper Case.      *)
  15. (*    KeyFlush   -P-   Procedure to clear the keyboard buffer.          *)
  16. (*    ReadKey    -F-   Reads a key from the keyboard, no echo.          *)
  17. (*    InputStr   -P-   Allows for editing and input of a string.        *)
  18. (*    Strip      -P-   Procedure to remove leading chars from a string. *)
  19. (*    Parse      -F-   Returns a portion of a string.                   *)
  20. (*                                                                      *)
  21. (*                                                                      *)
  22. (*                                                                      *)
  23. (*    compiled by   John Leonard       4/6/1986                         *)
  24. (*                                                                      *)
  25. (*       NOT FOR SALE WITHOUT WRITTEN PERMISSION                        *)
  26. (************************************************************************)
  27.  
  28.  
  29. procedure noise( freq,dura : integer);
  30.    begin
  31.       sound(freq);delay(dura);nosound;
  32.    end;
  33.  
  34.  
  35. procedure beep;
  36.    begin
  37.       noise(1000,200);
  38.    end;
  39.  
  40.  
  41. procedure burp;
  42.    begin
  43.       noise(256,200);
  44.    end;
  45.  
  46.  
  47. function conststr( n: integer;c:char):longstring;
  48.    var s : longstring;
  49.    begin
  50.       if n<0 then n:=0;
  51.       s[0] := chr(n);
  52.       fillchar(s[1],n,c);
  53.       conststr := s;
  54.    end;
  55.  
  56.  
  57. function UpcaseStr(S : Str80) : Str80;
  58.    var P : Integer;
  59.    begin
  60.       for P := 1 to Length(S) do S[P] := Upcase(S[P]);
  61.       UpcaseStr := S;
  62.    end;
  63.  
  64.  
  65. procedure keyflush;
  66.    var ch:char;
  67.    begin
  68.       while keypressed do read(kbd,ch);
  69.    end;
  70.  
  71.  
  72. function readkey( var Special : Boolean ) : char;
  73.    var ch : char;
  74.       quit:boolean;
  75.    begin
  76.       Special := false;
  77.       quit := false;
  78.       repeat
  79.          if keypressed then begin
  80.             quit := true;
  81.             read(kbd,ch);
  82.             if ( ch = #27) and keypressed then begin
  83.                read(kbd,ch);
  84.                Special := true;
  85.             end;
  86.          end;
  87.       until quit;
  88.       readkey := ch;
  89.    end;
  90.  
  91.  
  92. procedure InputStr(var S     : str80;
  93.                        L,X,Y : Integer;
  94.                        Term  : CharSet;
  95.                    var esc   : boolean;
  96.                    var TC    : Char    );
  97.    var
  98.       P : Integer;
  99.       special : boolean;
  100.       Ch : Char;
  101.    begin
  102.       GotoXY(X ,Y ); Write(S,ConstStr(L - Length(S),'_'));
  103.       P := 0;esc := false;
  104.       repeat
  105.         GotoXY(X + P ,Y );
  106.         ch := readkey(special);
  107.         if special then
  108.            case ch of
  109.             #75     : if P > 0 then
  110.                         P := P - 1
  111.                       else Beep;
  112.             #77     : if P < Length(S) then
  113.                         P := P + 1
  114.                       else Beep;
  115.             #83     : if p < length(s) then
  116.                       begin
  117.                         Delete(S,P+1,1);
  118.                         Write(copy(s,p+1,l),'_');
  119.                       end;
  120.             #72     : begin
  121.                          esc := true;
  122.                          tc  := #72;
  123.                          P := Length(S);
  124.                          GotoXY(X + P ,Y );
  125.                          Write('' :L - P);
  126.                          exit;
  127.                       end;
  128.             #80     : begin
  129.                          esc := true;
  130.                          tc  := #80;
  131.                          P := Length(S);
  132.                          GotoXY(X + P ,Y );
  133.                          Write('' :L - P);
  134.                          exit;
  135.                       end;
  136.             #115    : begin
  137.                          esc := true;
  138.                          tc  := #115;
  139.                          P := Length(S);
  140.                          GotoXY(X + P ,Y );
  141.                          Write('' :L - P);
  142.                          exit;
  143.                       end;
  144.             #116    : begin
  145.                          esc := true;
  146.                          tc  := #116;
  147.                          P := Length(S);
  148.                          GotoXY(X + P ,Y );
  149.                          Write('' :L - P);
  150.                          exit;
  151.                       end;
  152.             #160    : begin
  153.                          esc := true;
  154.                          tc  := #160;
  155.                          P := Length(S);
  156.                          GotoXY(X + P ,Y );
  157.                          Write('' :L - P);
  158.                          exit;
  159.                       end;
  160.             #164    : begin
  161.                          esc := true;
  162.                          tc  := #164;
  163.                          P := Length(S);
  164.                          GotoXY(X + P ,Y );
  165.                          Write('' :L - P);
  166.                          exit;
  167.                       end;
  168.                       else Beep;
  169.             end
  170.          else case Ch of
  171.             #27     : begin
  172.                          esc := true;
  173.                          tc  := #27;
  174.                          P := Length(S);
  175.                          GotoXY(X + P ,Y );
  176.                          Write('' :L - P);
  177.                          exit;
  178.                       end;
  179.           #32..#126 : if P < L then
  180.                       begin
  181.                         if Length(S) = L then
  182.                           Delete(S,L,1);
  183.                         P := P + 1;
  184.                         Insert(Ch,S,P);
  185.                         Write(Copy(S,P,L));
  186.                       end
  187.                       else Beep;
  188.           ^S        : if P > 0 then
  189.                         P := P - 1
  190.                       else Beep;
  191.           ^D        : if P < Length(S) then
  192.                         P := P + 1
  193.                       else Beep;
  194.           ^A        : P := 0;
  195.           ^F        : P := Length(S);
  196.           ^G        : if P < Length(S) then
  197.                       begin
  198.                         Delete(S,P + 1,1);
  199.                         Write(Copy(S,P + 1,L),'_');
  200.                       end;
  201.           ^H,#127   : if P > 0 then
  202.                       begin
  203.                         Delete(S,P,1);
  204.                         Write(^H,Copy(S,P,L),'_');
  205.                         P := P - 1;
  206.                       end
  207.                       else Beep;
  208.           ^Y        : begin
  209.                         Write(ConstStr(Length(S) - P,'_'));
  210.                         Delete(S,P + 1,L);
  211.                       end;
  212.           else  if not (Ch in Term) then Beep;
  213.         end;  {of case}
  214.       until (Ch in Term) ;
  215.       P := Length(S);
  216.       GotoXY(X + P  ,Y );
  217.       Write('' :L - P );
  218.       TC := Ch;
  219.     end;
  220.  
  221.  
  222. procedure Strip(var s : longstring;Break : charset);
  223.    var  done:boolean;
  224.    begin
  225.       done := false;
  226.       repeat
  227.          if( s[1] in break) then delete(s,1,1) else done:=true;
  228.       until done;
  229.    end;
  230.  
  231.  
  232. function parse(var Line: longstring;
  233.                         Break : charset ) : longstring;
  234.    var
  235.       Len,Indx           : Integer;
  236.    begin
  237.        parse := '';
  238.        Strip(Line,Break);
  239.        len := length(line);
  240.        if Len = 0 then Exit;
  241.        Indx := 0;
  242.        while not (Line[Indx+1] in Break) and (Indx < Len) do
  243.           Indx := Indx + 1;
  244.        parse := Copy(Line,1,Indx);
  245.        Delete(Line,1,Indx);
  246.        Strip(Line,Break)
  247.    end;
  248.  
  249.  
  250. {$V+}
  251.