Pascal: Калькулятор для перевода из одной системы счисления в другую

В прошлом году я писал программу для перевода из любой системы в любую систему счисления на си. Теперь потребовалось на Pascal.Функций стало больше. Некоторые пришлось просто копировать с других сайтов (да простят меня авторы)

К сожалению, точность вычислений здесь меньше, чем была на си — всего один знак после запятой точен.

Ограничение во FreePascal: числа в 16-ричной системе можно вводить только большими буквами. Нет функции UpperCase, писать было лень :)
Исходный код (FreePascal):

program test;
uses crt, math, strings;
var 
   s, s1,s2 : string; // число для перевода
   base_in : integer; // Основание входной системы счисления
   base_out : integer; // Основание выходной системы счисления
function CheckDotCount(s: string): boolean; // Проверка количества точек в числе
var
  count, i : integer;
begin
  count := 0;
  for i := 1 to Length(s) do
    if (s[i] = '.') then inc(count);
  if (count > 1) then CheckDotCount := false
  else CheckDotCount := true;
end;

function IntToHex(ds: byte): string;
const
 b: string = '0123456789ABCDEF';
begin
if (b[(ds shr 4) + 1] = '0') then
  IntToHex:= b[(ds and $F) + 1]
else IntToHex:= b[(ds shr 4) + 1] + b[(ds and $F) + 1];
end;

function HexToInt(s: string): Longword;
 var
   b: Byte;
   c: Char;
   r: Longword;
 begin
   r := 0;
   //s := UpperCase(s);
   for b := 1 to Length(s) do
   begin
     r := r * 16;
     c := s[b];
     case c of
       '0'..'9': Inc(r, Ord(c) - Ord('0'));
       'A'..'F': Inc(r, Ord(c) - Ord('A') + 10);
     end;
   end;
   HexToInt := r;
 end;

function checkSS(base : integer; s : string): boolean;
var
  i: integer;
  flag : boolean;
begin
  flag := true;
  for i := 1 to Length(s) do
  begin
    if (HexToInt(s[i]) >= base) then flag := false;
  end;
  if ((base > 16) or (base < 2)) then flag := false;
  checkSS := flag;
end;

function checkSSR (base : integer):boolean;
begin
if ((base > 16) or (base < 2)) then checkSSR := false
else
checkSSR := true;
end;

function getStringBeforeDot(s:string): string;
  //pos : integer;
begin
  if (Pos('.',s) = 0) then getStringBeforeDot := s
  else getStringBeforeDot := Copy(s, 1,Pos('.',s)-1);
end;

function getStringAfterDot(s: string):string;
begin
  if (Pos('.',s) = 0) then getStringAfterDot := ''
  else
    getStringAfterDot := copy(s,Pos('.',s)+1,Length(s));
end;

procedure IntConverter(s:string; base_in : integer; base_out : integer);
var
  n1,N,i,r1 : integer;
  d1 : array [0..255] of integer;
begin
  n1 := Length(s);
  N := 0;
  for i := 1 to n1 do
  begin
    N:= N*base_in+HexToInt(s[i]);
  end;
  if (N = 0) then write ('0')
  else
  begin
    r1 := 0;
    while (N <> 0) do
    begin
       d1[r1] := N mod base_out;
       N := N div base_out;
       inc(r1);
    end;
  for i:=r1-1 downto 0 do
    write(IntToHex(d1[i]));
  end;
end;

procedure DotConverter(s:string; base_in : integer; base_out : integer);
var
  n2 , i, k2: longint;
  Nf : double;
begin
  n2 := Length(s);
  if (n2 = 0) then
  begin
    writeln();
    exit;
  end;
  write('.');
  Nf := 0;
  for i := n2 downto 1 do
  begin
    Nf := (HexToInt(s[i]) + Nf) / base_in;
  end;
  k2 := 0;
  while ((Nf <> 0) AND (k2 < 5)) do
  begin
    inc(k2);
    write(IntToHex(floor(Nf*base_out)));
    Nf := ((Nf*base_out));
  end;
end;

begin
  writeln('Введите число для перевода:');
  readln(s);
  if (CheckDotCount(s) = false) then
  begin
    writeln('Во введеном числа более 1 точки, что-то не так');
    exit;  
  end;
  writeln('Введите основание входной системы счисления:');
  readln(base_in);
  if (checkSS(base_in, s) = false) then
  begin
    writeln('Некорректная система счисления или число для этой системы счисления');
    exit;  
  end;
  writeln('Введите основание выходной системы счисления:');
  readln(base_out);
  if (checkSSR(base_out) = false) then
  begin
    writeln('Некорректная система счисления или число для этой системы счисления');
    exit;  
  end;
  s1 := getStringBeforeDot(s);
  s2 := getStringAfterDot(s);
  IntConverter(s1,base_in,base_out);
  DotConverter(s2,base_in,base_out);
  readln;
end.

На PascalABC нет некоторых функций, зато есть другие.

Версия для PascalABC

program test;

var 
   s, s1,s2 : string; // число для перевода
   base_in : integer; // Основание входной системы счисления
   base_out : integer; // Основание выходной системы счисления
function CheckDotCount(s: string): boolean; // Проверка количества точек в числе
var
  count, i : integer;
begin
  count := 0;
  for i := 1 to Length(s) do
    if (s[i] = '.') then inc(count);  
   if (count > 1) then CheckDotCount := false
   else CheckDotCount := true;
end;

function IntToHex(ds: byte): string;
const
 b: string = '0123456789ABCDEF';
begin
if (b[(ds shr 4) + 1] = '0') then
  Result:= b[(ds and $F) + 1]
else Result:= b[(ds shr 4) + 1] + b[(ds and $F) + 1];  
end;

function HexToInt(s: string): Longword;
 var
   b: Byte;
   c: Char;
 begin
   Result := 0;
   s := UpperCase(s);
   for b := 1 to Length(s) do
   begin
     Result := Result * 16;
     c := s[b];
     case c of
       '0'..'9': Inc(Result, Ord(c) - Ord('0'));
       'A'..'F': Inc(Result, Ord(c) - Ord('A') + 10);
     end;
   end;
 end;

function checkSS(base : integer; s : string): boolean;
var
  i: integer;
  flag : boolean;
begin
  flag := true;
  for i := 1 to Length(s) do 
  begin
    if (HexToInt(s[i]) >= base) then flag := false;
  end;
  if ((base > 16) or (base < 2)) then flag := false;
  Result := flag;
end;

function checkSSR (base : integer):boolean;
begin
if ((base > 16) or (base < 2)) then Result := false
else
Result := true;
end;

function getStringBeforeDot(s:string): string;
  //pos : integer;
begin
  if (Pos('.',s) = 0) then Result := s
  else Result := Copy(s, 1,Pos('.',s)-1);
end;

function getStringAfterDot(s: string):string;
begin
  if (Pos('.',s) = 0) then Result := ''
  else
    Result := copy(s,Pos('.',s)+1,Length(s));
end;

procedure IntConverter(s:string; base_in : integer; base_out : integer);
var
  n1,N,i,r1 : integer;
  d1 : array [0..255] of integer;
begin
  n1 := Length(s);
  N := 0;
  for i := 1 to n1 do
  begin
    N:= N*base_in+HexToInt(s[i]);
  end;
  if (N = 0) then write ('0')
  else
  begin
    r1 := 0;
    while (N <> 0) do
    begin
       d1[r1] := N mod base_out;
       N := N div base_out;
       inc(r1);
    end;
  for i:=r1-1 downto 0 do
    write(IntToHex(d1[i]));
  end;
end;

procedure DotConverter(s:string; base_in : integer; base_out : integer);
var
  n2 , i, k2: longint;
  Nf : double;
begin
  n2 := Length(s);
  if (n2 = 0) then
  begin
    writeln();
    exit;
  end;
  write('.');
  Nf := 0;
  for i := n2 downto 1 do
  begin
    Nf := (HexToInt(s[i]) + Nf) / base_in;
  end;
  k2 := 0;
  while ((Nf <> 0) AND (k2 < 20)) do
  begin
    inc(k2);
    write(IntToHex(Floor(Nf*base_out)));
    Nf := ((Nf*base_out));
  end;
end;

begin
  writeln('Введите число для перевода:');
  readln(s);
  if (CheckDotCount(s) = false) then
  begin
    writeln('Во введеном числе более 1 точки, что-то не так');
    exit;  
  end;
  writeln('Введите основание входной системы счисления:');
  readln(base_in);
  if (checkSS(base_in, s) = false) then
  begin
    writeln('Некорректная система счисления или число для этой системы счисления');
    exit;  
  end;
  writeln('Введите основание выходной системы счисления:');
  readln(base_out);
  if (checkSSR(base_out) = false) then
  begin
    writeln('Некорректная система счисления или число для этой системы счисления');
    exit;  
  end;
  s1 := getStringBeforeDot(s);
  s2 := getStringAfterDot(s);
  IntConverter(s1,base_in,base_out);
  DotConverter(s2,base_in,base_out);
  readln;
end.

Исполняемые файлы:

• FreePascal
• PascalAbc

Внимание, PascalABC и, соответственно, его версия исполняемых файлов требует .Net Framework Версии 4. Он встроен в Windows 8, но его нужно включить в компонентах Windows.

Скрины:

Версия запущенная в Pascal ABC