home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / GRAPHICS / MISC / POSTOGRF.ZIP / PSTRINGS.I < prev    next >
Encoding:
Text File  |  1990-04-25  |  7.8 KB  |  209 lines
  1. { pstrings.i include file with various string handlers.
  2.   Written by Thomas B. Passin in TurboPascal 5.0.
  3.   Modified to be specific to POSTOGRF.
  4.  
  5.     25 Apr 90.  Added set constant No.
  6.     16 June 89.  Created based on STRINGS.SRC.  Added XOR_char, now
  7.        ReadRaw shows an underline cursor.
  8.     18 Oct 88 v1.0x3.  ReadRaw now only reverses screen attributes
  9.        if plot4 has been defined & InGraphMode is true.
  10.     28 Sept 88 v1.0x2
  11.     22 Sept 88 v1.0x1 }
  12.  
  13. { ------------------------ procedures ---------------------------
  14.    ReadRaw(var s:string80; prompt: string80;
  15.                       default:string80;);
  16.    Procedure StripWhite(var Line:string80);
  17.    Procedure LowerCase(var Comm:Namestr);
  18.    Procedure ParseComm(var Source, Destination:string80);
  19. }
  20.  
  21. (*{$DEFINE strtest}*)
  22.  
  23. {$IFDEF strtest}
  24. uses CRT;
  25. {$endif}
  26.  
  27. {$define STRINGS}
  28. type string80 = string[80];
  29. const CR = #13; ESC = #27; BS = #8; En = #79; SP = #32; TAB = #9;
  30.       Home = #71; LF = #10;
  31.       WhiteSpace:             set of char = [#8,#9,#10,#12,' '];
  32.       Yes : set of char = ['Y','y'];
  33.       No  : set of char = ['N', 'n'];
  34.       Curins: char = #219; Curover:char = '_';
  35.  
  36. Procedure Xor_char(aa:char);
  37. var regs:DOS.Registers;
  38. begin
  39.     regs.ax := $0A00 + ord(aa); regs.bx := $0087;
  40.     regs.cx :=1; intr($10,Dos.Registers(regs))
  41. end;
  42.  
  43. { ---------------------------------------------------------------
  44.     ReadRaw returns the following for the input string:
  45.       KEYSTROKE                              RETURNS
  46.     CR for 1st char                     s = default (erases string on screen)
  47.     CR any other time                   s = string typed on screen
  48.     SPACE for 1st char                  s = ''      (erases string on screen)
  49.     ESC anytime                         s = ESC     (erases string on screen)
  50.     <END>         moves to end on string, next input adds to string
  51.  
  52.    default = default string.
  53.    Restores cursor to starting position on exit.
  54. }
  55. procedure ReadRaw(var s:string80; prompt: string80;
  56.                       default:string80);
  57. var chr: char; t1, t2, t3, start, ytemp:byte; tattrib:byte;
  58.     twherex, twherey:byte;
  59.          W1, W2:word;
  60.          done: boolean;
  61. begin s := default;  done := false;
  62.       twherex := wherex; twherey := wherey;
  63.       tattrib := textattr;
  64. (*{$ifdef plot4} textattr := 16*(tattrib mod 16) + tattrib div 16; {$endif}*)
  65.       w1 := WindMin; w2 := Windmax;
  66.       ytemp := hi(w1) + wherey ;
  67.       start:= lo(w1) + 1;
  68.       t1 := start+ length(prompt) + 50;
  69.       if t1 > 79 then t1 := 79;
  70.       window(start,ytemp,t1, ytemp);
  71.       write(prompt);
  72.       start:= wherex; clrEOL;
  73.       if default <> '' then write(default);
  74.       t2 := wherex; t3 := start; GoToXY(start, whereY);
  75.       XOR_char(CurOver);
  76.       repeat chr := Readkey;
  77.                 case chr of
  78.                    BS:  if (s <> '') and (t3 <> start)
  79.                         then begin s := copy(s,1,length(s)-1);
  80.                                    dec(t3);
  81.                                    XOR_char(curover);
  82.                                    GoToXY(t3, wherey); clrEOL;
  83.                                    {write(' '); GoToXY(t3,wherey);}
  84.                                    XOR_char(curover);
  85.                              end
  86.                          else begin sound(2000); delay(25); nosound; end;
  87.                    ESC: begin s := ESC;
  88.                               GoToXY(start,wherey); clrEOL;
  89.                               XOR_char(curover);
  90.                               done := true;
  91.                         end;
  92.                   #0: begin if keypressed then chr := Readkey;
  93.                             case chr of
  94.                                  En: begin t3 := start   + length(s) ;
  95.                                            XOR_char(curover);
  96.                                            GoToXY(t3, wherey);
  97.                                            XOR_char(curover);
  98.                                      end;
  99.                             end; {case}
  100.                             chr := #0;
  101.                       end;
  102.                   CR: begin if t3 = start then s := default;
  103.                             done := true;
  104.                       end;
  105.                 else begin if (t3 = start)
  106.                            then if chr = SP
  107.                                    then begin s := '';
  108.                                               clrEOL;
  109.                                               done := true;
  110.                                          end
  111.                                    else begin clrEOL; s := chr;
  112.                                               inc(t3); write(chr);
  113.                                               XOR_char(curover);
  114.                                             end
  115.                            else begin
  116.                                      inc(t3); write(chr);
  117.                                      XOR_char(curover);
  118.                                      s := s+chr;
  119.                                  end;
  120.                      end; {else}
  121.                 end; {case}
  122.         until done ;
  123.         textattr := tattrib;
  124.         clrEOL;
  125.         window(1+lo(w1), 1+hi(w1), 1 + lo(w2), 1+hi(w2));
  126.         GoToXY(twherex, twherey);
  127. end; {ReadRaw}
  128.  
  129.  
  130. { -----------------------------------------------------------------
  131.                             StripWhite
  132.   -----------------------------------------------------------------}
  133. Procedure StripWhite(var Line:string80);
  134.    { Removes leading whitespace in string.  Returns a null string ('')
  135.       if there is only whitespace in the string
  136.    }
  137. Var n:  integer;
  138. begin
  139.     if Line = '' then exit ELSE
  140.     begin
  141.       n := 1;
  142.       While (Line[n] in WhiteSpace) and (n < length(Line)) do n :=n+1;
  143.       if    Line[n] in WhiteSpace then Line := ''
  144.       ELSE  Line := Copy(Line,n, length(Line)-n+1);
  145.     end;
  146. end;
  147.  
  148. Procedure LowerCase(var Comm:string80);
  149. const Uppercase:set of char = ['A'..'Z'];
  150. var i:integer;
  151. begin
  152.      for i := 1 to Length(Comm) do
  153.          if Comm[i] in UpperCase
  154.          then Comm[i] := chr(Ord(Comm[i]) + ord('a')-ord('A'));
  155. end;
  156.  
  157.  
  158. { ----------------------------------------------------------------
  159. Command string parser. ParseComm strips leading whitespace from
  160. the source string, then puts the first word into the destination
  161. string.  The end of the word is detected by the first whitespace.
  162. Whitespace is defined as BS,LF,tab,FF, or a space.
  163. --------------------------------------------------------------------}
  164.  
  165. Procedure ParseComm(var Source, Destination:string80);
  166.    {
  167.  processes a string into separate words ("commands"):
  168.         Strips leading whitespace from Source string.
  169.         Removes first word- delineated by trailing whitespace-
  170.             from Source & copies it into Destination.
  171.         Destination word always starts with non-whitespace unless null.
  172.         Source is set to '' if it would have been a single space.
  173.         Sets Destination to '' if Source is a null string. }
  174. var n:                          integer;
  175. begin
  176.      if Source = '' then begin Destination := ''; exit; end  ELSE
  177.      begin
  178.        StripWhite(Source);
  179.        n := 1;
  180.        Repeat n :=n+1
  181.        Until (Source[n] {is} in WhiteSpace) or (n > length(Source));
  182.        Destination := copy(Source,1,n-1);
  183.        Source := copy(Source,n,length(source)-n+1);
  184.        if source = ' ' then source := '';
  185.      end;
  186. end;
  187.  
  188. {var   comm1, comm2:                string80;
  189. begin
  190.      readln(Comm2);
  191.      while Comm2 <> '' do
  192.      begin
  193.           ParseComm(Comm2,Comm1);
  194.           WRITE(COMM1,'*');
  195.           writeln(Comm2)
  196.      end
  197. end.}
  198.  
  199. {$ifdef strtest}
  200. var s:string80;
  201. begin
  202.      clrscr; textbackground(blue);
  203.      window(12,10,65,18); clrscr;
  204.      readraw(s,'key string: ', 'default');
  205.      writeln; textbackground(red); {clrscr;}
  206.      writeln(s);
  207. end
  208. {$endif}
  209.