home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / d / drcpas10.zip / TOOLS.PAS < prev   
Pascal/Delphi Source File  |  1992-11-17  |  14KB  |  534 lines
  1. {$A+,B-,D-,F-,I+,L-,N-,O-,R-,S+,V-}
  2. Unit Tools;
  3.  
  4. (* by David R. Conrad, for Turbo Pascal 5.5
  5.  
  6.    This code is not copyrighted, you may use it freely.
  7.    There are no guarantees, either expressed or implied,
  8.    as to either merchantability or fitness for a particular
  9.    purpose.  The author's liability is limited to the amount
  10.    you paid for it.
  11.  
  12.    David R. Conrad, 17 Nov 92
  13.    David_Conrad@mts.cc.wayne.edu
  14.    dave@michigan.com
  15. *)
  16.  
  17. Interface
  18.  
  19. const
  20.   (* for use with the ShftKeys global variable: see also keyboard.pas *)
  21.   RIGHTSHIFT = $01;
  22.   LEFTSHIFT  = $02;
  23.   CTRLKEY    = $04;
  24.   ALTKEY     = $08;
  25.   SCROLLLOCK = $10;
  26.   NUMLOCK    = $20;
  27.   CAPSLOCK   = $40;
  28.   INSTOGGLE  = $80;
  29.  
  30.   whitespace : set of char = [#9,#10,#12,#13,' ',#255];
  31.  
  32. var
  33.   (* items from the BIOS data area *)
  34.   ShftKeys : Byte Absolute $0040:$0017;
  35.   CrtMode  : Byte Absolute $0040:$0049;
  36.   CrtWidth : Byte Absolute $0040:$004A;
  37.  
  38. (* all routines are documented in the implementation section *)
  39.  
  40. Function BCDbin (B : Byte) : Byte;
  41. Function BinBCD (B : Byte) : Byte;
  42. Function BinB (B : Byte) : String;
  43. Function BinW (W : Word) : String;
  44. Function BinL (L : Longint) : String;
  45. Function CommaStr (L : Longint) : String;
  46. Function CommarStr (R : Real; D : Byte) : String;
  47. Function ConstStr (C : Char; N : Byte) : String;
  48. Function DayStr (D : Byte) : String;
  49. Procedure DecPtr (Var P : Pointer);
  50. Procedure DecFarPtr (Var P : Pointer);
  51. Function FoldSpace (S : String) : String;
  52. Function HeadStr (S : String; N : Byte) : String;
  53. Function Hexit (H : Byte) : Char;
  54. Function HexB (B : Byte) : String;
  55. Function HexW (W : Word) : String;
  56. Function HexL (L : Longint) : String;
  57. Procedure IncPtr (Var P : Pointer);
  58. Procedure IncFarPtr (Var P : Pointer);
  59. Function Leap (Year : Integer) : Boolean;
  60. Function LowCase (C : Char) : Char;
  61. Function LowerStr (S : String) : String;
  62. Function MonthLen (M : Byte) : Byte;
  63. Function MonthStr (M : Byte) : String;
  64. Function NumStr (N : Longint; W : Byte) : String;
  65. Function NumrStr (N : Real; W,D : Byte) : String;
  66. Function OctB (B : Byte) : String;
  67. Function OctW (W : Word) : String;
  68. Function OctL (L : Longint) : String;
  69. Function PtrStr (P : Pointer) : String;
  70. Function Roman (N : Word) : String;
  71. Function Rot13 (Ch : Char) : Char;
  72. Function Rot13Str (S : String) : String;
  73. Function SubiStr (Sub,S : String) : Boolean;
  74. Function SubStr (Sub,S : String) : Boolean;
  75. Function SwapChars (S : string; Original, Replace : Char) : String;
  76. Function TailStr (S : String; N : Byte) : String;
  77. Function TrimHead (S : String) : String;
  78. Function TrimTail (S : String) : String;
  79. Function UpperStr (S : String) : String;
  80. Function ZeroStr (L : Longint; W : Byte) : String;
  81. Function ZerorStr (R : Real; W,D : Byte) : String;
  82.  
  83. Implementation
  84.  
  85. Function BCDbin (B : Byte) : Byte;
  86. (* convert a binary coded decimal to binary *)
  87. begin
  88.   BCDbin := B SHR 4 * 10 + B AND $0F;
  89. end;
  90.  
  91. Function BinBCD (B : Byte) : Byte;
  92. (* convert a byte in the range 0..99 to binary coded decimal *)
  93. begin
  94.   BinBCD := B DIV 10 * 16 + B MOD 10;
  95. end;
  96.  
  97. Function BinB (B : Byte) : String;
  98. (* convert a byte to a string of binary digits *)
  99. var
  100.   i, j : byte;
  101.   s : string[8];
  102. begin
  103.   s := '00000000';
  104.   i := 128;
  105.   for j := 1 to 8 do
  106.     begin
  107.       if (B AND i) <> 0 then s[j] := '1';
  108.       i := i SHR 1;
  109.     end;
  110.   BinB := s;
  111. end;
  112.  
  113. Function BinW (W : Word) : String;
  114. (* convert a word to binary *)
  115. begin
  116.   BinW := BinB(hi(W)) + BinB(lo(W));
  117. end;
  118.  
  119. Function BinL (L : Longint) : String;
  120. (* convert a longint to binary *)
  121. var
  122.   W : array[0..1] of Word absolute L;
  123. begin
  124.   BinL := BinW(W[1]) + BinW(W[0]);
  125. end;
  126.  
  127. Function CommaStr (L : Longint) : String;
  128. (* format an integer with commas (1,234,567) *)
  129. var
  130.   s : string;
  131.   len,alen,num,cnt : byte;
  132. begin
  133.   str (L,s);
  134.   len := length(s);
  135.   If L >= 0 then alen := pred(len) Else alen := pred(len) - 1;
  136.   num := alen DIV 3;
  137.   for cnt := 1 to num do
  138.     Insert (',',s,len - cnt * 3 + 1);
  139.   CommaStr := s;
  140. end;
  141.  
  142. Function CommarStr (R : Real; D : Byte) : String;
  143. (* format a real with commas: see also ieee.pas *)
  144. var
  145.   s,st : string;
  146.   len,alen,num,cnt : byte;
  147.   rh,rt : real;
  148. begin
  149.   rh := Int(R);
  150.   rt := Frac(R);
  151.   str (rh:0:0,s);
  152.   str (rt:0:D,st);
  153.   delete (st,1,1);
  154.   len := length(s);
  155.   If R >= 0 then alen := pred(len) Else alen := pred(len) - 1;
  156.   num := alen DIV 3;
  157.   for cnt := 1 to num do
  158.     Insert (',',s,len - cnt * 3 + 1);
  159.   CommarStr := s + st;
  160. end;
  161.  
  162. Function ConstStr (C : Char; N : Byte) : String;
  163. (* create an N-character long string filled with C's *)
  164. var
  165.   s : string;
  166. begin
  167.   s[0] := Chr(N);
  168.   FillChar(s[1],N,C);
  169.   ConstStr := s;
  170. end;
  171.  
  172. Function DayStr (D : Byte) : String;
  173. (* return the (English) name of a day of the week, Sunday = 0 *)
  174. begin
  175.   case D of
  176.     0 : DayStr := 'Sunday';
  177.     1 : DayStr := 'Monday';
  178.     2 : DayStr := 'Tuesday';
  179.     3 : DayStr := 'Wednesday';
  180.     4 : DayStr := 'Thursday';
  181.     5 : DayStr := 'Friday';
  182.     6 : DayStr := 'Saturday';
  183.   else
  184.     DayStr := '';
  185.   end;
  186. end;
  187.  
  188. Procedure DecPtr (Var P : Pointer);
  189. (* decrement a pointer, !!! Will wrap around the beginning of segments! *)
  190. begin
  191.   P := Ptr(Seg(P^),Pred(Ofs(P^)));
  192. end;
  193.  
  194. Procedure DecFarPtr (Var P : Pointer);
  195. (* decrement a pointer, handling segments *)
  196. begin
  197.   If Ofs(P^) = 0 then
  198.     P := Ptr(Pred(Seg(P^)),15)
  199.   Else
  200.     P := Ptr(Seg(P^),Pred(Ofs(P^)));
  201. end;
  202.  
  203. Function FoldSpace (S : String) : String;
  204. (* '   Collapse   spaces   ' --> ' Collapse spaces ' *)
  205. var
  206.   i : byte;
  207. begin
  208.   i := 1;
  209.   while (i <= Length(S)) and (S[i] in WhiteSpace) do
  210.     Inc (i);
  211.   while (i < Length(S)) do
  212.     begin
  213.       if S[i] = ' ' then
  214.         while (i < Length(S)) and (S[i+1] = ' ') do delete (S,i+1,1);
  215.       Inc (i);
  216.     end;
  217.   FoldSpace := S;
  218. end;
  219.  
  220. Function HeadStr (S : String; N : Byte) : String;
  221. (* return the first N characters of a string *)
  222. begin
  223.   HeadStr := Copy(S,1,N);
  224. end;
  225.  
  226. Function Hexit (H : Byte) : Char;
  227. (* convert a byte in the range 0..15 to hexadecimal '0'..'F' *)
  228. begin
  229.   if H <= 9 then
  230.     Hexit := char(H + byte('0'))
  231.   else
  232.     if H <= 15 then
  233.       Hexit := char(H + byte('A') - 10)
  234.     else
  235.       Hexit := '?';
  236. end;
  237.  
  238. Function HexB (B : Byte) : String;
  239. (* convert a byte to hexadecimal *)
  240. var
  241.   m,n : byte;
  242. begin
  243.   m := B shr 4;
  244.   n := B and $0F;
  245.   HexB := Hexit(m) + Hexit(n);
  246. end;
  247.  
  248. Function HexW (W : Word) : String;
  249. (* convert a word to hexadecimal *)
  250. begin
  251.   HexW := HexB(hi(W)) + HexB(lo(W));
  252. end;
  253.  
  254. Function HexL (L : Longint) : String;
  255. (* convert a longint to hexadecimal *)
  256. var
  257.   W : array[0..1] of Word absolute L;
  258. begin
  259.   HexL := HexW(W[1]) + HexW(W[0]);
  260. end;
  261.  
  262. Procedure IncPtr (Var P : Pointer);
  263. (* increment a pointer, !!! Will wrap around the end of segments! *)
  264. begin
  265.   P := Ptr(Seg(P^),Succ(Ofs(P^)));
  266. end;
  267.  
  268. Procedure IncFarPtr (Var P : Pointer);
  269. (* increment a pointer, handling segments *)
  270. begin
  271.   If Succ(Ofs(P^)) = 0 then
  272.     P := Ptr(Seg(P^)+$1000,0)
  273.   Else
  274.     P := Ptr(Seg(P^),Succ(Ofs(P^)));
  275. end;
  276.  
  277. Function Leap (Year : Integer) : Boolean;
  278. (* tell whether a year is a leap year *)
  279. begin
  280.   Leap := (Year MOD 4 = 0) and ((Year MOD 100 <> 0) or (Year MOD 400 = 0));
  281. end;
  282.  
  283. Function LowCase (C : Char) : Char;
  284. (* opposite of UpCase; convert characters to lower case *)
  285. begin
  286.   If ('A' <= c) and (c <= 'Z') then
  287.     LowCase := chr(ord(c) + 32)
  288.   Else
  289.     LowCase := c;
  290. end;
  291.  
  292. Function LowerStr (S : String) : String;
  293. (* convert all letters in a string to lower case *)
  294. var
  295.   cnt : byte;
  296. begin
  297.   for cnt := 1 to length(S) do
  298.     S[cnt] := LowCase(S[cnt]);
  299.   LowerStr := S;
  300. end;
  301.  
  302. Function MonthLen (M : Byte) : Byte;
  303. (* return length of a given month, !!! No leap years (Feb = 28)! *)
  304. begin
  305.   case M of
  306.     1  : MonthLen := 31;
  307.     2  : MonthLen := 28;
  308.     3  : MonthLen := 31;
  309.     4  : MonthLen := 30;
  310.     5  : MonthLen := 31;
  311.     6  : MonthLen := 30;
  312.     7  : MonthLen := 31;
  313.     8  : MonthLen := 31;
  314.     9  : MonthLen := 30;
  315.     10 : MonthLen := 31;
  316.     11 : MonthLen := 30;
  317.     12 : MonthLen := 31;
  318.   else
  319.     MonthLen := 0;
  320.   end;
  321. end;
  322.  
  323. Function MonthStr (M : Byte) : String;
  324. (* return (English) name of month *)
  325. begin
  326.   case M of
  327.     1  : MonthStr := 'January';
  328.     2  : MonthStr := 'February';
  329.     3  : MonthStr := 'March';
  330.     4  : MonthStr := 'April';
  331.     5  : MonthStr := 'May';
  332.     6  : MonthStr := 'June';
  333.     7  : MonthStr := 'July';
  334.     8  : MonthStr := 'August';
  335.     9  : MonthStr := 'September';
  336.     10 : MonthStr := 'October';
  337.     11 : MonthStr := 'November';
  338.     12 : MonthStr := 'December';
  339.   else
  340.     MonthStr := '';
  341.   end;
  342. end;
  343.  
  344. Function NumStr (N : Longint; W : Byte) : String;
  345. (* convert an integer to a string, right justified in W spaces *)
  346. var
  347.   s : string;
  348. begin
  349.   str (N:W,s);
  350.   NumStr := s;
  351. end;
  352.  
  353. Function NumrStr (N : Real; W,D : Byte) : String;
  354. (* convert a real in W spaces, D decimal places: see also ieee.pas *)
  355. var
  356.   s : string;
  357. begin
  358.   str (N:W:D,s);
  359.   NumrStr := s;
  360. end;
  361.  
  362. Function OctB (B : Byte) : String;
  363. (* convert a byte to octal *)
  364. begin
  365.   OctB := char(byte('0') + ((B AND $C0) SHR 6)) +
  366.           char(byte('0') + ((B AND $38) SHR 3)) +
  367.           char(byte('0') +  (B AND $07));
  368. end;
  369.  
  370. Function OctW (W : Word) : String;
  371. (* convert a word to octal *)
  372. begin
  373.   OctW := char(byte('0') + ((W AND $8000) SHR 15)) +
  374.           char(byte('0') + ((W AND $7000) SHR 12)) +
  375.           char(byte('0') + ((W AND $0E00) SHR  9)) +
  376.           char(byte('0') + ((W AND $01C0) SHR  6)) +
  377.           char(byte('0') + ((W AND $0038) SHR  3)) +
  378.           char(byte('0') +  (W AND $0007));
  379. end;
  380.  
  381. Function OctL (L : Longint) : String;
  382. (* convert a longint to octal *)
  383. begin
  384.   OctL := char(byte('0') + ((L AND $C0000000) SHR 15)) +
  385.           char(byte('0') + ((L AND $38000000) SHR 12)) +
  386.           char(byte('0') + ((L AND $07000000) SHR  9)) +
  387.           char(byte('0') + ((L AND $00E00000) SHR  6)) +
  388.           char(byte('0') + ((L AND $001C0000) SHR  3)) +
  389.           char(byte('0') + ((L AND $00038000) SHR 15)) +
  390.           char(byte('0') + ((L AND $00007000) SHR 12)) +
  391.           char(byte('0') + ((L AND $00000E00) SHR  9)) +
  392.           char(byte('0') + ((L AND $000001C0) SHR  6)) +
  393.           char(byte('0') + ((L AND $00000038) SHR  3)) +
  394.           char(byte('0') +  (L AND $00000007));
  395. end;
  396.  
  397. Function PtrStr (P : Pointer) : String;
  398. (* convert a pointer to a string, format XXXX:XXXX *)
  399. begin
  400.   PtrStr := HexW(Seg(P^)) + ':' + HexW(Ofs(P^));
  401. end;
  402.  
  403. Function Roman (N : Word) : String;
  404. (* convert an integer (1..3999) to a Roman numeral, e.g. MCMXCII *)
  405.  
  406. Function RomanDigit (one, five, ten : char; n : byte) : string;
  407. begin
  408.   case n of
  409.     0    : RomanDigit := '';
  410.     1..3 : RomanDigit := ConstStr(one, n);
  411.     4    : RomanDigit := one + five;
  412.     5..8 : RomanDigit := five + ConstStr(one, n - 5);
  413.     9    : RomanDigit := one + ten;
  414.   end;
  415. end;
  416.  
  417. var
  418.   s : string;
  419. begin
  420.   if N > 3999 then begin Roman := ''; exit; end;
  421.   s := RomanDigit('M',' ',' ',n DIV 1000);
  422.   n := n MOD 1000;
  423.   s := s + RomanDigit('C','D','M',n DIV 100);
  424.   n := n MOD 100;
  425.   s := s + RomanDigit('X','L','C',n DIV 10);
  426.   n := n MOD 10;
  427.   s := s + RomanDigit('I','V','X',n);
  428.   Roman := s;
  429. end;
  430.  
  431. Function Rot13 (Ch : Char) : Char;
  432. (* rotate the alphabet 13 places, nopqrstuvwxyzabcdefghijklm *)
  433. begin                             
  434.   if not (ch in ['A'..'Z','a'..'z']) then
  435.     begin
  436.       Rot13 := ch;
  437.       exit;
  438.     end;
  439.   if ch in ['A'..'M','a'..'m'] then
  440.     Rot13 := chr(ord(ch)+13)
  441.   else
  442.     Rot13 := chr(ord(ch)-13);
  443. end;
  444.  
  445. Function Rot13Str (S : String) : String;
  446. (* encrypt or decrypt a string with rot13 *)
  447. var
  448.   indx : byte;
  449. begin
  450.   for indx := 1 to length(S) do
  451.     S[indx] := Rot13(S[indx]);
  452.   Rot13Str := S;
  453. end;
  454.  
  455. Function SubiStr (Sub,S : String) : Boolean;
  456. (* substring matching, case insensitive *)
  457. begin
  458.   SubiStr := Pos(UpperStr(Sub),UpperStr(S)) <> 0;
  459. end;
  460.  
  461. Function SubStr (Sub,S : String) : Boolean;
  462. (* is one string a substring of another *)
  463. begin
  464.   SubStr := Pos(Sub,S) <> 0;
  465. end;
  466.  
  467. Function SwapChars (S : string; Original, Replace : Char) : String;
  468. (* replace all occurances of one character with another in a string *)
  469. var
  470.   i : byte;
  471. begin
  472.   for i := 1 to length(s) do
  473.     if S[i] = Original then S[i] := Replace;
  474.   SwapChars := S;
  475. end;
  476.  
  477. Function TailStr (S : String; N : Byte) : String;
  478. (* return the last N characters of a string *)
  479. begin
  480.   TailStr := Copy(S,Length(S) - N + 1,N);
  481. end;
  482.  
  483. Function TrimHead (S : String) : String;
  484. (* remove all whitespace from the beginning of a string *)
  485. begin
  486.   While (S <> '') and (S[1] in whitespace) do
  487.     Delete (S,1,1);
  488.   TrimHead := S;
  489. end;
  490.  
  491. Function TrimTail (S : String) : String;
  492. (* remove all whitespace from the end of a string *)
  493. begin
  494.   While (S <> '') and (S[Length(S)] in whitespace) do
  495.     Delete (S,Length(S),1);
  496.   TrimTail := S;
  497. end;
  498.  
  499. Function UpperStr (S : String) : String;
  500. (* convert a string to all upper case *)
  501. var
  502.   indx : byte;
  503. begin
  504.   for indx := 1 to length(S) do
  505.     S[indx] := UpCase(S[indx]);
  506.   UpperStr := S;
  507. end;
  508.  
  509. Function ZeroStr (L : Longint; W : Byte) : String;
  510. (* format an integer right justified in a field of zeroes *)
  511. var
  512.   s   : string;
  513.   cnt : byte;
  514. begin
  515.   str (L:W,s);
  516.   for cnt := 1 to length(s) do
  517.     If s[cnt] = ' ' then s[cnt] := '0';
  518.   ZeroStr := s;
  519. end;
  520.  
  521. Function ZerorStr (R : Real; W,D : Byte) : String;
  522. (* format a real with D decimal places in W zeroes: see also ieee.pas *)
  523. var
  524.   s   : string;
  525.   cnt : byte;
  526. begin
  527.   str (R:W:D,s);
  528.   for cnt := 1 to length(s) do
  529.     If s[cnt] = ' ' then s[cnt] := '0';
  530.   ZerorStr := s;
  531. end;
  532.  
  533. End.
  534.