VPF::[TP 7.1] Результат операции: 2^n - Форум программистов

MuForum

Дата 2.2.2008, 16:12 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 427
Регистрация: 13.6.2007
Где: Молдова, Кишинев

Репутация: нет
Всего: 4

Доброе время суток!
Сегодня была у меня в городе Олимпиада, а одна из задач была следующиая:

# Задача: Вывести на экран значение 2 в n степени. (2^n).
- (0<=n<=1000).

Я решил эту задачу следующим методом:

Код


{$N+}
Program T1;
Uses
    CRT, DOS;
{---}
procedure Check;
Var
    n: integer;
    V: extended;
Begin
    repeat
        ClrScr;
        n := 0;
        Write('n = '); ReadLn(n);
    until((n >= 0) and (n < 1001));
    V := exp(ln(2)*n);
    Write('Res: ',V:0:0);
end;
{---}
Begin
    Check;
    ReadKey;
end.

- Но если значение больше 17 символов, то на экран далее 17 символа выводиться нули.

# Вопрос:: Как РАЦИОНАЛЬНО можно решить данную задачу именно на 'Turbo Pascal 7.1'?!

--------------------

"Чтобы правильно задать вопрос, нужно знать большую часть ответа!" (Р. Шекли)

volvo877

Дата 2.2.2008, 16:31 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Комодератор
Сообщений: 2073
Регистрация: 15.11.2004

Репутация: 2
Всего: 116

Причем тебе надо не приближенное значение, а точное, до последней цифры, так? Задача явно на длинную арифметику. Ищи на форуме, по-моему уже были реализации.

mmvds

Дата 2.2.2008, 16:34 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 230
Регистрация: 22.12.2007

Репутация: нет
Всего: 6

Цитата(MuForum @ 2.2.2008, 16:12

)

Я решил эту задачу следующим методом

Если условие именно такое, как ты написал, то это решение единственное, т.к. не сказано ничего про N, и оно может быть действительным (т.е. как целым, так и дробным).
Если же N- натуральное, то метод решением в лоб (т.е. простым перемножением) позволил бы получить значения до 2^30, результат сделав типа longint.
Если нужно решить задачу в натуральных числах до N=1000, а это число из 302 цифр, то никакой целочисленный или вещественный тип паскаля не уместит столько.
Единственный выход - химичить со строками (string), при этом ограничение в 7.0 на строки не более 256 символов в строке, в 7.1 не в курсе, но скорее всего такое же.
Поэтому остается массив из 303 строк по 1 символу (array [1..303] of string[1]) ну а далее пошагово вспомнить как умножается число на другое с переносом разряда.

MuForum

Дата 2.2.2008, 16:39 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 427
Регистрация: 13.6.2007
Где: Молдова, Кишинев

Репутация: нет
Всего: 4

#volvo877, mmvds - Спасибо за консультацию ребята. В принципе я сейчас как раз так и пытаюсь реализовать этот метод, так как другим методом не вижу.

P.S. -> По сути стоит создавать одномерный динамический массив, в котором и будут хранить всю информацию. А на экран уже выводить по одном символу.

--------------------

"Чтобы правильно задать вопрос, нужно знать большую часть ответа!" (Р. Шекли)

digitech

Дата 2.2.2008, 16:40 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 271
Регистрация: 1.4.2007

Репутация: нет
Всего: 1

Код


Uses CRT, DOS;
var m:longint;

Function Check(chislo,stepen:real):longint;
Begin
    check :=trunc(exp(ln(chislo) * stepen));
end;


Begin
    m:=Check(2,30);
    Writeln(m);
    ReadKey;
end.

volvo877

Дата 2.2.2008, 16:51 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Комодератор
Сообщений: 2073
Регистрация: 15.11.2004

Репутация: 2
Всего: 116

digitech, ты на самом деле думаешь, что число из 300 знаков можно засунуть в LongInt? Я бы не рисковал все-таки smile

mmvds

Дата 2.2.2008, 16:56 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 230
Регистрация: 22.12.2007

Репутация: нет
Всего: 6

digitech, И что, это значения только до 30, как я и писал, а надо до 1000

digitech

Дата 2.2.2008, 17:00 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 271
Регистрация: 1.4.2007

Репутация: нет
Всего: 1

MuForum, если реализуешь свою задачу, покажи код. Интересно.

kuzyara

Дата 13.2.2008, 18:04 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 215
Регистрация: 13.11.2006

Репутация: нет
Всего: 1

Цитата(DRKB)

Это модуль для работы с очень большими числами без потери точности. Модуль даёт возможность манипулирования с 10000 и более значащими цифрами в числах. В модуле реализованы сложение, вычитание, умножение, деление, возведение в целую степень и факториал. Все функции в качестве аргументов принимают длинные строки и результат выдают тоже в виде строки.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Просьба связаться со мной, если кто хочет доработать модуль и расширить функциональность.

Код


unit UMathServices; 
{Автор Vit} 

interface 


Type TProgress = procedure(Done:real); 

{Собственно экспортные функции} 
Function ulFact(First:String):string; 
Function ulSum(First, Second :string):string; 
Function ulSub(First, Second :string):string; 
Function ulMPL(First, Second :string):string; 
Function ulPower(First, Second :string):string; 
function UlDiv(First, Second:String; Precision:integer):String;   {Precision - не истинная точность а количество знаков учитываемых после запятой сверх тех которые значимы. Все знаки уже существующие в делимом и делителе в любом случае учитываются} 

{Call back function for long operations} 
var OnProgress: TProgress; 

implementation 

Uses SysUtils; 

type TMathArray=array of integer; 

Type TNumber=record 
               int, frac:TMathArray; 
               sign:boolean; 
             end; 

var   n1, n2:TNumber; 



Procedure Str2Number(s:string; var n:TNumber); 
  var i, j, l:integer; 
begin 
  if s='' then 
    begin 
      setlength(n.int , 0); 
      setlength(n.frac , 0); 
      exit; 
    end; 
  l:=length(s); 
  if s[1]='-' then 
    begin 
      s:=copy(s,2,l); 
      l:=l-1; 
      n.sign:=false; 
    end 
  else 
    n.sign:=true; 
  j:=pos('.', s); 
  if j>0 then 
    begin 
      setlength(n.int , j-1); 
      for i:=1 to j-1 do n.int[i-1]:=strtoint(s[j-i]); 
      setlength(n.frac , l-j); 
      for i:=1 to l-j do n.frac[i-1]:=strtoint(s[l-i+1]); 
    end 
  else 
    begin 
     setlength(n.int,l); 
     for i:=1 to l do n.int[i-1]:=strtoint(s[l-i+1]); 
     setlength(n.frac,0); 
    end; 
end; 

Function Num2Array(Var n:TNumber; var a:TMathArray):integer; 
  var i:integer; 
begin 
  result:=length(n.frac); 
  setlength(a,length(n.int)+result); 
  for i:=0 to length(a)-1 do if i<result then a[i]:=n.frac[i] else a[i]:=n.int[i-result]; 
end; 

Procedure MultiplyArray(var a1, a2, a:TMathArray); 
  var i, j:integer; 
      b:boolean; 
begin 
{checking for zero, 1} 
  for i:=length(a2)-1 downto 0 do 
    begin 
      for j:=length(a1)-1 downto 0 do 
        begin 
          a[j+i]:=a[j+i]+(a2[i]*a1[j]); 
        end; 
    end; 
  repeat 
    b:=true; 
    for i:=0 to length(a)-1 do 
      if a[i]>9 then 
        begin 
          b:=false; 
          try 
            a[i+1]:=a[i+1]+1; 
          except 
            setlength(a, length(a)+1); 
            a[i+1]:=a[i+1]+1; 
          end; 
          a[i]:=a[i]-10; 
        end; 
  until b; 
end; 


Procedure Array2Num(Var n:TNumber; var a:TMathArray; frac:integer; sign:boolean); 
  var i:integer; 
begin 
  setlength(n.frac,frac); 
  setlength(n.int,length(a)-frac); 
  for i:=0 to length(a)-1 do 
    begin 
      if i<frac then n.frac[i]:=a[i] else n.int[i-frac]:=a[i]; 
    end; 
  n.sign:=sign; 
end; 

Function Number2Str(var n:TNumber):string; 
  var i:integer; 
      s:string; 
begin 
  result:=''; 
  for i:=0 to high(n.int) do result:=inttostr(n.int[i])+result; 
  if length(n.frac)<>0 then 
    begin 
      for i:=0 to high(n.frac) do s:=inttostr(n.frac[i])+s; 
      result:=result+'.'+s; 
    end; 
  while (length(result)>1) and (result[1]='0') do delete(result,1,1); 
  if pos('.', result)>0 then while (length(result)>1) and (result[length(result)]='0') do delete(result,length(result),1); 
  if not n.sign then result:='-'+result; 
  setlength(n.int,0); 
  setlength(n.frac,0); 
end; 

Procedure DisposeNumber(var n:TNumber); 
begin 
  setlength(n.int,0); 
  setlength(n.frac,0); 
end; 


Function ulFact(First:String):string; 
  var n1, n2:TNumber; 
      i:integer; 
      a, a1, a2:TMathArray; 
      max:integer; 
begin 
  Str2Number('1', n1); 
  Str2Number('1', n2); 
  Num2Array(n1, a1); 
  Num2Array(n2, a2); 
  max:=strtoint(First); 
  for i:=1 to strtoint(First) do 
    begin 
      if Assigned(OnProgress) then OnProgress((i/max)*100); 
      setlength(a,length(a1)+length(a2)+1); 
      MultiplyArray(a1, a2, a); 
      setlength(a1,0); 
      setlength(a2,0); 
      a1:=a; 
      Str2Number(inttostr(i), n2); 
      Num2Array(n2, a2); 
    end; 
  Array2Num(n1, a1, 0, true); 
  result:=Number2Str(n1); 
  DisposeNumber(n1); 
end; 

Function ulPower(First, Second :string):string; 
  var i, j, c:integer; 
      a, a1, a2:TMathArray; 
  var n1:TNumber; 
      max:integer; 
begin 
  j:=strtoint(Second); 
  if j=0 then 
    begin 
      result:='1'; 
      exit; 
    end 
  else 
    if j=1 then 
      begin 
        result:=First; 
        exit; 
      end; 


  max:=j-1; 
  Str2Number(First, n1); 
  c:=Num2Array(n1, a1); 
  setlength(a,0); 
  setlength(a2,0); 
  a2:=a1; 
  for i:=1 to j-1 do 
    begin 
      if Assigned(OnProgress) then OnProgress((i/max)*100); 
      setlength(a,0); 
      setlength(a,length(a1)+length(a2)+1); 
      MultiplyArray(a1, a2, a); 
      setlength(a2,0); 
      a2:=a; 
    end; 
  setlength(a1,0); 
  setlength(a2,0); 
  c:=c*j; 
  if n1.sign then 
    Array2Num(n1, a, c, true) 
  else 
    if odd(j) then Array2Num(n1, a, c, false) else Array2Num(n1, a, c, true); 
  setlength(a,0); 
  result:=Number2Str(n1); 
  DisposeNumber(n1); 
end; 




Procedure MultiplyNumbers(var n1, n2 :TNumber); 
  var i:integer; 
      a, a1, a2:TMathArray; 
begin 
  i:=Num2Array(n1, a1)+Num2Array(n2, a2); 
  setlength(a,length(a1)+length(a2)+1); 
  MultiplyArray(a1, a2, a); 
  setlength(a1,0); 
  setlength(a2,0); 
  Array2Num(n1, a, i, n1.sign=n2.sign); 
  DisposeNumber(n2); 
  setlength(a,0); 
end; 


Function ulMPL(First, Second :string):string; 
  var n1, n2:TNumber; 
begin 
  Str2Number(First, n1); 
  Str2Number(Second, n2); 
  MultiplyNumbers(n1, n2); 
  result:=Number2Str(n1); 
  DisposeNumber(n1); 
end; 


Procedure AlignNumbers(var n1, n2:TNumber); 
  var i1, i2, i:integer; 
begin 
  i1:=length(n1.int); 
  i2:=length(n2.int); 
  if i1>i2 then setlength(n2.int, i1); 
  if i2>i1 then setlength(n1.int, i2); 

  i1:=length(n1.frac); 
  i2:=length(n2.frac); 

  if i1>i2 then 
    begin 
      setlength(n2.frac, i1); 
      for i:=i1-1 downto 0 do 
        begin 
          if i-(i1-i2)>0 then n2.frac[i]:=n2.frac[i-(i1-i2)] else n2.frac[i]:=0; 
        end; 
    end; 
  if i2>i1 then 
    begin 
      setlength(n1.frac, i2); 
      for i:=i2-1 downto 0 do 
        begin 
          if i-(i2-i1)>0 then n1.frac[i]:=n1.frac[i-(i2-i1)] else n1.frac[i]:=0; 
        end; 
    end; 
end; 


Function SubInteger(a1,a2:TMathArray):integer; 
  var i:integer; 
      b:boolean; 
begin 
  result:=0; 
  if length(a1)=0 then exit; 
  for i:=0 to length(a1)-1 do a1[i]:=a1[i]-a2[i]; 
  repeat 
    b:=true; 
    for i:=0 to length(a1)-1 do 
      if a1[i]<0 then 
        begin 
          b:=false; 
          if i=length(a1)-1 then 
            begin 
              result:=-1; 
              a1[i]:=a1[i]+10; 
              b:=true; 
            end 
          else 
            begin 
              a1[i+1]:=a1[i+1]-1; 
              a1[i]:=a1[i]+10; 
            end; 
        end; 
  until b; 
end; 

Procedure AssignNumber(out n1:TNumber; const n2:TNumber); 
  var i:integer; 
begin 
  Setlength(n1.int, length(n2.int)); 
  for i:=0 to length(n2.int)-1 do n1.int[i]:=n2.int[i]; 
  Setlength(n1.frac, length(n2.frac)); 
  for i:=0 to length(n2.frac)-1 do n1.frac[i]:=n2.frac[i]; 
  n1.sign:=n2.sign; 
end; 

Procedure SubNumber(var n1, n2 : TNumber); 
  var i:integer; 
      n:TNumber; 
begin 
  AlignNumbers(n1, n2); 
  i:=subInteger(n1.frac, n2.frac); 
  n1.int[0]:=n1.int[0]+i; 
  DisposeNumber(n); 
  AssignNumber(n, n1); 
  i:=subInteger(n1.int, n2.int); 
  if i<0 then 
    begin 
      subInteger(n2.int, n.int); 
      AssignNumber(n1, n2); 
    end 
  else 
    begin 
      DisposeNumber(n2); 
    end; 
end; 

Function SumInteger(a1,a2:TMathArray):integer; 
  var i:integer; 
      b:boolean; 
begin 
  result:=0; 
  if length(a1)=0 then exit; 
  for i:=0 to length(a1)-1 do a1[i]:=a1[i]+a2[i]; 
  repeat 
    b:=true; 
    for i:=0 to length(a1)-1 do 
      if a1[i]>9 then 
        begin 
          b:=false; 
          if i=length(a1)-1 then 
            begin 
              result:=1; 
              a1[i]:=a1[i]-10; 
              b:=true; 
            end 
          else 
            begin 
              a1[i+1]:=a1[i+1]+1; 
              a1[i]:=a1[i]-10; 
            end; 
        end; 
  until b; 
end; 

Procedure SumNumber(var n1, n2:TNumber); 
  var i:integer; 
begin 
  AlignNumbers(n1, n2); 
  i:=sumInteger(n1.frac, n2.frac); 
  n1.int[0]:=n1.int[0]+i; 
  i:=sumInteger(n1.int, n2.int); 
  if i>0 then 
    begin 
      setlength(n1.int, length(n1.int)+1); 
      n1.int[length(n1.int)-1]:=i; 
    end; 
  DisposeNumber(n2); 
end; 

Procedure SumNumbers(var n1, n2:TNumber); 
begin 
  if n1.sign and n2.sign then 
    begin 
      SumNumber(n1, n2); 
      n1.sign:=true; 
    end 
  else 
    if (not n1.sign) and (not n2.sign) then 
      begin 
        SumNumber(n1, n2); 
        n1.sign:=False; 
      end 
    else 
      if (not n1.sign) and n2.sign then 
        begin 
          SubNumber(n2, n1); 
          AssignNumber(n1, n2); 
        end 
      else 
        begin 
          SubNumber(n1, n2); 
        end; 
end; 

Function ulSum(First, Second :string):string; 
begin 
  Str2Number(First, n1); 
  Str2Number(Second, n2); 
  SumNumbers(n1, n2); 
  result:=Number2Str(n1); 
  DisposeNumber(n1); 
end; 

Function ulSub(First, Second :string):string; 
begin 
  Str2Number(First, n1); 
  Str2Number(Second, n2); 
  n2.sign:=not n2.sign; 
  SumNumbers(n1, n2); 
  result:=Number2Str(n1); 
  DisposeNumber(n1); 
end; 









function  DupChr(const X:Char;Count:Integer):AnsiString; 
begin 
  if Count>0 then begin 
    SetLength(Result,Count); 
    if Length(Result)=Count then FillChar(Result[1],Count,X); 
  end; 
end; 

function StrCmp(X,Y:AnsiString):Integer; 
var 
  I,J:Integer; 
begin 
  I:=Length(X); 
  J:=Length(Y); 
  if I=0 then begin 
    Result:=J; 
    Exit; 
  end; 
  if J=0 then begin 
    Result:=I; 
    Exit; 
  end; 
  if X[1]=#45 then begin 
    if Y[1]=#45 then begin 
      X:=Copy(X,2,I); 
      Y:=Copy(Y,2,J); 
    end else begin 
      Result:=-1; 
      Exit; 
    end; 
  end else if Y[1]=#45 then begin 
    Result:=1; 
    Exit; 
  end; 
  Result:=I-J; 
  if Result=0 then Result:=CompareStr(X,Y); 
end; 



function StrDiv(X,Y:AnsiString):AnsiString; 
var 
  I,J:Integer; 
  S,V:Boolean; 
  T1,T2:AnsiString; 
  R:string; 
  max:integer; 

begin 
  Result:=#48; 
  R:=#48; 
  I:=Length(X); 
  J:=Length(Y); 
  S:=False; 
  V:=False; 
  if I=0 then Exit; 
  if (J=0) OR (Y[1]=#48) then begin 
    Result:=''; 
    R:=''; 
    Exit; 
  end; 
  if X[1]=#45 then begin 
    Dec(I); 
    V:=True; 
    X:=Copy(X,2,I); 
    if Y[1]=#45 then begin 
      Dec(J); 
      Y:=Copy(Y,2,J) 
    end else S:=True; 
  end else if Y[1]=#45 then begin 
    Dec(J); 
    Y:=Copy(Y,2,J); 
    S:=True; 
  end; 
  Dec(I,J); 
  if I<0 then begin 
    R:=X; 
    Exit; 
  end; 
  T2:=DupChr(#48,I); 
  T1:=Y+T2; 
  T2:=#49+T2; 
  max:= Length(T1); 
  while Length(T1)>=J do begin 
    while StrCmp(X,T1)>=0 do begin 
      X:=UlSub(X,T1); 
      Result:=UlSum(Result,T2); 
    end; 
    SetLength(T1,Length(T1)-1); 
    SetLength(T2,Length(T2)-1); 
    if Assigned(OnProgress) then OnProgress(100-(Length(T1)/max)*100); 
  end; 
  R:=X; 
  if S then if Result[1]<>#48 then Result:=#45+Result; 
  if V then if R[1]<>#48 then R:=#45+R; 
end; 

Function Mul10(First:string; Second:integer):string; 
  var s:string; 
      i, j:integer; 
begin 
  if pos('.',First)=0 then 
    begin 
      s:=''; 
      For i:=0 to Second-1 do s:=s+'0'; 
      Result:=First+s; 
    end 
  else 
    begin 
      s:=''; 
      j:=length(First)-pos('.',First); 
      if (second-j)>0 then For i:=0 to Second-j-1 do s:=s+'0'; 
      First:=First+s; 
      j:=pos('.',First); 
      First:=StringReplace(First,'.','',[]); 
      insert('.',First,j+second); 
      while (length(First)>0) and (First[length(First)]='0') do delete(First,length(First),1); 
      while (length(First)>0) and (First[length(First)]='.') do delete(First,length(First),1); 
      Result:=First; 
    end; 
end; 

Function Div10(First:string; Second:integer):string; 
  var s:string; 
      i:integer; 
begin 
  s:=''; 
  For i:=0 to Second do s:=s+'0'; 
  s:=s+First; 
  Insert('.', s, length(s)-Second+1); 
  while (length(s)>0) and (s[1]='0') do delete(s,1,1); 
  if pos('.',s)>0 then 
    while (length(s)>0) and (s[length(s)]='0') do delete(s,length(s),1); 
  if (length(s)>0) and (s[length(s)]='.') then delete(s,length(s),1); 
  Result:=s; 
end; 

function UlDiv(First, Second:String; Precision:integer):String; 
begin 
  First:=Mul10(First, Precision); 
  result:=Div10(StrDiv(First, Second), Precision); 
end; 

end.

Взято с Vingrad.ru http://forum.vingrad.ru

Function ulPower(First, Second :string):string;

Это сообщение отредактировал(а) kuzyara - 13.2.2008, 18:05

--------------------

подпись

volvo877

Дата 13.2.2008, 19:55 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Комодератор
Сообщений: 2073
Регистрация: 15.11.2004

Репутация: 2
Всего: 116

kuzyara, так, на всякий случай, объясни мне, ты задание читал, или как всегда - Write-Only?

Цитата(MuForum @ 2.2.2008, 15:12

)

Как РАЦИОНАЛЬНО можно решить данную задачу именно на 'Turbo Pascal 7.1'?!

Тогда поведай мне, где взять SysUtils и динамические массивы, на которых все построено в приведенном модуле, для Турбо Паскаля? Написать самому?

Это сообщение отредактировал(а) volvo877 - 13.2.2008, 19:57

kuzyara

Дата 14.2.2008, 13:40 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 215
Регистрация: 13.11.2006

Репутация: нет
Всего: 1

а я вотЪ что ещё накапал: http://forum.vingrad.ru/forum/topic-58172/...25B0/index.html

Это сообщение отредактировал(а) kuzyara - 14.2.2008, 17:42

--------------------

подпись

Bug_Hunter

Дата 19.2.2008, 02:30 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 19
Регистрация: 19.2.2008
Где: Бл. Подмосковье

Репутация: нет
Всего: нет

Цитата(MuForum @ 2.2.2008, 16:12

)

Как РАЦИОНАЛЬНО можно решить данную задачу именно на 'Turbo Pascal 7.1'?!

Ну, для начала надо вспомнить, что 2^1000 есть единица, сдвинутая на 1000 позиций влево - представить такое число в массиве байт не составит труда. А затем надо преобразовать это число к десятичному представлению методом сдвигов и двоично-десятичной коррекции.

Все реализуемо на Турбо-Паскале применением арифметических логических операций и эффективнее, пожалуй, не возможно.

Сам алгоритм (с реализацией на Ассемблере) описан, например в книге В.К. Злобин, В.Л. Григорьев "Программирование арифметических операций в микропроцессорах".

ЗЫ: Я эту книгу случайно обнаружил в библиотеке санатория и выменял на "Сердца трех" Джека Лондона smile

- просто так не отдавали и на деньги не меняли smile

ЗЫ2: По легенде, книга эта была оставлена тому санаторию стоителями в составе документации на автоматизированную котельную smile

Bug_Hunter

Дата 19.2.2008, 14:31 (ссылка)

(нет голосов)

Загрузка ...

Во, наваял кой чего:

Код


const
  NMAX = 1000;
  WOUT = 50;

var
  a: array[0..(NMAX-1) div 3] of byte;
  n, count: word;
  len, i: word;
  carry: byte;

  s: string[127];
  lval: longint;
  ier: integer;

begin
  while TRUE do begin
    write(#13#10'N (0<=N<=',NMAX,'): '); readln(s);
    if s='' then break;
    val(s,lval,ier);
    if (ier<>0) or not ((0<=lval) and (lval<=NMAX)) then begin
      Writeln('Error!');
      continue;
      end;
    n:=lval;

    a[0]:=1; len:=1;
    count:=n;
    while count>0 do begin
      carry:=0;
      for i:=0 to len-1 do begin
        a[i]:=(a[i] shl 1)+carry;
        if a[i]>9 then begin
          a[i]:=(a[i]+6) and $0F;
          carry:=1;
          end
        else
          carry:=0;
        end;
      if carry>0 then begin
        a[len]:=1; len:=len+1;
        end;
      count:=count-1;
      end;

    write(#13#10'2^N: ');
    count:=WOUT;
    for i:=len-1 downto 0 do begin
      write(chr(ord('0')+a[i])); count:=count-1;
      if (i>0) and (count=0) then begin
        write(#13#10'     ');
        count:=WOUT;
        end;
      end;
    writeln;
    end;
end.

Хотя, возможно, можно и оптимальнее за счет того, что в отличии от преобразования произвольного двоичного числа к десятичному представлению здесь мы справа вдвигаем только нули и на этом деле возможно можно поймать какую-либо закономерность...

MuForum

Дата 3.3.2008, 01:25 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 427
Регистрация: 13.6.2007
Где: Молдова, Кишинев

Репутация: нет
Всего: 4

Цитата(Bug_Hunter @ 19.2.2008, 02:30)

Цитата(MuForum @ 2.2.2008, 16:12

)

Как РАЦИОНАЛЬНО можно решить данную задачу именно на 'Turbo Pascal 7.1'?!

- просто так не отдавали и на деньги не меняли smile

Хм, можно будет как-то с тобой связаться, очень хотелось бы данную книгу почитать.

# Некоторое время потратив, я сумел выйти на вот такой алгоритм:

Код


{****************************************************************************}
{# Developer: S@nek[BoR] }
{# Date of the creation: 5.02.2008 }
{# Description: x^n. (0<=n<=1000) }
{****************************************************************************}
Program T1;
Uses
    CRT;
{---}
Type
    num = 0..9;
    MyArr = array[1..1000] of num;
    rnx = record
        a,b: MyArr;
        x,n,len: WORD;
    end;
{---}
Var
    PRnx: rnx;
{---}
procedure Check(Var PRnx: rnx);
Begin
    with(PRnx) do
    Begin
        repeat
            ClrScr;
            Write('x = '); Readln(x);
            Write('n = '); ReadLn(n);
        until((x > 0) and (x < 10) and (n >= 0) and (n < 1001));
    end;
end;
{---}
procedure XN(Var PRnx: rnx);
Var
    i,j,k,p: WORD;
Begin
    with(PRnx) do
    Begin
        while((n mod x = 0) and ((n / x) <> 1) and ((n / x) <> 0) and ((x * x) < 10)) do
        Begin
            n := trunc(n/x);
            x := x * x;
        end;
        j := 1;
        len := 1;
        if(n<>0) then
        Begin
            a[1] := x;
            while(j < n) do
            Begin
                inc(j);
                i := 1;
                k := 0;
                while(i <= len) do
                Begin
                    p := a[i] * x;
                    b[i] := (p mod 10) + k;
                    k := (p div 10);
                    if((i = len) and (k <> 0)) then b[i+1] := k;
                    inc(i);
                end;
                if(k<>0) then inc(len);
                a := b;
            end;
        end
        else a[1] := 1;
        WriteLn;
        WriteLn('x = ',x);
        WriteLn('n = ',n);
        WriteLn('len = ',len);
        Write('Res: ');
        for i:=len downto 1 do Write(a[i]);
    end;
end;
{---}
Begin
    Check(PRnx);
    XN(PRnx);
    ReadKey;
end.

P.S. -> Сокращение степени осуществляется, только когда степень чётная(Сдесь можно оптимизировать, хотя из-за этого код возрастёт, поэтому я этого не сделал).
- Если кому-то поможет, буду рад. Так же хотелось бы услышать мнения о данном методе. (Можно ещё конечно создавать массив динамически, так как если основание меньше 10, то максимально за один такт массив может разростатся только на одну ячейку).

Это сообщение отредактировал(а) MuForum - 3.3.2008, 02:01

--------------------

"Чтобы правильно задать вопрос, нужно знать большую часть ответа!" (Р. Шекли)

Bug_Hunter

Дата 3.3.2008, 20:32 (ссылка)

(нет голосов)

Загрузка ...

Цитата(MuForum @ 3.3.2008, 01:25

)

Хм, можно будет как-то с тобой связаться, очень хотелось бы данную книгу почитать.

Должна быть в библиотеке любого технического вуза. Да вообще, она же под 8-ми разрядные микропроцессоры, там и ассемблер другой, и сами возможности микропроцессоров ограниченные - лучше поискать что-нибуть с похожим названием по каталогу. А ключевой момент в моем примере - двоично-десятичная коррекция - много где описана.
Да, я не в Молдове.

Цитата(MuForum @ 3.3.2008, 01:25

)

Некоторое время потратив, я сумел выйти на вот такой алгоритм:

Ну, если забить на то, что он не работает...

Вот тут:

Код


                    p := a[i] * x;
                    b[i] := (p mod 10) + k;
                    k := (p div 10);

Надо делать так:

Код


                    p := a[i] * x + k;
                    b[i] := (p mod 10);
                    k := (p div 10);

Цитата(MuForum @ 3.3.2008, 01:25

)

Сокращение степени осуществляется, только когда степень чётная

Ну и нафик такая оптимизация? Тем более, что ты и тут напортачил, надо так:

Код


        while (n>0) and ((n mod 2)=0) and ((x*x)<10) do
        Begin
            n := n div 2;
            x := x * x;
        end;

1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Object Pascal: кроссплатформенные технологии \| Следующая тема »