Contributor: ESB CONSULTANCY unit ESBRtns; { Miscellaneous Routines to enhance your 32-bit Delphi Programming including: - 16-bit Bit Lists - Block Operations - various String Routines and Conversions (c) 1997 ESB Consultancy v1.00 First Public Release on 15 Aug 1997 to celebrate our WebSite's First Birthday. These routines are used by ESB Consultancy within the development of their Customised Application. ESB Consultancy retains full copyright. ESB Consultancy grants users of this code royalty free rights to do with this code as they wish. We does ask that if this code helps you in you development that you send as an email mailto:esb@gold.net.au or even a local postcard. It would also be nice if you gave us a mention in your About Box or Help File. ESB Consultancy Home Page: http://www.gold.net.au/~esb Mail Address: PO Box 2259, Boulder, WA 6432 AUSTRALIA } interface const MaxByte: Byte = 255; MaxShortInt: ShortInt = 127; MaxWord: Word = 65535; MaxReal: Real = 1.7e38; MaxSingle: Single = 3.4e38; MaxDouble: Double = 1.7e308; MaxExtended: Extended = 1.1e4932; MaxComp: Comp = 9.2e18; MinByte: Byte = 0; MinShortInt: ShortInt = -128; MinInt: Integer = -32768; MinWord: Word = 0; MinLongInt: LongInt = $80000000; MinReal: Real = 2.9e-39; MinSingle: Single = 1.5e-45; MinDouble: Double = 5.0e-324; MinExtended: Extended = 3.4e-4932; const NumPadCh: Char = ' '; // Character to use for Left Hand Padding of Numerics // NumPosSign: Boolean = False; //Signals whether a '+' sign should be shown with positives type TBitList = Word; // Used for a Bit List of 16 bits from 15 -> 0 type String16 = string [16]; {*** Bit Manipulation ***} procedure ClearAllBits (var Body: TBitList); { Sets all Bits to 0 } procedure SetAllBits (var Body: TBitList); { Sets all Bits to 1 } procedure FlipAllBits (var Body: TBitList); { Flips all Bits, i.e 1 -> 0 and 0 -> 1 } procedure ClearBit (var Body: TBitList; const I: Byte); { Sets specified Bit to 0 } procedure SetBit (var Body: TBitList; const I: Byte); { Sets specified Bit to 1 } procedure FlipBit (var Body: TBitList; const I: Byte); { Flips specified Bit, i.e. 0 -> 1 and 1 -> 0 } function BitIsSet (const Body: TBitList; const I: Byte): Boolean; { Returns True if Specified Bit is 1 } procedure ReverseBits (var Body: TBitList); register; { Reverses the Bit List, i.e. Bit 15 <-> Bit 0, Bit 14 <-> Bit1, etc. } function Bits2Str (const Body: TBitList): String16; { Converts a Bit list to a string of '1' and '0'. } function Str2Bits (const S: String16): TBitList; register; { Converts a string of '1' and '0' into a BitList. } function BitsSet (const Body: TBitList): Byte; register; { Returns a number from 0 -> 16 indicating the number of Bits Set } function Booleans2BitList (const B: array of Boolean): TBitList; { Converts an Array of Boolean into a BitList } {*** Block Operations ***} procedure ESBMoveOfs (const Source; const Ofs1: Integer; var Dest; const Ofs2: Integer; const Size: Integer); { Moves Size bytes from Source starting at Ofs1 to destination starting at Ofs 2 using fast dword moves. BASM } procedure ESBClear (var Dest; const Size: Integer); { Fills given structure with specified number of 0 values, effectively clearing it. } procedure ESBSet (var Dest; const Size: Integer); { Fills given structure with specified number of $FF values, effectively setting it. } {*** String to Integer Types ***} function Str2LInt (const S: String): LongInt; { Converts a String into a LongInt } function Str2Byte (const S: String): Byte; { Converts a String into a Byte } function Str2SInt (const S: String): ShortInt; { Converts a String into a ShortInt } function Str2Int (const S: String): Integer; { Converts a String into an Integer } function Str2Word (const S: String): Word; { Converts a String into a Word } {*** Integer Types to Strings ***} function LInt2Str (const L: LongInt; const Len: Byte): String; { Converts a LongInt into a String of length N with NumPadCh Padding to the Left } function Byte2Str (const L: LongInt; const Len: Byte): String; { Converts a LongInt into a String of length N with NumPadCh Padding to the Left } function LInt2ZStr (const L: LongInt; const Len: Byte): String; { Converts a LongInt into a String of length N with NumPadCh Padding to the Left } function LInt2ZBStr (const L: LongInt; const Len: Byte): String; { Converts a LongInt into a String of length N with NumPadCh Padding to the Left, with blanks returned if Value is 0 } function LInt2CStr (const L : LongInt; const Len : Byte): string; { Convert a LongInt into a Comma'ed String of length Len, with NumPadCh Padding to the Left } function LInt2EStr (const L: LongInt): String; { Convert a LongInt into an exact String, No Padding } function LInt2ZBEStr (const L: LongInt): String; { Convert a LongInt into an exact String, No Padding, with null returned if Value is 0 } function LInt2CEStr (const L : LongInt): string; { Convert a LongInt into a Comma'ed String without Padding } {*** Extended Reals to Strings ***} function Ext2EStr (const E: Extended; const Decimals: Byte): String; { Converts an Extended Real into an exact String, No padding, with given number of Decimal Places } function Ext2EStr2 (const E: Extended; const Decimals: Byte): String; { Converts an Extended Real into an exact String, No padding, with at most given number of Decimal Places } function Ext2CEStr (const E: Extended; const Decimals: Byte): String; { Converts an Extended Real into an exact String, No padding, with given number of Decimal Places, with Commas separating thousands } function Double2EStr (const D: Double; const Decimals: Byte): String; { Converts a Double Real into an exact String, No padding, with given number of Decimal Places } function Single2EStr (const S: Single; const Decimals: Byte): String; { Converts a Single Real into an exact String, No padding, with given number of Decimal Places } function Comp2EStr (const C: Comp): String; { Converts a Comp (Integral) Real into an exact String, No padding } function Comp2CStr (const C : Comp; const Len : Byte): string; { Converts a Comp (Integral) Real into a Comma'ed String of specified Length, Len, NumPadCh used for Left padding } function Comp2CEStr (const C : Comp): string; { Converts a Comp (Integral) Real into a Comma'ed String without Padding } function Ext2Str (const E: Extended; const Len, Decimals: Byte): String; { Converts an Extended Real into a String of specified Length, using NumPadCh for Left Padding, and with Specified number of Decimals } function Double2Str (const D: Double; const Len, Decimals: Byte): String; { Converts a Double Real into a String of specified Length, using NumPadCh for Left Padding, and with Specified number of Decimals } function Single2Str (const S: Single; const Len, Decimals: Byte): String; { Converts an Single Real into a String of specified Length, using NumPadCh for Left Padding, and with Specified number of Decimals } function Comp2Str (const C: Comp; const Len : Byte): String; { Converts a Comp (Integral) Real into a String of specified Length, using NumPadCh for Left Padding } {*** Strings to Extended Reals ***} function Str2Ext (const S: String): Extended; { Converts a String into an Extended Real } {*** Extra String Operations ***} function LeftStr (const S : string; const N : Integer): string; { Returns the substring consisting of the first N characters of S. If N > Length (S) then the substring = S. } function RightStr (const S : string; const N : Integer): string; { Returns the substring consisting of the last N characters of S. If N > Length (S) then the substring = S. } function LeftTillStr (const S : string; const Ch : Char): string; { Returns the substring consisting of the characters from S up to but not including the specified one. If the specified character is not found then a null string is returned. } function RightAfterStr (const S : String; const N : Integer): String; { Returns the sub-string to the right AFTER the first N Characters. if N >= Length (S) then a Null string is returned. } function RightAfterChStr (const S : String; const Ch : Char): String; { Returns the sub-string to the right AFTER the first ocurrence of specifiec character. If Ch not found then a Null String is returned. } function StripTChStr (const S : string; const Ch : Char): string; { Returns the String with all specified trailing characters removed. } function StripLChStr (const S : string; const Ch : Char): string; { Returns the String with all specified leading characters removed. } function StripChStr (const S : string; const Ch : Char): string; { Returns the String with all specified leading and trailing characters removed. } function ReplaceChStr (const S : string; const OldCh, NewCh : Char): string; { Returns the String with all occurrences of OldCh character replaced with NewCh character. } function FillStr (const Ch : Char; const N : Integer): string; { Returns a string composed of N occurrences of Ch. } function BlankStr (const N : Integer): string; { Returns a string composed of N blank spaces (i.e. #32) } function DashStr (const N : Integer): String; { Returns a string composed of N occurrences of '-'. } function DDashStr (const N : Integer): string; { Returns a string composed of N occurrences of '='. } function LineStr (const N : Integer): string; { Returns a string composed of N occurrences of 'Ä' (196). } function DLineStr (const N : Integer): string; { Returns a string composed of N occurrences of 'Í' (205). } function StarStr (const N : Integer): string; { Returns a string composed of N occurrences of '*'. } function HashStr (const N : Integer): string; { Returns a string composed of N occurrences of '#'. } function PadRightStr (const S : string; const Len : Integer): string; { Returns a string with blank spaces added to the end of the string until the string is of the given length. If Length (S) >= Len then NO padding occurs, and S is returned. } function PadLeftStr (const S : string; const Len : Integer): string; { Returns a string with blank spaces added to the beginning of the string until the string is of the given length. If Length (S) >= Len then NO padding occurs, and S is returned. } function CentreStr (const S : String; const Len : Integer): String; { Returns a string with blank spaces added to the beginning and end of the string to in effect centre the string within the given length. If Length (S) >= Len then NO padding occurs, and S is returned. } function PadChRightStr (const S : string; const Ch : Char; const Len : Integer): string; { Returns a string with specified characters added to the end of the string until the string is of the given length. If Length (S) >= Len then NO padding occurs, and S is returned. } function PadChLeftStr (const S : string; const Ch : Char; const Len : Integer): string; { Returns a string with specified characters added to the beginning of the string until the string is of the given length. If Length (S) >= Len then NO padding occurs, and S is returned. } function CentreChStr (const S : String; const Ch : Char; const Len : Integer): String; { Returns a string with specified characters added to the beginning and end of the string to in effect centre the string within the given length. If Length (S) >= Len then NO padding occurs, and S is returned. } function LeftAlignStr (const S : string; const N : Integer): string; function RightAlignStr (const S : string; const N : Integer): string; function Boolean2TF (const B : Boolean): Char; { Converts a Boolean Value into the corresponding Character: True -> 'T' False -> 'F' } function Boolean2YN (const B : Boolean): Char; { Converts a Boolean Value into the corresponding Character: True -> 'Y' False -> 'N' } function Boolean2Char (const B : Boolean; TrueChar, FalseChar: Char): Char; { Converts a Boolean Value into the corresponding Character: True -> TrueChar False -> FalseChar } function TF2Boolean (const Ch : Char): Boolean; { Converts a Character Value into its corresponding Boolean value: 'T', 't' -> True Otherwise -> False } function YN2Boolean (const Ch : Char): Boolean; { Converts a Character Value into its corresponding Boolean value: 'Y', 'y' -> True Otherwise -> False } implementation uses SysUtils; {**** Bit Manipulation ****} procedure ClearAllBits (var Body: TBitList); begin Body:= $0000 end; procedure SetAllBits (var Body: TBitList); begin Body:= $FFFF end; procedure FlipAllBits (var Body: TBitList); begin Body:= Body xor $FFFF end; procedure ClearBit (var Body: TBitList; const I: Byte); begin Body:= Body and (not ($0001 shl I)) end; procedure SetBit (var Body: TBitList; const I: Byte); begin Body:= Body or ($0001 shl I) end; procedure FlipBit (var Body: TBitList; const I: Byte); begin Body:= Body xor ($0001 shl I) end; function BitIsSet (const Body: TBitList; const I: Byte): Boolean; begin Result := (Body and ($0001 shl I)) <> 0 end; function Bits2Str (const Body: TBitList): String16; var I: Integer; begin SetLength (Result, 16); for I := 0 to 15 do if BitIsSet (Body, I) then Result [I + 1] := '1' else Result [I + 1] := '0'; end; procedure ReverseBits (var Body: TBitList); assembler; asm push esi push ebx mov esi, eax mov bx, Word Ptr [esi] sub ax, ax // clear ax for out going bit list mov cx, 16 // 16 iterations needed for a word sub dx, dx // clear dx for additions @1: shl ax, 1 // move all of ax right shr bx, 1 // move lsb into CF adc ax, dx // add in the carry bit loop @1 mov Word Ptr [esi], ax pop ebx pop esi end; function Str2Bits (const S: String16): TBitList; assembler; asm push esi push ebx mov esi, eax lodsb // Read Length sub ah, ah mov cx, ax // & store in CX sub bx, bx // clear BX for bit list construction mov dl, '0' // for comparisons @1: lodsb shl bx, 1 // mov bx along cmp al, dl je @2 add bx, 1 // otherwise add 1 @2: loop @1; mov ax, bx // result must be in ax pop ebx pop esi end; function BitsSet (const Body: TBitList): Byte; assembler; asm mov dx, ax // Place BitList into BX xor ax, ax // Clear AX mov cx, 16 // Move 16 into CX @2: shl dx, 1 // Shift Left jnc @1 // if no carry then no increment inc ax @1: loop @2 end; function Booleans2BitList (const B: array of Boolean): TBitList; var I: Integer; begin Result := 0; for I := 0 to High (B) do if B [I] then SetBit (Result, 0); end; procedure ESBMoveOfs (const Source; const Ofs1: Integer; var Dest; const Ofs2: Integer; const Size: Integer); asm push esi push edi mov esi, Source add esi, Ofs1 mov edi, Dest add edi, Ofs2 mov eax, Size mov ecx, eax cmp edi,esi jg @@DOWN je @@EXIT sar ecx,2 //copy count DIV 4 dwords js @@EXIT rep movsd mov ecx,eax and ecx,03h rep movsb //copy count MOD 4 bytes jmp @@EXIT @@DOWN: lea esi,[esi+ecx-4] // point ESI to last dword of source lea edi,[edi+ecx-4] // point EDI to last dword of dest sar ecx,2 // copy count DIV 4 dwords js @@EXIT std rep movsd mov ecx,eax and ecx,03h // Copy count MOD 4 bytes add esi,4-1 // point to last byte of rest add edi,4-1 rep movsb cld @@EXIT: pop edi pop esi end; procedure ESBClear (var Dest; const Size: Integer); begin FillChar (Dest, Size, $00); end; procedure ESBSet (var Dest; const Size: Integer); begin FillChar (Dest, Size, $FF); end; function Str2LInt (const S: String): LongInt; begin try Result := StrToInt (S); except Result := 0; end; end; function Str2Byte (const S: String): Byte; var L: LongInt; begin L := Str2LInt (S); if L > MaxByte then Result := MaxByte else if L < MinByte then Result := MinByte else Result := L; end; function Str2SInt (const S: String): ShortInt; var L: LongInt; begin L := Str2LInt (S); if L > MaxShortInt then Result := MaxShortInt else if L < MinShortInt then Result := MinShortInt else Result := L; end; function Str2Int (const S: String): Integer; var L: LongInt; begin L := Str2LInt (S); if L > MaxInt then Result := MaxInt else if L < MinInt then Result := MinInt else Result := L; end; function Str2Word (const S: String): Word; var L: LongInt; begin L := Str2LInt (S); if L > MaxWord then Result := MaxWord else if L < MinWord then Result := MinWord else Result := L; end; function LInt2EStr (const L: LongInt): String; begin try Result := IntToStr (L); except Result := ''; end; end; function LInt2ZBEStr (const L: LongInt): String; begin if L = 0 then Result := '' else try Result := IntToStr (L); except Result := ''; end; end; function Ext2EStr (const E: Extended; const Decimals: Byte): String; begin try Result := FloatToStrF (E, ffFixed, 18, Decimals) except Result := ''; end; end; function Ext2EStr2 (const E: Extended; const Decimals: Byte): String; begin Result := Ext2EStr (E, Decimals); Result := StripTChStr (Result, '0'); if Length (Result) > 0 then if Result [Length (Result)] = DecimalSeparator then Result := LeftStr (Result, Length (Result) - 1); end; function Ext2CEStr (const E: Extended; const Decimals: Byte): String; begin try Result := FloatToStrF (E, ffNumber, 18, Decimals) except Result := ''; end; end; function Double2EStr (const D: Double; const Decimals: Byte): String; begin try Result := FloatToStrF (D, ffFixed, 15, Decimals) except Result := ''; end; end; function Single2EStr (const S: Single; const Decimals: Byte): String; begin try Result := FloatToStrF (S, ffFixed, 7, Decimals) except Result := ''; end; end; function Comp2EStr (const C: Comp): String; begin try Result := FloatToStrF (C, ffFixed, 18, 0) except Result := ''; end; end; function Str2Ext (const S: String): Extended; begin try Result := StrToFloat (S); except Result := 0; end; end; function LInt2Str (const L: LongInt; const Len: Byte): String; begin try Result := IntToStr (L); except Result := ''; end; Result := PadChLeftStr (LeftStr (Result, Len), NumPadCh, Len); end; function Byte2Str (const L: LongInt; const Len: Byte): String; begin try Result := IntToStr (L); except Result := ''; end; Result := PadChLeftStr (LeftStr (Result, Len), NumPadCh, Len); end; function LInt2ZBStr (const L: LongInt; const Len: Byte): String; begin Result := LInt2ZBEStr (L); Result := PadChLeftStr (LeftStr (Result, Len), NumPadCh, Len); end; function LInt2ZStr (const L: LongInt; const Len: Byte): String; begin Result := LInt2EStr (L); Result := PadChLeftStr (LeftStr (Result, Len), '0', Len); end; function LInt2CStr (const L : LongInt; const Len : Byte): string; begin Result := LInt2CEStr (L); Result := PadChLeftStr (LeftStr (Result, Len), NumPadCh, Len); end; function LInt2CEStr (const L : LongInt): string; var LS, L2, I : Integer; Temp : string; begin Result := LInt2EStr (L); LS := Length (Result); L2 := (LS - 1) div 3; Temp := ''; for I := 1 to L2 do Temp := ThousandSeparator + Copy (Result, LS - 3 * I + 1, 3) + Temp; Result := Copy (Result, 1, (LS - 1) mod 3 + 1) + Temp; end; function Comp2CStr (const C : Comp; const Len : Byte): string; begin Result := Comp2CEStr (C); Result := PadChLeftStr (LeftStr (Result, Len), NumPadCh, Len); end; function Comp2CEStr (const C : Comp): string; var LS, L, I : Integer; Temp : string; begin Result := Comp2EStr (C); LS := Length (Result); L := (LS - 1) div 3; Temp := ''; for I := 1 to L do Temp := ThousandSeparator + Copy (Result, LS - 3 * I + 1, 3) + Temp; Result := Copy (Result, 1, (LS - 1) mod 3 + 1) + Temp; end; function Ext2Str (const E: Extended; const Len, Decimals: Byte): String; begin try Result := FloatToStrF (E, ffFixed, 18, Decimals) except Result := ''; end; Result := PadChLeftStr (LeftStr (Result, Len), NumPadCh, Len); end; function Double2Str (const D: Double; const Len, Decimals: Byte): String; begin try Result := FloatToStrF (D, ffFixed, 15, Decimals) except Result := ''; end; Result := PadChLeftStr (LeftStr (Result, Len), NumPadCh, Len); end; function Single2Str (const S: Single; const Len, Decimals: Byte): String; begin try Result := FloatToStrF (S, ffFixed, 7, Decimals) except Result := ''; end; Result := PadChLeftStr (LeftStr (Result, Len), NumPadCh, Len); end; function Comp2Str (const C: Comp; const Len: Byte): String; begin try Result := FloatToStrF (C, ffFixed, 18, 0) except Result := ''; end; Result := PadChLeftStr (LeftStr (Result, Len), NumPadCh, Len); end; function LeftStr (const S : string; const N : Integer): string; begin Result := Copy (S, 1, N); end; function LeftAlignStr (const S : string; const N : Integer): string; begin Result := PadRightStr (Copy (S, 1, N), N); end; function RightAlignStr (const S : string; const N : Integer): string; begin Result := PadLeftStr (Copy (S, 1, N), N); end; function RightStr (const S : string; const N : Integer): string; var M: Integer; begin M := Length (S) - N + 1; if M < 1 then M := 1; Result := Copy (S, M, N); end; function LeftTillStr (const S : string; const Ch : Char): string; var M: Integer; begin M := Pos (Ch, S); if M < 2 then Result := '' else Result := Copy (S, 1, M - 1); end; function RightAfterStr (const S : String; const N : Integer): String; begin Result := Copy (S, N + 1, Length (S) - N ); end; function RightAfterChStr (const S : String; const Ch : Char): String; var M: Integer; begin M := Pos (Ch, S); if M = 0 then Result := '' else Result := Copy (S, M + 1, Length (S) - M); end; function StripChStr (const S : string; const Ch: Char): string; begin Result := StripTChStr (StripLChStr (S, Ch), Ch); end; function StripTChStr (const S : string; const Ch: Char): string; var Len: Integer; begin Len := Length (S); while (Len > 0) and (S [Len] = Ch) do Dec (Len); if Len = 0 then Result := '' else Result := Copy (S, 1, Len); end; function StripLChStr (const S : string; const Ch: Char): string; var I, Len: Integer; begin Len := Length (S); I := 1; while (I <= Len) and (S [I] = Ch) do Inc (I); if (I > Len) then Result := '' else Result := Copy (S, I, Len - I + 1); end; function ReplaceChStr (const S : string; const OldCh, NewCh : Char): string; var I: Integer; begin Result := S; if OldCh = NewCh then Exit; for I := 1 to Length (S) do if S [I] = OldCh then Result [I] := NewCh; end; function FillStr (const Ch : Char; const N : Integer): string; begin SetLength (Result, N); FillChar (Result [1], N, Ch); end; function BlankStr (const N : Integer): string; begin Result := FillStr (' ', N); end; function DashStr (const N : Integer): string; begin Result := FillStr ('-', N); end; function DDashStr (const N : Integer): string; begin Result := FillStr ('=', N); end; function LineStr (const N : Integer): string; begin Result := FillStr (#196, N); end; function DLineStr (const N : Integer): string; begin Result := FillStr (#205, N); end; function StarStr (const N : Integer): string; begin Result := FillStr ('*', N); end; function HashStr (const N : Integer): string; begin Result := FillStr ('#', N); end; function PadRightStr (const S : string; const Len : Integer): string; var N: Integer; begin N := Length (S); if N < Len then Result := S + BlankStr (Len - N) else Result := S; end; function PadLeftStr (const S : string; const Len : Integer): string; var N: Integer; begin N := Length (S); if N < Len then Result := BlankStr (Len - N) + S else Result := S; end; function CentreStr (const S : String; const Len : Integer): String; var N, M: Integer; begin N := Length (S); if N < Len then begin M := Len - N; if Odd (M) then Result := BlankStr (M div 2) + S + BlankStr (M div 2 + 1) else Result := BlankStr (M div 2) + S + BlankStr (M div 2); end else Result := S; end; function PadChRightStr (const S : string; const Ch : Char; const Len : Integer): string; var N: Integer; begin N := Length (S); if N < Len then Result := S + FillStr (Ch, Len - N) else Result := S; end; function PadChLeftStr (const S : string; const Ch : Char; const Len : Integer): string; var N: Integer; begin N := Length (S); if N < Len then Result := FillStr (Ch, Len - N) + S else Result := S; end; function CentreChStr (const S : String; const Ch : Char; const Len : Integer): String; var N, M: Integer; begin N := Length (S); if N < Len then begin M := Len - N; if Odd (M) then Result := FillStr (Ch, M div 2) + S + FillStr (Ch, M div 2 + 1) else Result := FillStr (Ch, M div 2) + S + FillStr (Ch, M div 2); end else Result := S; end; function Boolean2TF (const B : Boolean): Char; begin if B then Result := 'T' else Result := 'F'; end; function Boolean2YN (const B : Boolean): Char; begin if B then Result := 'Y' else Result := 'N'; end; function Boolean2Char (const B : Boolean; TrueChar, FalseChar: Char): Char; begin if B then Result := TrueChar else Result := FalseChar; end; function TF2Boolean (const Ch : Char): Boolean; begin Result := Ch in ['T', 't']; end; function YN2Boolean (const Ch : Char): Boolean; assembler; begin Result := Ch in ['Y', 'y']; end; end.