The following code is how to turn 10 credits to n-based numbers.
Unit basefunctions;
Interface
Uses sysutils;
Function dec_to_base (NBase, NDEC_VALUE, LEAD_ZEROS: Integer; Comit: String): String; // 10 Support -> N-BBFNCTION BASE_TO_DEC (NBASE: Integer; CBase_Value, Comit: String): Integer; // N > 10
IMPLEMentation
function Dec_To_Base (nBase, nDec_Value, Lead_Zeros: integer; cOmit: string): string; {Function: converts decimal integer to base n, max = Base36 Parameters: nBase = base number, ie Hex is base 16 nDec_Value = decimal to be converted. Lead_Zeros = min number of digits if leading zeros required cOmit = chars to omit from base (eg I, O, U, etc.) Returns: number in base n as string} var Base_PChar: PChar; Base_String: string; To_Del, Modulus, DivNo: integer; temp_string: string; i, nLen, Len_Base: integer; begin {initialise ..} Base_String: = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'; {max = Base36} To_Del: = 0; Modulus: = 0; DivNo: = nDec_Value; result : = '; IF (NBase> 36) THEN NBASE: = 36; {Max = Base36} Comctions; {build string to fit specified base} if not (comit =') THEN BEGIN {Iterate Thru 'Ommited Letters} Nlen: = Length (Comit); for i: = 1 to Nlen Do Begin To_Del: = POS (Comit [I], Base_String; {Find Position of Letter} IF (TO_DEL> 0) THEN Begin { Remove Letter from base string} Len_Base: = Length (Base_String); temp_string: = Copy (Base_String, 0, To_Del - 1); temp_string: = temp_string Copy (Base_String, To_Del 1, Len_Base - To_Del); Base_String: = temp_string; end; {if; {for i ..} end; {if not comit = '' '' '' '. ); {divide decimal by base & iterate until zero to convert it} while DivNo> 0 do begin Modulus: = DivNo mod nBase; {remainder is next digit} result: = Base_PChar [Modulus] result; DivNo: = DivNo div nBase ;
{While ..} {FIX ZERO VALUE} IF (longeth (result) = 0) Then Result: = '0'; {Add Required LEADING ZEROS} IF (Length (Result) function Base_To_Dec (nBase: integer; cBase_Value, cOmit: string): integer; {Function:. converts base n integer to decimal, max = Base36 Parameters: nBase = base number, ie Hex is base 16 cBase_Value = base n integer (as string ) to be converted comit = chars to omit from base (EG. I, O, U, ETC) Returns: Number in Decimal As String} var Base_pcha: pchar; base_string: string; to_del, unit_counter: integer; temp_string: string; i , nLen, Len_Base: integer; begin {initialise ..} Base_String: = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'; {max = Base36} To_Del: = 0; Unit_Counter: = nBase; result: = 0; if (nBase> 36) then nBase: = 36; {max = Base36} cOmit: = UpperCase (cOmit); cBase_Value: = UpperCase (cBase_Value); {ensure uppercase letters} {build string to fit specified base} if not (cOmit = '') then begin {iterate thru ' Ommited letters} nlen: = length (com); for i: = 1 to nlen do beg_del: = POS (Comit [i], base_string); {Find position of letter} if (to_del> 0) THEN BEGIN {Remove Letter From base string} Len_Base: = Length (Base_String); temp_string: = Copy (Base_String, 0, To_Del - 1); temp_string: = temp_string Copy (Base_String, To_Del 1, Len_Base - To_Del); Base_String: = temp_string; end; {if; {for i ..} end; {if not comit = '' '' '' '. ); {Iterate thru Digits of Base N value, Each Digit is a multiple of base n} nlen: = length (cbase_value); if (nlen = 0) Then Result: = 0 {FIX ZERO VALUE} else begin for i: = 1 to Nlen Do Begin IF (i = 1) THEN UNIT_COUNTER: = 1 {1st Digit = Units} else if (i> 1) Then Unit_counter: = unit_counter * nbase; {multiples of base} Result: = Result ((CBase_Value) ((CBASE_VALUE) ) 1) -i, 1), base_pchar) - 1) * Unit_counter); end; {for i: = 1 ..} end; {else begin ..} end; {function base_to_dec} end. {Unit basefunctions} // ****************************************** INTTOHEX Supplement Delphi provides INTTOHEX, but there is no HEXTOINT with it. There are also functions similar to INTTOBIN and BINTOINT in the SYSUTILS unit. I met this problem when I designated serial numbers in the previous time. I actually called me today's "third party" implementation, I dare not exclusive, paste it here. {================================================} {Convert a hexstring value to an Int64} {NOTE: Last Char Can Be 'HEX} {EG.' 00123H 'OR' 00123H '} {0 Will Be Returned if INVALID HexString} {================= ========================} Function HEXTOINT (HEXSTR: STRING): INT64; VAR RETVAR: INT64; I: Byte; Begin HexStr: = Uppercase (HEXSTR); if HexStr [Length (HexStr)] = 'H' Then Delete (HexStr, Length (HEXSTR), 1); RETVAR: = 0; For i: = 1 to length (HEXSTR) Do Begin Retvar: = RETVAR SHL 4; if HexStr [I] IN ['0' .. '9'] Then Retvar: = RETVAR (Byte (HexStr [i]) - 48) Else if HexStr [I] in ['a' .. 'f']. Retvar: = RETVAR (Byte (HexSTR [I]) - 55) Else Begin Retvar: = 0; Break; End; End; Result: = RETVAR; END; {==============================================} {Convert An Int64 Value to a binary string} {Numbits CAN BE 64, 32, 16, 8 to indicate the} {return value is to be int64, dword, word} {or byte respectively (default = 64)} {Numbits Normally Co. Required for} {NEGATIVE INPUT VALUES} {========================================== =====} Function INTTOBIN (Numbits: Word = 64): String; Var Retvar: String; I, Ilen: Byte; Begin Retvar: = '; Case Numbits of 32: ivalue: = DWORD (IVALUE); 16: IValue: = Word (iValue); 8: ivalue: = byte (iValue); While Ivalue <> 0 do begin Retvar: = char (48 (iValue and 1)) retvar; ivalue: = ivalue shr 1; If RETVAR = '' TEN RETVAR: = '0'; Result: = RETVAR; END; {==============================================} {Convert A bit binary string to an {Note: Last Char CAN be 'b' for binary} {eg. '001011b' or '001011b'} {0 will be returned if invalid binarystring} {======= =================================================} function bintoint (binstr: string): int64; VAR i: byte; return binstr: = Uppercase (binstr); if Binstr [length (binstr)] = 'bin delete (Binstr, Length (Binstr), 1); RETVAR: = 0; for i : = 1 to Length (Binstr) Do Begin if Not (Binstr [I] IN ['0', '1']) THEN Begin Retvar: = 0; Break; End; Retvar: = (Retvar SHL 1) (Byte (Binstr [I]) and 1); Result: = RETVAR; END; // ************************************************* Match string of wildcard {This function gets two strings and compares. The first string can be any string, but cannot contain the specified wildcard (* or?). The second string can be any form you want. For example: MatchStrings ('David Stidolph', '* ST *') returns true. } Function matchstrings (Source, Pattern: String): boolean; var psource: array [0..255] of char; ppattern: array [0..255] of char; Function matchpattern (Element, Pattern: Pchar): Boolean Function ispatternwild (Pattern: Pchar): Boolean; Var T: integer; begin result: = strscan (pattern, '*') <> nil; if not resulting thumb: = strscan (pattern, '?') <> nil; END; Begin if 0 = strcomp (pattern, '*') Then Result: = true else if (element ^ = chr (0)) and (pattern ^ <> chr (0)) THEN Result: = false else if Element ^ = chr (0) THEN RESE: = True else begin case pattern ^ of '*': if matchpattern (element, @ pattern [1]) Then Result: = true else result: = matchpattern (@Element [1], pattern); ' ? ': Result: = matchpattern (@Element [1], @ Pattern [1]); else if element ^ = pattern ^ Then Result: = matchpattern (@Element [1], @ pattern [1]) Else Result: = False; end; end; end; begin strpcopy; strpcopy; result: = matchpattern (psource, ppattern); // ********************************************* The function of the binary string {========= ============================================================================================================================================================================================================= ====} {Binhextools} {========================================== =======================} {Version: 1.0} {compiler: borland delphi 3.0} {Author: Hans Luyten} {Date: 11 Juni 1998} {= ============================================================================================================================================================================================================= ============} {UTILITIES for Working with binary strings} {============================ ===================================} {FUNCTION: RESULTSTRING = HexToBin (hEXSTRING)} {PURPOSE: Convert A hex number (string) to a binary number} {(String) {=========================== =============================================} {function: Resultinteger = HEXCHARTOINT (HEXCHAR)} {purpose: Convert a hex character (0..9 & a..f or a..f) to} {an integer} {======================================================================================================================================== =================================================} {function: resultString = hexchartobin (Hexchar) } {Purpose: Convert a hex character (0..9 & a..f or arsf) to a} {binary string} {================== =====================================================} {Function: Resultinteger = POW (BASE, POWER)} {purpose: Simple Power Routine Resulting in An Integer} {(16bit)} {========================= ===============================================} {function: Resultinteger = binstrt (binstring)} { Purpose: this function converts a 16 bit binary string to} {an integer} {=============== ========================================================} { Function: Resultstring = DecodesMs7bit (PDUSTRING)} {purpose: this function decodes AN 7-bit SMS (GSM 03.38) to} {ascii} {==================== ===================================================} {function: resultString = ReverseStr (SourceString)} {purpose: this function reverse code} {==================================== ==================================} Unit binhextools; Interface function HexToBin (HexNr: string): string; function HexCharToInt (HexToken: char): Integer; function HexCharToBin (HexToken: char): string; function pow (base, power: integer): integer; function BinStrToInt (BinStr: string): Integer; Function DecodeSMS7bit (PDU: String): String; Function RevertR (Sourcestr: String): String; IMPLEMentation Uses sysutils, dialogs; Function HEXCHARTOINT (HEXTOKEN: Char): Integer; Begin {if Hextoken> # 97 THEN HEXTOKEN: = CHR (ORD (HEXTOKEN) -32); {Use Lowercase Aswell} Result: = 0; IF (HEXTOKEN> # 47) And (HexToken <# 58) THEN {Chars 0 .... 9} Result: = ORD (HEXTOKEN) -48 Else IF (HEXTOKEN> # 64) And (HexToken <# 71) THEN { Chars a .... f} result: = ORD (HEXTOKEN) -65 10; End; Function HexChartobin (HexToken: Char): String; Var Divleft: Integer; Begin Divleft: = HEXCHARTOINT (HexToKen); {FIRST HEX- > Bin} result: = '; {use reverse dividing} Repeat {trick; Divide By 2} IF = odd (Divleft) THEN {Result = ODD ?1n bit = 1} Result: =' 1 ' Result {Result = Even "kilse result: = '0' result; Divleft: = DivleFT Div 2; {Keep Dividing Till 0 Left and length = 4} Until (Divleft = 0) AND (length (result) = 4); {1 token = nibble = 4 bits} end; Function HEXTOBIN (HEXNR: STRING): String; {Only stringsize is limited of binnr} var counter: integer; begin result: = '; For counter: = 1 to length (HEXNR) Do Result: = Result HEXCHARTOBIN (HEXNR [counter]); Function Pow (Base, Power: Integer): Integer; Var counter: integer; begin result: = 1; For counter: = 1 to power do result: = result * base; Function BinsTRTOINT (Binstr: String): Integer; VAR Counter: Integer; Begin If Length (Binstr)> 16 Then Raise Erangeerror.create (# 13 binstr # 13 'is Not within the Valid Range of A 16 bit binary.' # 13); Result: = 0; For counter: = 1 to Length (binstr) do if binstr [counter] = '1' Ten Result: = Result Pow (2, Length (binstr) -counter; function DecodeSMS7Bit (PDU: string): string; var OctetStr: string; OctetBin: string; Charbin: string; PrevOctet: string; Counter: integer; Counter2: integer; begin PrevOctet: = ''; Result: = ''; for Counter = 1 To Length (PDU) Do Begin if Length (Prevoct)> = 7 THEN {IF 7 Bit overflow on Previous} Begin IF BinsTrt (Prevoct) <> 0 Then Result: = Result CHR (BinsTRTOINT (Prevoct)) Else Result: = Result ''; PrevocTet: = ''; end; IF = COPY (PDU, Counter, 2); OcTetbin: = HEXTOBIN (OCTETSTSTER); Charbin: = '; for counter2: = 1 to length (prevoct) Do Charbin: = charbin prevoctet [counter2]; For counter2: = 1 to 7-length (prevoct) Do Charbin: = OCTETBIN [8-counter2 1] Charbin IF BinsTrtOINT (Charbin) <> 0 THEN Result: = Result Chr (BinsTRTOIN) ELSE RESULT: = Result '; PrevocTet: = COPY (Octetbin, 1, Length (Prevoct) 1); end; end; Function ReverseStr (SourceStr: String): String; Var counter: integer; begin result: = '; For counter: = 1 to Length (SourceStr) Do Result: = SourceStr [counter] result; End.
