home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / tttsrc51.zip / STRNTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1993-03-08  |  13KB  |  483 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.10                              }
  5. {                                                                          }
  6. {                                                                          }
  7. {               Copyright 1986-1993 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}                                       
  13.                      {       Unit:  StrnTTT5          }
  14.                      {--------------------------------}
  15.  
  16. { Update History:    5.01a   Added DEBUG compiler directive
  17.                      5.02a   fixed extract words error       
  18.           01/04/93   5.10    DPMI compatible version
  19. }
  20.  
  21. {$S-,R-,V-}
  22. {$IFNDEF DEBUG}
  23. {$D-}
  24. {$ENDIF}       
  25.  
  26. unit StrnTTT5;
  27.  
  28. interface
  29.  
  30. CONST
  31.     Floating = 255;
  32.  
  33. Function Squeeze(L:char;Str:string;Width:byte): string;
  34. Function First_Capital_Pos(Str:string): byte;
  35. Function First_Capital(Str:string): char;
  36. Function PadLeft(Str:string;Size:byte;Pad:char):string;
  37. Function PadCenter(Str:string;Size:byte;Pad:char):string;
  38. Function PadRight(Str:string;Size:byte;Pad:char):string;
  39. Function Last(N:byte;Str:string):string;
  40. Function First(N:byte;Str:string):string;
  41. Function Upper(Str:string):string;
  42. Function Lower(Str:string):string;
  43. Function Proper(Str:string):string;
  44. Function OverType(N:byte;StrS,StrT:string):string;
  45. Function Strip(L,C:char;Str:string):string;
  46. Function LastPos(C:Char;Str:string):byte;
  47. Function PosWord(Wordno:byte;Str:string):byte;
  48. Function WordCnt(Str:string):byte;
  49. Function ExtractWords(StartWord,NoWords:byte;Str:string):string;
  50. Function Str_to_Int(Str:string):integer;
  51. Function Str_to_Long(Str:string):Longint;
  52. Function Str_to_Real(Str:string):real;
  53. Function Real_to_str(Number:real;Decimals:byte):string;
  54. Function Int_to_Str(Number:longint):string;
  55. Function Real_to_SciStr(Number:real; D:byte):string;
  56.  
  57. implementation
  58.  
  59.  Function Squeeze(L:Char; Str:string;Width:byte): string;
  60.  {}
  61.  const more:string[1] = #26;
  62.  var temp : string;
  63.  begin
  64.      If Width = 0 then
  65.      begin
  66.          Squeeze := '';
  67.          exit;
  68.      end;
  69.      Fillchar(Temp[1],Width,' ');
  70.      Temp[0] := chr(Width);
  71.      If Length(Str) < Width then
  72.         Move(Str[1],Temp[1],length(Str))
  73.      else
  74.      begin
  75.          If upcase(L) = 'L' then
  76.          begin
  77.              Move(Str[1],Temp[1],pred(width));
  78.              Move(More[1],Temp[Width],1);
  79.          end
  80.          else
  81.          begin
  82.              Move(More[1],Temp[1],1);
  83.              Move(Str[length(Str)-width+2],Temp[2],pred(width));
  84.          end;
  85.      end;
  86.      Squeeze := Temp;
  87.  end; {of func Squeeze}
  88.  
  89.  Function First_Capital_Pos(Str : string): byte;
  90.  {}
  91.  var StrPos : byte;
  92.  begin
  93.      StrPos := 1;
  94.      While (StrPos <= length(Str))  and ((Str[StrPos] in ['A'..'Z']) = false) do
  95.             StrPos := Succ(StrPos);
  96.      If StrPos > length(Str) then
  97.         First_Capital_Pos  := 0
  98.      else
  99.         First_Capital_Pos := StrPos;
  100.  end; {of func First_Capital_Pos}
  101.  
  102.  Function First_capital(Str : string): char;
  103.  {}
  104.  var B : byte;
  105.  begin
  106.      B := First_Capital_Pos(Str);
  107.      If B > 0 then
  108.         First_Capital := Str[B]
  109.      else
  110.         First_Capital := #0;
  111.  end; {of func First_capital}
  112.  
  113. Function PadLeft(Str:string;Size:byte;Pad:char):string;
  114. var temp : string;
  115. begin
  116.     Fillchar(Temp[1],Size,Pad);
  117.     Temp[0] := chr(Size);
  118.     If Length(Str) <= Size then
  119.        Move(Str[1],Temp[1],length(Str))
  120.     else
  121.        Move(Str[1],Temp[1],size);
  122.     PadLeft := Temp;
  123. end;
  124.  
  125. Function PadCenter(Str:string;Size:byte;Pad:char):string;
  126. var temp : string;
  127. L : byte;
  128. begin
  129.     Fillchar(Temp[1],Size,Pad);
  130.     Temp[0] := chr(Size);
  131.     L := length(Str);
  132.     If L <= Size then
  133.        Move(Str[1],Temp[((Size - L) div 2) + 1],L)
  134.     else
  135.        Move(Str[((L - Size) div 2) + 1],Temp[1],Size);
  136.     PadCenter := temp;
  137. end; {center}
  138.  
  139. Function PadRight(Str:string;Size:byte;Pad:char):string;
  140. var
  141.   temp : string;
  142.   L : integer;
  143. begin
  144.     Fillchar(Temp[1],Size,Pad);
  145.     Temp[0] := chr(Size);
  146.     L := length(Str);
  147.     If L <= Size then
  148.        Move(Str[1],Temp[succ(Size - L)],L)
  149.     else
  150.        Move(Str[1],Temp[1],size);
  151.     PadRight := Temp;
  152. end;
  153.  
  154. Function Last(N:byte;Str:string):string;
  155. var Temp : string;
  156. begin
  157.     If N > length(Str) then
  158.        Temp := Str
  159.     else
  160.        Temp := copy(Str,succ(length(Str) - N),N);
  161.     Last := Temp;
  162. end;  {Func Last}
  163.  
  164. Function First(N:byte;Str:string):string;
  165. var Temp : string;
  166. begin
  167.     If N > length(Str) then
  168.        Temp := Str
  169.     else
  170.        Temp := copy(Str,1,N);
  171.     First := Temp;
  172. end;  {Func First}
  173.  
  174. Function Upper(Str:string):string;
  175. var
  176.   I : integer;
  177. begin
  178.     For I := 1 to length(Str) do
  179.         Str[I] := Upcase(Str[I]);
  180.     Upper := Str;
  181. end;  {Func Upper}
  182.  
  183. Function Lower(Str:string):string;
  184. var
  185.   I : integer;
  186. begin
  187.     For I := 1 to length(Str) do
  188.         If ord(Str[I]) in [65..90] then
  189.            Str[I] := chr(ord(Str[I]) + 32);
  190.     Lower := Str;
  191. end;  {Func Lower}
  192.  
  193. Function Proper(Str:string):string;
  194. var
  195.   I : integer;
  196.   SpaceBefore: boolean;
  197. begin
  198.     SpaceBefore := true;
  199.     Str := lower(Str);
  200.     For I := 1 to length(Str) do
  201.         If SpaceBefore and (ord(Str[I]) in [97..122]) then
  202.         begin
  203.             SpaceBefore := False;
  204.             Str[I] := Upcase(Str[I]);
  205.         end
  206.         else
  207.             If (SpaceBefore = False) and (Str[I] = ' ') then
  208.                 SpaceBefore := true;
  209.     Proper := Str;
  210. end;
  211.  
  212. Function OverType(N:byte;StrS,StrT:string):string;
  213. {Overlays StrS onto StrT at Pos N}
  214. var
  215.   L : byte;
  216.   StrN : string;
  217. begin
  218.     L := N + pred(length(StrS));
  219.     If L < length(StrT) then
  220.        L := length(StrT);
  221.     If L > 255 then
  222.        Overtype := copy(StrT,1,pred(N)) + copy(StrS,1,255-N)
  223.         else
  224.     begin
  225.        Fillchar(StrN[1],L,' ');
  226.        StrN[0] := chr(L);
  227.        Move(StrT[1],StrN[1],length(StrT));
  228.        Move(StrS[1],StrN[N],length(StrS));
  229.        OverType := StrN;
  230.     end;
  231. end;  {Func OverType}
  232.  
  233. Function Strip(L,C:char;Str:string):string;
  234. {L is left,center,right,all,ends}
  235. var I :  byte;
  236. begin
  237.     Case Upcase(L) of
  238.     'L' : begin       {Left}
  239.               While (Str[1] = C) and (length(Str) > 0) do
  240.                     Delete(Str,1,1);
  241.           end;
  242.     'R' : begin       {Right}
  243.               While (Str[length(Str)] = C) and (length(Str) > 0) do
  244.                     Delete(Str,length(Str),1);
  245.           end;
  246.     'B' : begin       {Both left and right}
  247.               While (Str[1] = C) and (length(Str) > 0) do
  248.                     Delete(Str,1,1);
  249.               While (Str[length(Str)] = C) and (length(Str) > 0)  do
  250.                     Delete(Str,length(Str),1);
  251.           end;
  252.     'A' : begin       {All}
  253.               I := 1;
  254.               Repeat
  255.                    If (Str[I] = C) and (length(Str) > 0) then
  256.                       Delete(Str,I,1)
  257.                    else
  258.                       I := succ(I);
  259.               Until (I > length(Str)) or (Str = '');
  260.           end;
  261.     end;
  262.     Strip := Str;
  263. end;  {Func Strip}
  264.  
  265. Function LastPos(C:Char;Str:string):byte;
  266. Var I : byte;
  267. begin
  268.     I := succ(Length(Str));
  269.     Repeat
  270.          I := Pred(I);
  271.     Until (I = 0) or (Str[I] = C);
  272.     LastPos := I;
  273. end;  {Func LastPos}
  274.  
  275. Function LocWord(StartAT,Wordno:byte;Str:string):byte;
  276. {local proc used by PosWord and Extract word}
  277. var
  278.   W,L: integer;
  279.   Spacebefore: boolean;
  280. begin
  281.     If (Str = '') or (wordno < 1) or (StartAT > length(Str)) then
  282.     begin
  283.         LocWord := 0;
  284.         exit;
  285.     end;
  286.     SpaceBefore := true;
  287.     W := 0;
  288.     L := length(Str);
  289.     StartAT := pred(StartAT);
  290.     While (W < Wordno) and (StartAT <= length(Str)) do
  291.     begin
  292.         StartAT := succ(StartAT);
  293.         If SpaceBefore and (Str[StartAT] <> ' ') then
  294.         begin
  295.             W := succ(W);
  296.             SpaceBefore := false;
  297.         end
  298.         else
  299.             If (SpaceBefore = false) and (Str[StartAT] = ' ') then
  300.                 SpaceBefore := true;
  301.     end;
  302.     If W = Wordno then
  303.        LocWord := StartAT
  304.     else
  305.        LocWord := 0;
  306. end;
  307.  
  308. Function PosWord(Wordno:byte;Str:string):byte;
  309. begin
  310.     PosWord := LocWord(1,wordno,Str);
  311. end;  {Func Word}
  312.  
  313. Function WordCnt(Str:string):byte;
  314. var
  315.   W,I: integer;
  316.   SpaceBefore: boolean;
  317. begin
  318.     If Str = '' then
  319.     begin
  320.         WordCnt := 0;
  321.         exit;
  322.     end;
  323.     SpaceBefore := true;
  324.     W := 0;
  325.     For  I :=  1 to length(Str) do
  326.     begin
  327.         If SpaceBefore and (Str[I] <> ' ') then
  328.         begin
  329.             W := succ(W);
  330.             SpaceBefore := false;
  331.         end
  332.         else
  333.             If (SpaceBefore = false) and (Str[I] = ' ') then
  334.                 SpaceBefore := true;
  335.     end;
  336.     WordCnt := W;
  337. end;
  338.  
  339. Function ExtractWords(StartWord,NoWords:byte;Str:string):string;
  340. var Start, finish : integer;
  341. begin
  342.     If Str = '' then
  343.     begin
  344.         ExtractWords := '';
  345.         exit;
  346.     end;
  347.     Start := LocWord(1,StartWord,Str);
  348.     If Start <> 0 then
  349.        finish := LocWord(Start,succ(NoWords),Str)
  350.     else
  351.     begin
  352.         ExtractWords := '';
  353.         exit;
  354.     end;
  355.     If finish = 0 then {5.02A}
  356.        finish := succ(length(Str));
  357.     Repeat
  358.         finish := pred(finish);
  359.     Until Str[finish] <> ' ';
  360.     ExtractWords := copy(Str,Start,succ(finish-Start));
  361. end;  {Func ExtractWords}
  362.  
  363. Function Int_to_Str(Number:longint):string;
  364. var Temp : string;
  365. begin
  366.     Str(Number,temp);
  367.     Int_to_Str := temp;
  368. end;
  369.  
  370. Function Str_to_Real(Str:string):real;
  371. var
  372.   code : integer;
  373.   Temp : real;
  374. begin
  375.     If length(Str) = 0 then
  376.        Str_to_Real := 0
  377.     else
  378.     begin
  379.         If Copy(Str,1,1)='.' Then
  380.            Str:='0'+Str;
  381.         If (Copy(Str,1,1)='-') and (Copy(Str,2,1)='.') Then
  382.            Insert('0',Str,2);
  383.         If Str[length(Str)] = '.' then
  384.            Delete(Str,length(Str),1);
  385.        val(Str,temp,code);
  386.        if code = 0 then
  387.           Str_to_Real := temp
  388.        else
  389.           Str_to_Real := 0;
  390.     end;
  391. end;
  392.  
  393. function Real_to_str(Number:real;Decimals:byte):string;
  394. var Temp : string;
  395. begin
  396.     Str(Number:20:Decimals,Temp);
  397.     repeat
  398.          If copy(Temp,1,1) = ' ' then delete(Temp,1,1);
  399.     until copy(temp,1,1) <> ' ';
  400.     If Decimals = Floating then
  401.     begin
  402.        Temp := Strip('R','0',Temp);
  403.        If Temp[Length(temp)] = '.' then
  404.           Delete(temp,Length(temp),1);
  405.     end;
  406.     Real_to_Str := Temp;
  407. end;
  408.  
  409. Function  Str_to_Int(Str:string):integer;
  410. var temp,code : integer;
  411. begin
  412.     If length(Str) = 0 then
  413.        Str_to_Int := 0
  414.     else
  415.     begin
  416.        val(Str,temp,code);
  417.        if code = 0 then
  418.           Str_to_Int := temp
  419.        else
  420.           Str_to_Int := 0;
  421.     end;
  422. end;
  423.  
  424. Function Str_to_Long(Str:string):Longint;
  425. var
  426.   code : integer;
  427.   Temp : longint;
  428. begin
  429.     If length(Str) = 0 then
  430.        Str_to_Long := 0
  431.     else
  432.     begin
  433.        val(Str,temp,code);
  434.        if code = 0 then
  435.           Str_to_Long := temp
  436.        else
  437.           Str_to_Long := 0;
  438.     end;
  439. end;
  440.  
  441. Function Real_to_SciStr(Number:real; D:byte):string;
  442. {Credits: Michael Harris, Houston. Thanks!}
  443. Const
  444.     DamnNearUnity = 9.99999999E-01;
  445. Var
  446.     Temp : real;
  447.     Power: integer;
  448.     Value: string;
  449.     Sign : char;
  450. begin
  451.     If Number = 1.0 then
  452.        Real_to_SciStr := '1.000'
  453.     else
  454.     begin
  455.         Temp := Number;
  456.         Power := 0;
  457.         If Number > 1.0 then
  458.         begin
  459.            While Temp >= 10.0 do
  460.            begin
  461.                Inc(Power);
  462.                Temp := Temp/10.0;
  463.            end;
  464.            Sign := '+';
  465.         end
  466.         else
  467.         begin
  468.             While Temp < DamnNearUnity do
  469.             begin
  470.                 Inc(Power);
  471.                 Temp := Temp * 10.0;
  472.             end;
  473.             Sign := '-';
  474.         end;
  475.         Value := Real_To_Str(Temp,D);
  476.         Real_to_SciStr := Value+' E'+Sign+Padright(Int_to_Str(Power),2,'0');
  477.     end;
  478. end; {func Real_to_SciStr}
  479.  
  480. begin    {unit initialization}
  481. end.
  482.  
  483.