Конвертация из одной СИ в другую , Математика, алгоритмы > Арифметика, СИ. большие чи

В FAQ имеется пример для перевода с ограничением, что СИ не может быть более чем 36-ти значная. Ниже код, которому все-равно. Главный недостаток - жутко тормозной . Так же имеются функции суммирования и умножения в произвольной СИ.
P.S. Вроде проверил, глюков не нашел; если что пните.
P.P.S. Так же есть код и на VB

const
  CharSetIn  = '0123456789ABCDEF';
  CharSetOut = '01';
 
// Пример конвертирует число FFA из 16-ричной СИ в двоичную
Convert('FFA',CharSetIn,CharSetOut);
 
 
// CharSet = "01234567" - 8-ми ричная система исчисления
// MyChr(0) = "0", MyChr(7) = "7", MyChr(8) = "0"
// Всегда: A = Ai*Base^i + ... + A1*Base + A0, где Ai in CharSet
// Base = MyChr(Len(CharSet)-1) + 1 ~ 10 (соотв. СИ)
 
// РЕАЛИЗОВАННЫЕ ФУНКЦИИ
// Convert - преобразование числа из одной СИ в другую
// f0 - преобразование одного символа исходной СИ в другую (впомогат.)
// MySum - сумма двух чисел в некоторой СИ
// MyMult - произведение двух чисел в некоторой СИ
// MyChr - по номеру возвращает символ
// MyOrd - по символу возвращает номер в CharSet
 
//**MyOrd**************************************************************
function MyOrd(A: Char; CharSet: String): Integer;
var i: Integer;
begin
Result:=0;
for i:=1 to Length(CharSet) do
  begin
  if CharSet[i]=A then
     begin
     Result:=i-1;
     exit;
     end
  end;
end;
 
//**MyChr**************************************************************
function MyChr(Num: Integer; CharSet: String): Char;
begin
Result := CharSet[Num mod Length(CharSet) + 1];
end;
 
//**MySum************************************************************
function MySum (A, B, CharSet: String): String;
var
  i, Pos, Add, L, L_CharSet: Integer;
  AA,BB, O, Res: String;
begin
if Length(A)>=Length(B)
   then begin AA:=A; BB:=B; end
   else begin AA:=B; BB:=A; end;
 
L:= Length(AA);
L_CharSet := Length(CharSet);
O:=MyChr(0, CharSet);
 
for i := Length(BB) to L-1 do
BB := O + BB;
 
Add:=0;
for i:= L downto  1 do
  begin
  Pos := MyOrd(AA[i], CharSet)+MyOrd(BB[i],CharSet) + Add;
  Add := 0;
  While Pos >= L_CharSet do
     begin
     Pos := Pos mod L_CharSet;
     Add := Add+1;
     end;
 
  Res := MyChr(Pos, CharSet) + Res;
  end;
 
If Add<>0
   then Result := MyChr(Add, CharSet) + Res
   else Result:=res;
end;
 
//**MyMulti************************************************************
function MyMulti (A, B, CharSet: String): String;
var
  i, e, Res, AA, BB: String;
  j, k: Integer;
begin
AA:='';BB:='';
k:=1; while A[k]=MyChr(0,CharSet) do k:=k+1; for j:=k to Length(A) do AA:=AA+A[j];
k:=1; while B[k]=MyChr(0,CharSet) do k:=k+1; for j:=k to Length(B) do BB:=BB+B[j];
 
i :=''; Res := '';
 
e:=MyChr(1,CharSet);
while (i<>BB) do
  begin
  Res := MySum(Res, AA, CharSet);
  i := MySum(i,e,CharSet);
  end;
Result:= Res;
end;
 
//**f0****************************************************************
function f0(A: Char; SetIn, SetOut: String): String;
var
  Pos, j, L: Integer;
  Res: String;
begin
L := Length(SetOut);
Pos := MyOrd(A,SetIn);
For j := 1 To Pos div (L-1) do
Res := MySum( Res,MyChr(L-1,SetOut),SetOut);
Result := MySum(Res,MyChr(Pos mod (L-1),SetOut),SetOut);
end;
 
//**Convert************************************************************
function Convert(A, SetIn, SetOut: String): String;
var
  Base, Multiplier, N, Res: String;
  i: Integer;
begin
Base := MySum(f0(MyChr(Length(SetIn)-1,SetIn),SetIn,SetOut),MyChr(1,SetOut),SetOut);
N:=MyChr(1,SetOut);
Res:='';
 
for i:= Length(A) downto 1 do
  begin
  Multiplier := f0(A[i],SetIn,SetOut);
  Res := MySum(Res,MyMulti(Multiplier,N,SetOut),SetOut);
  N := MyMulti(Base,N,SetOut);
  end;
 
Result := Res;
end;

"Перевод между системами исчисления"
-----------------------------------------------------------------------
Полнофункциональный готовый модуль с расширенными возможностями.
 
 
UNIT CONVUNIT;
INTERFACE
 
FUNCTION DEC2BIN(DEC: LONGINT): STRING;
FUNCTION BIN2DEC(BIN: STRING): LONGINT;
FUNCTION DEC2HEX(DEC: LONGINT): STRING;
FUNCTION HEX2DEC(HEX: STRING): LONGINT;
FUNCTION DEC2OCT(DEC: LONGINT): STRING;
FUNCTION OCT2DEC(OCT: STRING): LONGINT;
FUNCTION BIN2HEX(BIN: STRING): STRING;
FUNCTION HEX2BIN(HEX: STRING): STRING;
FUNCTION DEC2BASEN(BASE: INTEGER; DEC: LONGINT): STRING;
 
FUNCTION BASEN2DEC(BASE: INTEGER; NUM: STRING): LONGINT;
 
 
IMPLEMENTATION
 
FUNCTION DEC2BIN(DEC: LONGINT): STRING;
 
VAR
  BIN : STRING;
  I, J: LONGINT;
 
BEGIN
  IF DEC = 0 THEN BIN := '0'
  ELSE
  BEGIN
    BIN := '';
    I := 0;
    WHILE (1 SHL (I + 1)) <=DEC DO I := I + 1;
    { (1 SHL (I + 1)) = 2^(I + 1) }
    FOR J := 0 TO I DO
    BEGIN
      IF (DEC SHR (I - J)) = 1 THEN BIN := BIN + '1'
      { (DEC SHR (I - J)) = DEC DIV 2^(I - J) }
      ELSE BIN := BIN + '0';
      DEC := DEC AND ((1 SHL (I - J)) - 1);
      { DEC AND ((1 SHL (I - J)) - 1) = DEC MOD 2^(I - J) }
    END;
  END;
  DEC2BIN := BIN;
END;
 
FUNCTION BIN2DEC(BIN: STRING): LONGINT;
 
VAR
  J    : LONGINT;
  Error: BOOLEAN;
  DEC  : LONGINT;
 
BEGIN
  DEC := 0;
  Error := False;
  FOR J := 1 TO Length(BIN) DO
  BEGIN
    IF (BIN[J] <>'0') AND (BIN[J] <>'1') THEN Error := True;
    IF BIN[J] = '1' THEN DEC := DEC + (1 SHL (Length(BIN) - J));
    { (1 SHL (Length(BIN) - J)) = 2^(Length(BIN)- J) }
  END;
  IF Error THEN BIN2DEC := 0
  ELSE BIN2DEC := DEC;
END;
 
FUNCTION DEC2HEX(DEC: LONGINT): STRING;
 
CONST
  HEXDigts: STRING[16] = '0123456789ABCDEF';
 
VAR
  HEX : STRING;
  I, J: LONGINT;
 
BEGIN
  IF DEC = 0 THEN HEX := '0'
  ELSE
  BEGIN
    HEX := '';
    I := 0;
    WHILE (1 SHL ((I + 1) * 4)) <=DEC DO I := I + 1;
    { 16^N = 2^(N * 4) }
    { (1 SHL ((I + 1) * 4)) = 16^(I + 1) }
    FOR J := 0 TO I DO
    BEGIN
      HEX := HEX + HEXDigts[(DEC SHR ((I - J) * 4)) + 1];
      { (DEC SHR ((I - J) * 4)) = DEC DIV 16^(I - J) }
      DEC := DEC AND ((1 SHL ((I - J) * 4)) - 1);
      { DEC AND ((1 SHL ((I - J) * 4)) - 1) = DEC MOD 16^(I - J) }
    END;
  END;
  DEC2HEX := HEX;
END;
 
FUNCTION HEX2DEC(HEX: STRING): LONGINT;
 
FUNCTION Digt(Ch: CHAR): BYTE;
 
CONST
  HEXDigts: STRING[16] = '0123456789ABCDEF';
 
VAR
  I: BYTE;
  N: BYTE;
 
BEGIN
  N := 0;
  FOR I := 1 TO Length(HEXDigts) DO
  IF Ch = HEXDigts[I] THEN N := I - 1;
  Digt := N;
END;
 
CONST
  HEXSet: SET OF CHAR = ['0'..'9', 'A'..'F'];
 
VAR
  J    : LONGINT;
  Error: BOOLEAN;
  DEC  : LONGINT;
 
BEGIN
  DEC := 0;
  Error := False;
  FOR J := 1 TO Length(HEX) DO
  BEGIN
    IF NOT (UpCase(HEX[J]) IN HEXSet) THEN Error := True;
    DEC := DEC + Digt(UpCase(HEX[J])) SHL ((Length(HEX) - J) * 4);
    { 16^N = 2^(N * 4) }
    { N SHL ((Length(HEX) - J) * 4) = N * 16^(Length(HEX) - J) }
  END;
  IF Error THEN HEX2DEC := 0
  ELSE HEX2DEC := DEC;
END;
 
FUNCTION DEC2OCT(DEC: LONGINT): STRING;
 
CONST
  OCTDigts: STRING[8] = '01234567';
 
VAR
  OCT : STRING;
  I, J: LONGINT;
 
BEGIN
  IF DEC = 0 THEN OCT := '0'
  ELSE
  BEGIN
    OCT := '';
    I := 0;
    WHILE (1 SHL ((I + 1) * 3)) <=DEC DO I := I + 1;
    { 8^N = 2^(N * 3) }
    { (1 SHL (I + 1)) = 8^(I + 1) }
    FOR J := 0 TO I DO
    BEGIN
      OCT := OCT + OCTDigts[(DEC SHR ((I - J) * 3)) + 1];
      { (DEC SHR ((I - J) * 3)) = DEC DIV 8^(I - J) }
      DEC := DEC AND ((1 SHL ((I - J) * 3)) - 1);
      { DEC AND ((1 SHL ((I - J) * 3)) - 1) = DEC MOD 8^(I - J) }
    END;
  END;
  DEC2OCT := OCT;
END;
 
FUNCTION OCT2DEC(OCT: STRING): LONGINT;
 
CONST
  OCTSet: SET OF CHAR = ['0'..'7'];
 
VAR
  J    : LONGINT;
  Error: BOOLEAN;
  DEC  : LONGINT;
 
BEGIN
  DEC := 0;
  Error := False;
  FOR J := 1 TO Length(OCT) DO
  BEGIN
    IF NOT (UpCase(OCT[J]) IN OCTSet) THEN Error := True;
    DEC := DEC + (Ord(OCT[J]) - 48) SHL ((Length(OCT) - J) * 3);
    { 8^N = 2^(N * 3) }
    { N SHL ((Length(OCT) - J) * 3) = N * 8^(Length(OCT) - J) }
  END;
  IF Error THEN OCT2DEC := 0
  ELSE OCT2DEC := DEC;
END;
 
FUNCTION BIN2HEX(BIN: STRING): STRING;
 
FUNCTION SetHex(St: STRING; VAR Error: BOOLEAN): CHAR;
 
VAR
  Ch: CHAR;
 
BEGIN
       IF St = '0000' THEN Ch := '0'
  ELSE IF St = '0001' THEN Ch := '1'
  ELSE IF St = '0010' THEN Ch := '2'
  ELSE IF St = '0011' THEN Ch := '3'
  ELSE IF St = '0100' THEN Ch := '4'
  ELSE IF St = '0101' THEN Ch := '5'
  ELSE IF St = '0110' THEN Ch := '6'
  ELSE IF St = '0111' THEN Ch := '7'
  ELSE IF St = '1000' THEN Ch := '8'
  ELSE IF St = '1001' THEN Ch := '9'
  ELSE IF St = '1010' THEN Ch := 'A'
  ELSE IF St = '1011' THEN Ch := 'B'
  ELSE IF St = '1100' THEN Ch := 'C'
  ELSE IF St = '1101' THEN Ch := 'D'
  ELSE IF St = '1110' THEN Ch := 'E'
  ELSE IF St = '1111' THEN Ch := 'F'
  ELSE Error := True;
  SetHex := Ch;
END;
 
VAR
  HEX  : STRING;
  I    : INTEGER;
  Temp : STRING[4];
  Error: BOOLEAN;
 
BEGIN
  Error := False;
  IF BIN = '0' THEN HEX := '0'
  ELSE
  BEGIN
    Temp := '';
    HEX := '';
    IF Length(BIN) MOD 4 <>0 THEN
    REPEAT
      BIN := '0' + BIN;
    UNTIL Length(BIN) MOD 4 = 0;
    FOR I := 1 TO Length(BIN) DO
    BEGIN
      Temp := Temp + BIN[I];
      IF Length(Temp) = 4 THEN
      BEGIN
        HEX := HEX + SetHex(Temp, Error);
        Temp := '';
      END;
    END;
  END;
  IF Error THEN BIN2HEX := '0'
  ELSE BIN2HEX := HEX;
END;
 
FUNCTION HEX2BIN(HEX: STRING): STRING;
 
VAR
  BIN  : STRING;
  I    : INTEGER;
  Error: BOOLEAN;
 
BEGIN
  Error := False;
  BIN := '';
  FOR I := 1 TO Length(HEX) DO
  CASE UpCase(HEX[I]) OF
    '0': BIN := BIN + '0000';
    '1': BIN := BIN + '0001';
    '2': BIN := BIN + '0010';
    '3': BIN := BIN + '0011';
    '4': BIN := BIN + '0100';
    '5': BIN := BIN + '0101';
    '6': BIN := BIN + '0110';
    '7': BIN := BIN + '0111';
    '8': BIN := BIN + '1000';
    '9': BIN := BIN + '1001';
    'A': BIN := BIN + '1010';
    'A': BIN := BIN + '1011';
    'C': BIN := BIN + '1100';
    'D': BIN := BIN + '1101';
    'E': BIN := BIN + '1110';
    'F': BIN := BIN + '1111';
    ELSE Error := True;
  END;
  IF Error THEN HEX2BIN := '0'
  ELSE HEX2BIN := BIN;
END;
 
FUNCTION Potens(X, E :LONGINT): LONGINT;
 
VAR
  P, I : LONGINT;
 
BEGIN
  P := 1;
  IF E = 0 THEN P := 1
  ELSE FOR I := 1 TO E DO P := P * X;
  Potens := P;
END;
 
FUNCTION DEC2BASEN(BASE: INTEGER; DEC: LONGINT): STRING;
 
CONST
  NUMString: STRING = '0123456789ABCDEFGHAIJKLMNOPQRSTUVWXYZ';
 
VAR
  NUM : STRING;
  I, J: INTEGER;
 
BEGIN
  IF (DEC = 0) OR (BASE <2) OR (BASE >36) THEN NUM := '0'
  ELSE
  BEGIN
    NUM := '';
    I := 0;
    WHILE Potens(BASE, I + 1) <=DEC DO I := I + 1;
    FOR J := 0 TO I DO
    BEGIN
      NUM := NUM + NUMString[(DEC DIV Potens(BASE, I - J)) + 1];
      DEC := DEC MOD Potens(BASE, I - J);
    END;
  END;
  DEC2BASEN := NUM;
END;
 
FUNCTION BASEN2DEC(BASE: INTEGER; NUM: STRING): LONGINT;
 
 
FUNCTION Digt(Ch: CHAR): BYTE;
 
CONST
  NUMString: STRING = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
 
VAR
  I: BYTE;
  N: BYTE;
 
BEGIN
  N := 0;
  FOR I := 1 TO Length(NUMString) DO
  IF Ch = NUMString[I] THEN N := I - 1;
  Digt := N;
END;
 
CONST
  NUMSet: SET OF CHAR = ['0'..'9', 'A'..'Z'];
 
VAR
  J    : INTEGER;
  Error: BOOLEAN;
  DEC  : LONGINT;
 
BEGIN
  DEC := 0;
  Error := False;
  IF (BASE <2) OR (BASE >36) THEN Error := True;
  FOR J := 1 TO Length(NUM) DO
  BEGIN
    IF (NOT (UpCase(NUM[J]) IN NUMSet)) OR (BASE <Digt(NUM[J]) + 1) THEN Error
:= True;
    DEC := DEC + Digt(UpCase(NUM[J])) * Potens(BASE, Length(NUM) - J);
  END;
  IF Error THEN BASEN2DEC := 0
  ELSE BASEN2DEC := DEC;
END;
 
END.

Цитата

var
  i, Pos, Add, L, L_CharSet: Integer;
  AA,BB, O, Res: String;
begin
if Length(A)>=Length(B)
   then begin AA:=A; BB:=B; end
   else begin AA:=B; BB:=A; end;

Кошмар, это код не для FAQ. Что за AA, BB? Тут даже комментариями в коде не обойдешься. Нужно называть переменные нормально. Советую почитать эту тему.

Насчет кода S6T6N6. Написано не очень качественно. Некоторые функции можно было бы написать более эффективно. Нет комментариев, а код большой и содержит много сходу непонятных преобразований.

В общем, вот образец:
Перевод чисел из десятичной

Переписал, вроде нигде не напортачил. Пойдет?

Использование: пример конвертирования числа ABC01, записанного в 16-ти ричной СИ в 8-ричную

Convert('ABC01','0123456789ABCDEF','01234567')

// Модуль для работы с натуральными числами в различных системах исчисления
 
// Далее, если говорится, что Система Исчисления (СИ) задается строкой (CharSet)
// то имеется в виду, что эта строка содержит символы требуемой СИ, начиная с нуля
// Примеры CharSet (стандартный вид)
// Двоичная          - '01'
// Восьмиричная      - '01234567'
// Десятичная        - '0123456789'
// Шестнадцатиричная - '0123456789ABCDEF'
// Можно использовать и нестандартные виды, например для двоичной 'ab', а для
// троичной 'abc' - данному модулю все равно.
 
// "-Ричность" СИ ограничена только наличием доступных различных символов.
// Работа с числами в определенной СИ производится как со строками, потому величина
// чисел значения почти не имеет, но это отрицательно сказывается на времени работы
// функций (особенно на умножении).
unit MyUnit;
 
interface
 
function Convert(Num, SetIn, SetOut: String): String;
function MySum (Num1, Num2, CharSet: String): String;
function MyMulti (Num1, Num2, CharSet: String): String;
function MyOrd(A: Char; CharSet: String): Integer;
function MyChr(Num: Integer; CharSet: String): Char;
 
implementation
 
// Функция возвращает позицию символа A в строке CharSet (начиная с 0)
function MyOrd(A: Char; CharSet: String): Integer;
var
  i: Integer;
begin
  Result := 0;
  for i := 1 to Length(CharSet) do
  begin
    if CharSet[i] = A then begin
      Result := i-1;
      exit;
    end
  end;
end;
 
// Функция возвращает символ из строки CharSet по номеру Num (~CharSet[Num+1])
function MyChr(Num: Integer; CharSet: String): Char;
begin
  Result := CharSet[Num mod Length(CharSet) + 1];
end;
 
// Функция возвращает число без ведущих нулей, то есть ShortNum('0000123')='123'
function ShortNum(Num, CharSet: String): String;
var
  k, j: Integer;
begin
  Result := '';
  k := 1;
  while Num[k] = MyChr(0, CharSet) do
    k := k + 1;
  for j := k to Length(Num) do Result := Result + Num[j];
end;
 
// Функция выполняет сложение двух чисел Num1 и Num2 в СИ, задаваемой CharSet
function MySum (Num1, Num2, CharSet: String): String;
var
  i, Pos, Add, L, L_CharSet: Integer;
  N1 , N2 , O, Res: String;
begin
 
  // Далее потребуется что бы первое число по длине было не менее второго,
  // если не так, то меняем местами
  if Length(Num1)>=Length(Num2) then
  begin
    N1 := Num1;
    N2 := Num2;
  end
  else
  begin
    N1 := Num2;
    N2 := Num1;
  end;
 
  L:= Length(N1);
  L_CharSet := Length(CharSet);
  O:=MyChr(0, CharSet); // 0 - в СИ, определяемой CharSet
 
  //Уравнняем второе до длины первого нулями справа: 10 = 010
  for i := Length(N2) to L-1 do
    N2 := O + N2;
 
  Add:=0;
 
  //Суммирование с младших разрядов, Add - добавка от предыдущих разрядов
  // для следующего. Напр. для 10-чной СИ: 9+7 - Add = 1, 4+5 - Add=0
  for i := L downto 1 do
  begin
    Pos := MyOrd(N1[i], CharSet)+MyOrd(N2[i], CharSet) + Add;
    Add := 0;
    while Pos >= L_CharSet do
     begin
     Pos := Pos mod L_CharSet;
     Add := Add + 1;
     end;
 
  Res := MyChr(Pos, CharSet) + Res;
  end;
 
If Add<>0
   then Result := MyChr(Add, CharSet) + Res
   else Result := Res;
end;
 
// Функция выполняет умножение двух чисел Num1 и Num2 в СИ, задаваемой CharSet
function MyMulti (Num1, Num2, CharSet: String): String;
var
  i, e, Res, N1, N2: String;
begin
  N1 := ShortNum(Num1, CharSet);
  N2 := ShortNum(Num2, CharSet);
 
  i :='';
  Res := '';
 
  //e - единица СИ, определяемая CharSet
  e := MyChr(1,CharSet);
 
  //Умножение Num1 на Num2 - это Num1 сложеное Num2 раз в СИ, определяемой CharSet
  while (i <> N2) do
  begin
    Res := MySum(Res, N1, CharSet);
    i := MySum(i, e, CharSet);
  end;
 
  Result := Res;
end;
 
// Функция выполняет преобразование одноразрядного числа A, заданного
// в СИ, определяемой SetIn, в число в СИ, определяемой SetOut
function f0(A: Char; SetIn, SetOut: String): String;
var
  Pos, j, L: Integer;
  Res: String;
begin
  L := Length(SetOut);
  Pos := MyOrd(A, SetIn);
 
  for j := 1 To Pos div (L-1) do
    Res := MySum(Res, MyChr(L-1, SetOut), SetOut);
 
  Result := MySum(Res, MyChr(Pos mod (L-1), SetOut), SetOut);
end;
 
// Функция выполняет преобразование числа Num, заданного
// в СИ, определяемой SetIn, в число в СИ, определяемой SetOut
function Convert(Num, SetIn, SetOut: String): String;
var
  Base, Multiplier, N, Res: String;
  i: Integer;
begin
  // Num = MultilplierN * Base^N + ... + Multiplier0 * Base^0
  // Base - основание СИ, это всегда <последний символ CharSet>+<нулевой символ> ~ 10
  // MultiplierI - множитель при соответствующей степени
  // Напр. для 10-чной СИ  -  123 = 1 * 10^2 + 2 * 10^1 + 3 * 10^0
  // Тут Base = 10, Multiplier = {1, 2, 3}
 
  Base := MySum(f0(MyChr(Length(SetIn)-1, SetIn), SetIn, SetOut), MyChr(1, SetOut), SetOut);
  N := MyChr(1, SetOut); // = Base^0, потом будем домножать на Base (в соотв. СИ)
  Res := '';
 
  // Обрабатываем входящее число с хвоста
  for i := Length(Num) downto 1 do
  begin
    Multiplier := f0(Num[i], SetIn, SetOut);
    Res := MySum(Res, MyMulti(Multiplier, N, SetOut), SetOut);
    N := MyMulti(Base, N, SetOut);
  end;
 
  Result := Res;
end;
 
end.