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
Wrap
Pascal/Delphi Source File
|
1992-11-17
|
14KB
|
534 lines
{$A+,B-,D-,F-,I+,L-,N-,O-,R-,S+,V-}
Unit Tools;
(* by David R. Conrad, for Turbo Pascal 5.5
This code is not copyrighted, you may use it freely.
There are no guarantees, either expressed or implied,
as to either merchantability or fitness for a particular
purpose. The author's liability is limited to the amount
you paid for it.
David R. Conrad, 17 Nov 92
David_Conrad@mts.cc.wayne.edu
dave@michigan.com
*)
Interface
const
(* for use with the ShftKeys global variable: see also keyboard.pas *)
RIGHTSHIFT = $01;
LEFTSHIFT = $02;
CTRLKEY = $04;
ALTKEY = $08;
SCROLLLOCK = $10;
NUMLOCK = $20;
CAPSLOCK = $40;
INSTOGGLE = $80;
whitespace : set of char = [#9,#10,#12,#13,' ',#255];
var
(* items from the BIOS data area *)
ShftKeys : Byte Absolute $0040:$0017;
CrtMode : Byte Absolute $0040:$0049;
CrtWidth : Byte Absolute $0040:$004A;
(* all routines are documented in the implementation section *)
Function BCDbin (B : Byte) : Byte;
Function BinBCD (B : Byte) : Byte;
Function BinB (B : Byte) : String;
Function BinW (W : Word) : String;
Function BinL (L : Longint) : String;
Function CommaStr (L : Longint) : String;
Function CommarStr (R : Real; D : Byte) : String;
Function ConstStr (C : Char; N : Byte) : String;
Function DayStr (D : Byte) : String;
Procedure DecPtr (Var P : Pointer);
Procedure DecFarPtr (Var P : Pointer);
Function FoldSpace (S : String) : String;
Function HeadStr (S : String; N : Byte) : String;
Function Hexit (H : Byte) : Char;
Function HexB (B : Byte) : String;
Function HexW (W : Word) : String;
Function HexL (L : Longint) : String;
Procedure IncPtr (Var P : Pointer);
Procedure IncFarPtr (Var P : Pointer);
Function Leap (Year : Integer) : Boolean;
Function LowCase (C : Char) : Char;
Function LowerStr (S : String) : String;
Function MonthLen (M : Byte) : Byte;
Function MonthStr (M : Byte) : String;
Function NumStr (N : Longint; W : Byte) : String;
Function NumrStr (N : Real; W,D : Byte) : String;
Function OctB (B : Byte) : String;
Function OctW (W : Word) : String;
Function OctL (L : Longint) : String;
Function PtrStr (P : Pointer) : String;
Function Roman (N : Word) : String;
Function Rot13 (Ch : Char) : Char;
Function Rot13Str (S : String) : String;
Function SubiStr (Sub,S : String) : Boolean;
Function SubStr (Sub,S : String) : Boolean;
Function SwapChars (S : string; Original, Replace : Char) : String;
Function TailStr (S : String; N : Byte) : String;
Function TrimHead (S : String) : String;
Function TrimTail (S : String) : String;
Function UpperStr (S : String) : String;
Function ZeroStr (L : Longint; W : Byte) : String;
Function ZerorStr (R : Real; W,D : Byte) : String;
Implementation
Function BCDbin (B : Byte) : Byte;
(* convert a binary coded decimal to binary *)
begin
BCDbin := B SHR 4 * 10 + B AND $0F;
end;
Function BinBCD (B : Byte) : Byte;
(* convert a byte in the range 0..99 to binary coded decimal *)
begin
BinBCD := B DIV 10 * 16 + B MOD 10;
end;
Function BinB (B : Byte) : String;
(* convert a byte to a string of binary digits *)
var
i, j : byte;
s : string[8];
begin
s := '00000000';
i := 128;
for j := 1 to 8 do
begin
if (B AND i) <> 0 then s[j] := '1';
i := i SHR 1;
end;
BinB := s;
end;
Function BinW (W : Word) : String;
(* convert a word to binary *)
begin
BinW := BinB(hi(W)) + BinB(lo(W));
end;
Function BinL (L : Longint) : String;
(* convert a longint to binary *)
var
W : array[0..1] of Word absolute L;
begin
BinL := BinW(W[1]) + BinW(W[0]);
end;
Function CommaStr (L : Longint) : String;
(* format an integer with commas (1,234,567) *)
var
s : string;
len,alen,num,cnt : byte;
begin
str (L,s);
len := length(s);
If L >= 0 then alen := pred(len) Else alen := pred(len) - 1;
num := alen DIV 3;
for cnt := 1 to num do
Insert (',',s,len - cnt * 3 + 1);
CommaStr := s;
end;
Function CommarStr (R : Real; D : Byte) : String;
(* format a real with commas: see also ieee.pas *)
var
s,st : string;
len,alen,num,cnt : byte;
rh,rt : real;
begin
rh := Int(R);
rt := Frac(R);
str (rh:0:0,s);
str (rt:0:D,st);
delete (st,1,1);
len := length(s);
If R >= 0 then alen := pred(len) Else alen := pred(len) - 1;
num := alen DIV 3;
for cnt := 1 to num do
Insert (',',s,len - cnt * 3 + 1);
CommarStr := s + st;
end;
Function ConstStr (C : Char; N : Byte) : String;
(* create an N-character long string filled with C's *)
var
s : string;
begin
s[0] := Chr(N);
FillChar(s[1],N,C);
ConstStr := s;
end;
Function DayStr (D : Byte) : String;
(* return the (English) name of a day of the week, Sunday = 0 *)
begin
case D of
0 : DayStr := 'Sunday';
1 : DayStr := 'Monday';
2 : DayStr := 'Tuesday';
3 : DayStr := 'Wednesday';
4 : DayStr := 'Thursday';
5 : DayStr := 'Friday';
6 : DayStr := 'Saturday';
else
DayStr := '';
end;
end;
Procedure DecPtr (Var P : Pointer);
(* decrement a pointer, !!! Will wrap around the beginning of segments! *)
begin
P := Ptr(Seg(P^),Pred(Ofs(P^)));
end;
Procedure DecFarPtr (Var P : Pointer);
(* decrement a pointer, handling segments *)
begin
If Ofs(P^) = 0 then
P := Ptr(Pred(Seg(P^)),15)
Else
P := Ptr(Seg(P^),Pred(Ofs(P^)));
end;
Function FoldSpace (S : String) : String;
(* ' Collapse spaces ' --> ' Collapse spaces ' *)
var
i : byte;
begin
i := 1;
while (i <= Length(S)) and (S[i] in WhiteSpace) do
Inc (i);
while (i < Length(S)) do
begin
if S[i] = ' ' then
while (i < Length(S)) and (S[i+1] = ' ') do delete (S,i+1,1);
Inc (i);
end;
FoldSpace := S;
end;
Function HeadStr (S : String; N : Byte) : String;
(* return the first N characters of a string *)
begin
HeadStr := Copy(S,1,N);
end;
Function Hexit (H : Byte) : Char;
(* convert a byte in the range 0..15 to hexadecimal '0'..'F' *)
begin
if H <= 9 then
Hexit := char(H + byte('0'))
else
if H <= 15 then
Hexit := char(H + byte('A') - 10)
else
Hexit := '?';
end;
Function HexB (B : Byte) : String;
(* convert a byte to hexadecimal *)
var
m,n : byte;
begin
m := B shr 4;
n := B and $0F;
HexB := Hexit(m) + Hexit(n);
end;
Function HexW (W : Word) : String;
(* convert a word to hexadecimal *)
begin
HexW := HexB(hi(W)) + HexB(lo(W));
end;
Function HexL (L : Longint) : String;
(* convert a longint to hexadecimal *)
var
W : array[0..1] of Word absolute L;
begin
HexL := HexW(W[1]) + HexW(W[0]);
end;
Procedure IncPtr (Var P : Pointer);
(* increment a pointer, !!! Will wrap around the end of segments! *)
begin
P := Ptr(Seg(P^),Succ(Ofs(P^)));
end;
Procedure IncFarPtr (Var P : Pointer);
(* increment a pointer, handling segments *)
begin
If Succ(Ofs(P^)) = 0 then
P := Ptr(Seg(P^)+$1000,0)
Else
P := Ptr(Seg(P^),Succ(Ofs(P^)));
end;
Function Leap (Year : Integer) : Boolean;
(* tell whether a year is a leap year *)
begin
Leap := (Year MOD 4 = 0) and ((Year MOD 100 <> 0) or (Year MOD 400 = 0));
end;
Function LowCase (C : Char) : Char;
(* opposite of UpCase; convert characters to lower case *)
begin
If ('A' <= c) and (c <= 'Z') then
LowCase := chr(ord(c) + 32)
Else
LowCase := c;
end;
Function LowerStr (S : String) : String;
(* convert all letters in a string to lower case *)
var
cnt : byte;
begin
for cnt := 1 to length(S) do
S[cnt] := LowCase(S[cnt]);
LowerStr := S;
end;
Function MonthLen (M : Byte) : Byte;
(* return length of a given month, !!! No leap years (Feb = 28)! *)
begin
case M of
1 : MonthLen := 31;
2 : MonthLen := 28;
3 : MonthLen := 31;
4 : MonthLen := 30;
5 : MonthLen := 31;
6 : MonthLen := 30;
7 : MonthLen := 31;
8 : MonthLen := 31;
9 : MonthLen := 30;
10 : MonthLen := 31;
11 : MonthLen := 30;
12 : MonthLen := 31;
else
MonthLen := 0;
end;
end;
Function MonthStr (M : Byte) : String;
(* return (English) name of month *)
begin
case M of
1 : MonthStr := 'January';
2 : MonthStr := 'February';
3 : MonthStr := 'March';
4 : MonthStr := 'April';
5 : MonthStr := 'May';
6 : MonthStr := 'June';
7 : MonthStr := 'July';
8 : MonthStr := 'August';
9 : MonthStr := 'September';
10 : MonthStr := 'October';
11 : MonthStr := 'November';
12 : MonthStr := 'December';
else
MonthStr := '';
end;
end;
Function NumStr (N : Longint; W : Byte) : String;
(* convert an integer to a string, right justified in W spaces *)
var
s : string;
begin
str (N:W,s);
NumStr := s;
end;
Function NumrStr (N : Real; W,D : Byte) : String;
(* convert a real in W spaces, D decimal places: see also ieee.pas *)
var
s : string;
begin
str (N:W:D,s);
NumrStr := s;
end;
Function OctB (B : Byte) : String;
(* convert a byte to octal *)
begin
OctB := char(byte('0') + ((B AND $C0) SHR 6)) +
char(byte('0') + ((B AND $38) SHR 3)) +
char(byte('0') + (B AND $07));
end;
Function OctW (W : Word) : String;
(* convert a word to octal *)
begin
OctW := char(byte('0') + ((W AND $8000) SHR 15)) +
char(byte('0') + ((W AND $7000) SHR 12)) +
char(byte('0') + ((W AND $0E00) SHR 9)) +
char(byte('0') + ((W AND $01C0) SHR 6)) +
char(byte('0') + ((W AND $0038) SHR 3)) +
char(byte('0') + (W AND $0007));
end;
Function OctL (L : Longint) : String;
(* convert a longint to octal *)
begin
OctL := char(byte('0') + ((L AND $C0000000) SHR 15)) +
char(byte('0') + ((L AND $38000000) SHR 12)) +
char(byte('0') + ((L AND $07000000) SHR 9)) +
char(byte('0') + ((L AND $00E00000) SHR 6)) +
char(byte('0') + ((L AND $001C0000) SHR 3)) +
char(byte('0') + ((L AND $00038000) SHR 15)) +
char(byte('0') + ((L AND $00007000) SHR 12)) +
char(byte('0') + ((L AND $00000E00) SHR 9)) +
char(byte('0') + ((L AND $000001C0) SHR 6)) +
char(byte('0') + ((L AND $00000038) SHR 3)) +
char(byte('0') + (L AND $00000007));
end;
Function PtrStr (P : Pointer) : String;
(* convert a pointer to a string, format XXXX:XXXX *)
begin
PtrStr := HexW(Seg(P^)) + ':' + HexW(Ofs(P^));
end;
Function Roman (N : Word) : String;
(* convert an integer (1..3999) to a Roman numeral, e.g. MCMXCII *)
Function RomanDigit (one, five, ten : char; n : byte) : string;
begin
case n of
0 : RomanDigit := '';
1..3 : RomanDigit := ConstStr(one, n);
4 : RomanDigit := one + five;
5..8 : RomanDigit := five + ConstStr(one, n - 5);
9 : RomanDigit := one + ten;
end;
end;
var
s : string;
begin
if N > 3999 then begin Roman := ''; exit; end;
s := RomanDigit('M',' ',' ',n DIV 1000);
n := n MOD 1000;
s := s + RomanDigit('C','D','M',n DIV 100);
n := n MOD 100;
s := s + RomanDigit('X','L','C',n DIV 10);
n := n MOD 10;
s := s + RomanDigit('I','V','X',n);
Roman := s;
end;
Function Rot13 (Ch : Char) : Char;
(* rotate the alphabet 13 places, nopqrstuvwxyzabcdefghijklm *)
begin
if not (ch in ['A'..'Z','a'..'z']) then
begin
Rot13 := ch;
exit;
end;
if ch in ['A'..'M','a'..'m'] then
Rot13 := chr(ord(ch)+13)
else
Rot13 := chr(ord(ch)-13);
end;
Function Rot13Str (S : String) : String;
(* encrypt or decrypt a string with rot13 *)
var
indx : byte;
begin
for indx := 1 to length(S) do
S[indx] := Rot13(S[indx]);
Rot13Str := S;
end;
Function SubiStr (Sub,S : String) : Boolean;
(* substring matching, case insensitive *)
begin
SubiStr := Pos(UpperStr(Sub),UpperStr(S)) <> 0;
end;
Function SubStr (Sub,S : String) : Boolean;
(* is one string a substring of another *)
begin
SubStr := Pos(Sub,S) <> 0;
end;
Function SwapChars (S : string; Original, Replace : Char) : String;
(* replace all occurances of one character with another in a string *)
var
i : byte;
begin
for i := 1 to length(s) do
if S[i] = Original then S[i] := Replace;
SwapChars := S;
end;
Function TailStr (S : String; N : Byte) : String;
(* return the last N characters of a string *)
begin
TailStr := Copy(S,Length(S) - N + 1,N);
end;
Function TrimHead (S : String) : String;
(* remove all whitespace from the beginning of a string *)
begin
While (S <> '') and (S[1] in whitespace) do
Delete (S,1,1);
TrimHead := S;
end;
Function TrimTail (S : String) : String;
(* remove all whitespace from the end of a string *)
begin
While (S <> '') and (S[Length(S)] in whitespace) do
Delete (S,Length(S),1);
TrimTail := S;
end;
Function UpperStr (S : String) : String;
(* convert a string to all upper case *)
var
indx : byte;
begin
for indx := 1 to length(S) do
S[indx] := UpCase(S[indx]);
UpperStr := S;
end;
Function ZeroStr (L : Longint; W : Byte) : String;
(* format an integer right justified in a field of zeroes *)
var
s : string;
cnt : byte;
begin
str (L:W,s);
for cnt := 1 to length(s) do
If s[cnt] = ' ' then s[cnt] := '0';
ZeroStr := s;
end;
Function ZerorStr (R : Real; W,D : Byte) : String;
(* format a real with D decimal places in W zeroes: see also ieee.pas *)
var
s : string;
cnt : byte;
begin
str (R:W:D,s);
for cnt := 1 to length(s) do
If s[cnt] = ' ' then s[cnt] := '0';
ZerorStr := s;
end;
End.