Перевод из Q-ичной в P-q-ичную с. с. Опции

[/7popok]

Сколько программ перевода в разные системы счисления я видел, и стандартные: 2- 8- 10- 16-, и разные другие, даже из римской в 10- и обратно и в троичную уравновешенную и обратно. Но сколько я ни искал, так и не нашёл переводов в системы со смешанным основанием. Попытался написать такое, но получилось наоборот из P-Q-ичной в Q-ичную. Теперь мучаюсь. Не могу сделать то, что хотел... посмотрите, пожалуйста, кому не лень, и подскажите, что не так... легче было простенькую игрушку на 500 строк написать, чем это, честно...

uses crt;
var
 te,i,j,tp,p,q,xk,xkt,code:integer;
 x,tt:real;
 s:string;
{---------------------------------------------------}
 {функция возведения числа I в степень j}
 function stepen ( i,j:integer): integer;
 var
  k :integer;
  s:longint;
 begin
  s:=1;
  if j=0 then stepen:=1;
  for k:=0 to j-1 do
    s:=s*i;
  stepen:=s;
 end;
 {---------------------------------------------------}
 {нахождение количества цифр в разряде}
 procedure Kolvo;
 var
  sn:integer;
 begin
  tp:=1;
  sn:=q-1;
  repeat
   sn:=(sn) div p;
   tp:=tp+1;
  until sn<p;
 end;
{---------------------------------------------------}
begin
clrscr;
{ввод в цикле параметров:
  Число, основание p и q с.с
 в случае некорректного ввода данных на экран выводится сообшение об ошибке,
 ввод данных повторяется }
repeat
 write(' vvedite 4islo: ');
 readln(s);
 te:=1;
 Val(s, x, Code);
 If Code<>0 Then
  begin
   WriteLn('oshibka pri preobrazovanii v pozicii!!! : ', Code);
   te:=0;
  end;
 if x<>trunc(x) then
  begin
   writeln('4islo dolzno bit celim');
   readln;
   te:=0;
  end;
 if te<>0 then
 begin
   write(' vvedite osnovanie p: ');
   readln(p);
   write(' vvedite osnovanie q: ');
   readln(q);
 if q>10 then
  begin
   writeln('Error!!! osnovanie ne bolshe 10');
   readln;
   te:=0;
   end;
 end;
 if te<>0 then
 if (p>=q)or(not(p>1))or(not(q>2)) then
  begin
   writeln('Error!!! nepravilnoe osnovanie!(p>=q)');
   readln;
   te:=0;
  end;
 until te=1;
 {вызов функции подсчета количества цифр в разряде}
 kolvo;
 xk:=0;
 j:=0;
 xk:=0;
 xkt:=0;
 {перевод числа в q c.c}
 Repeat
  {перевод разряда}
  for i:=1 to tp do
   begin
    j:=j+1;
    tt:=x-trunc(x/10)*10;
    if tt>=p then
     begin
       writeln('Error!!! cifra bolshe osnovaniya!');
       readln;
       exit;
     end;
    x:=(x-tt)/10;
    {перевод чисел разряда из p в q}
    xkt:=xkt + trunc(tt)*stepen(p,i-1);
   end;
   {проверка на корректность данных}
   if xkt>=q then
    begin
       writeln('Error!!! nevernoe 4islo!');
       readln;
       exit;
    end;
   {суммирование разрядов в конечное число}
   xk:=xk+ xkt*stepen(10,trunc(j/tp)-1);
   xkt:=0;
 until j>=10;
 writeln;
 {вывод результата на экран}
 writeln('4islo po osnavaneu ',p,'-',q,' = ',xk);
readln;
end.

P.S. Этот код уже с исправлениями частично под то, что я пытался сделать, но на большее меня не хватило.

Сообщение отредактировано: /7popok - 24.01.2007 21:03

[volvo]

Я бы сделал вот так (с учетом FromDec/ToDec из FAQ-а):

function zeroes(s: string; n: integer): string;
begin
  while length(s) < n do s := '0' + s;
  zeroes := s
end;

function power(a, b: integer): longint;
var i, X: longint;
begin
  X := 1;
  for i := 1 to b do
    X := X * a;

  power := X;
end;

var
  P, Q: integer;
  get_bits, i, num: integer;

  s_num, s_res, conv: string;

begin
  {
    write('P = '); readln(P);
    write('Q = '); readln(Q);
  }

  p := 3;
  q := 9;
  num := 121;

  get_bits := 0;
  while power(P, get_bits) < Q do inc(get_bits);

  writeln('get_bits = ', get_bits);
  str(num, s_num);

  s_res := '';
  for i := 1 to length(s_num) do begin
    s_res := s_res + zeroes(fromdec(todec(s_num[i], q), p), get_bits);
  end;
  while (length(s_res) > 0) and (s_res[1] = '0') do delete(s_res, 1, 1);
  writeln(s_res)


end.

С отрицательными чуть позже разберусь... Пока не совсем понятен алгоритм...