forum.boolean.name

forum.boolean.name (http://forum.boolean.name/index.php)
-   MidletPascal (http://forum.boolean.name/forumdisplay.php?f=46)
-   -   Некоторые алгоритмы написанные на чистом pascal-е (http://forum.boolean.name/showthread.php?t=9490)

_Nox_ 13.10.2009 20:26
Некоторые алгоритмы написанные на чистом pascal-е
 
кому надо, могу выложить:
А. сортировки:
1. пузырьком (bubble)
2. быстрая сортировка (qsort)

Б. целочисленная арифметика:
1. НОД (двух чисел)
2. НОК (двух чисел)
3. Разложение натурального числа N<=2 000 000 000 на простые множители.
6. Перевод целых чисел из одной системы счисления в другую:
01) Перевод натурального числа N<=2 000 000 000 из десятичной системы счисления в двоичную.
02) Перевод двоичного числа из набора цифр 1 и 0 в натуральное десятичное число N<=2 000 000 000.
03) Перевод двоичного числа из набора цифр 1 и 0 в шестнадцатеричное число (набор цифр шестнадцатеричного числа). Количество цифр в двоичном числе <=30
04) Перевод шестнадцатеричного числа из набора цифр 0..F в двоичное число. Количество цифр в двоичном числе <=30.
05) Перевод натурального числа N<=2 000 000 000 из десятичной системы счисления в шестнадцатеричную.
06) Перевод шестнадцатеричного числа из набора цифр 0..F в десятичное число N<=2 000 000 000.
4. Быстрое возведение числа А в степень В

алгоритмы писал сам, так что они могут быть не самыми оптимальными, и написаны, не слишком красиво, полную совместимость с МП не гарантирую, может что и надо будет переписать, всётаки на чистом паскале писалось, могу написать ещё и длинную арифметику, кому надо, напишите, но на это нужно будет троху времени

_Nox_ 13.10.2009 20:58
Ответ: Некоторые алгоритмы написанные на чистом pascal-е
 
:(

Nod

Код:
function NOD (a1,b1:int64):int64; {В мидлет паскале надо ставить integer вместо int64}
begin
  while (A1<>0) and (B1 <> 0) do
    begin
      if a1 > b1 then a1:=a1 mod b1
                else b1:=b1 mod a1;
    end;
  NOD:=a1+b1;
end;
НOK

Код:
function NOK (a2, b2 : int64):int64;
begin
NOK:=(a2 div NOD (a2,b2){<=Добавить ещё в программу NOD из пункта сверху})*b2;
end;
3. Разложение натурального числа N<=2 000 000 000 на простые множители.
Код:
program task;
var n:int64;
    mas : array [1..100] of longint;
    i,j:longint;
    a:longint;
begin
assign (input, 'input.txt'); reset (input);
assign (output, 'output.txt'); rewrite (output);
  readln (n);
  write (N, ' = ');

  i:=0;
  while n mod 2 = 0 do
    begin
      mas [i+1]:= 2;
      inc (i);
      n:=n div 2;
    end;
  a:=3;

  while (n<>1) do
    begin
      while n mod a = 0 do
        begin
          mas [i+1]:= a;
          inc (i);
          n:=n div a;
        end;
      inc (a,2);

    end;

  if i=0 then write (n)
        else for j:=1 to i do
                begin
                    write (mas [j]);
                  if j<>i then write (' * ');
                end;
  writeln;

  writeln (i);

  close (input);
  close (output);

end.
dec to bin
Код:
program dectobin;
type binmas = array [1..10000] of byte;
var Dec : int64;
    bin : binmas;
    i:longint;

procedure indata;
const infile = 'input.txt';
begin
assign (input, infile); reset (input);
readln (Dec);
close (input);
end;

procedure dec_to_bin;
begin
i:=1;
while Dec > 0 do
 begin
  bin [i]:=Dec mod 2;
  Dec:=Dec div 2;
  inc (i);
 end;
end;

procedure outdata;
const outfile = 'output.txt';
var j:longint;
begin
assign (output, outfile); rewrite (output);
for j:=i-1 downto 1 do write (bin [j]);
close (output);
end;


begin
indata;
dec_to_bin;
outdata;
end.
bin to dec
Код:
program bintodec;
type binmas = array [1..10000] of integer;
var bin : binmas;
    N : int64;
    i,j:longint;

procedure indata;
const infile = 'input.txt';
var s:string;

begin
assign (input, infile); reset (input);

i:=1;
read (s);
for j:=1 to length (s) do
  begin
  if ord (s [j]) = ord ('1') then bin [i]:=1
                              else bin [i]:=0;
  inc (i);
  end;

close (input);
end;

procedure bin_to_dec;
var t:int64;
begin
N:=0;
t:=1;
for j:=i-1 downto 1 do
  begin
    N:=N+bin [j]*t;
    if i <> j then t:=t*2;
  end;

end;

procedure outdata;
const outfile = 'output.txt';
begin
assign (output, outfile); rewrite (output);
writeln (N);
close (output);
end;


begin
indata;
bin_to_dec;
outdata;
end.
bin to hex
Код:
program bin_to_hex;
var s,s2,t:string;
    i:integer;
begin
assign (input, 'input.txt'); reset (input);
assign (output, 'output.txt'); rewrite (output);

readln (S);
for i:=length (s) downto 1 do
  begin
  t:=s[i] + t;
  if i=1 then
    begin
      if length (t)=1 then t:='000'+t;
      if length (t)=2 then t:='00'+t;
      if length (t)=3 then t:='0'+t;
    end;
  if length (t)= 4 then
    begin
      if t = '0000' then s2:= '0' + s2 else
      if t = '0001' then s2:= '1' + s2 else
      if t = '0010' then s2:= '2' + s2 else
      if t = '0011' then s2:= '3' + s2 else
      if t = '0100' then s2:= '4' + s2 else
      if t = '0101' then s2:= '5' + s2 else
      if t = '0110' then s2:= '6' + s2 else
      if t = '0111' then s2:= '7' + s2 else
      if t = '1000' then s2:= '8' + s2 else
      if t = '1001' then s2:= '9' + s2 else
      if t = '1010' then s2:= 'A' + s2 else
      if t = '1011' then s2:= 'B' + s2 else
      if t = '1100' then s2:= 'C' + s2 else
      if t = '1101' then s2:= 'D' + s2 else
      if t = '1110' then s2:= 'E' + s2 else
      if t = '1111' then s2:= 'F' + s2;
      t:='';
    end;
  end;

writeln (s2);

close (input);
close (output);
end.
hex to bin
Код:
program hex_to_bin;
var hex_str, bin_str:string;
    i:integer;
begin
assign (input, 'input.txt'); reset (input);
assign (output, 'output.txt'); rewrite (output);

readln (hex_str);

for i:=1 to length (hex_str) do
  begin
    case hex_str [i] of
      '0' : bin_str := bin_str + '0000';
      '1' : bin_str := bin_str + '0001';
      '2' : bin_str := bin_str + '0010';
      '3' : bin_str := bin_str + '0011';
      '4' : bin_str := bin_str + '0100';
      '5' : bin_str := bin_str + '0101';
      '6' : bin_str := bin_str + '0110';
      '7' : bin_str := bin_str + '0111';
      '8' : bin_str := bin_str + '1000';
      '9' : bin_str := bin_str + '1001';
      'A' : bin_str := bin_str + '1010';
      'B' : bin_str := bin_str + '1011';
      'C' : bin_str := bin_str + '1100';
      'D' : bin_str := bin_str + '1101';
      'E' : bin_str := bin_str + '1110';
      'F' : bin_str := bin_str + '1111';
    END;

  end;

close (input);
close (output);
end.
dec to hex
Код:
program dec_to_hex;
type binmas = array [1..10000] of byte;
var Decc : int64;
    bin : binmas;
    bins: string;
    Hex : string;
    i,j:longint;
    ss:string;

procedure indata;
const infile = 'input.txt';
begin
assign (input, infile); reset (input);
readln (Decc);
close (input);
end;

procedure dec_to_bin;
begin
i:=1;
while Decc > 0 do
 begin
  bin [i]:=Decc mod 2;
  Decc:=Decc div 2;
  inc (i);
 end;
end;


procedure bin_to_hex;
var t : string;
    a : integer;
begin
assign (output, 'output.txt'); rewrite (output);
t:='';
for a:=length (bins) downto 1 do
  begin
  t := bins [a] + t;
  if a = 1 then
    begin
      if length (t)=1 then t:='000'+t;
      if length (t)=2 then t:='00'+t;
      if length (t)=3 then t:='0'+t;
    end;
  if length (t)= 4 then
    begin
      if t = '0000' then Hex:= '0' + Hex else
      if t = '0001' then Hex:= '1' + Hex else
      if t = '0010' then Hex:= '2' + Hex else
      if t = '0011' then Hex:= '3' + Hex else
      if t = '0100' then Hex:= '4' + Hex else
      if t = '0101' then Hex:= '5' + Hex else
      if t = '0110' then Hex:= '6' + Hex else
      if t = '0111' then Hex:= '7' + Hex else
      if t = '1000' then Hex:= '8' + Hex else
      if t = '1001' then Hex:= '9' + Hex else
      if t = '1010' then Hex:= 'A' + Hex else
      if t = '1011' then Hex:= 'B' + Hex else
      if t = '1100' then Hex:= 'C' + Hex else
      if t = '1101' then Hex:= 'D' + Hex else
      if t = '1110' then Hex:= 'E' + Hex else
      if t = '1111' then Hex:= 'F' + Hex;
      t:='';
    end;
  end;

writeln (hex);

close (output);
end;




begin
indata;
dec_to_bin;
bins:='';
for j:=i-1 downto 1 do
  begin
    str (bin[j],ss);
    bins:=bins+ss;
  end;
bin_to_hex;
end.

hex to dec
Код:
program hex_to_dec;
type binmas = array [1..10000] of integer;
var hex_str:string;
    bin_str:string;
        bin:binmas;
    i,j:longint;
    t,n:int64;
begin
assign (input, 'input.txt'); reset (input);
assign (output, 'output.txt'); rewrite (output);
readln (hex_str);

bin_str:='';
for i:=1 to length (hex_str) do
  begin
    case hex_str [i] of
      '0' : bin_str := bin_str + '0000';
      '1' : bin_str := bin_str + '0001';
      '2' : bin_str := bin_str + '0010';
      '3' : bin_str := bin_str + '0011';
      '4' : bin_str := bin_str + '0100';
      '5' : bin_str := bin_str + '0101';
      '6' : bin_str := bin_str + '0110';
      '7' : bin_str := bin_str + '0111';
      '8' : bin_str := bin_str + '1000';
      '9' : bin_str := bin_str + '1001';
      'A' : bin_str := bin_str + '1010';
      'B' : bin_str := bin_str + '1011';
      'C' : bin_str := bin_str + '1100';
      'D' : bin_str := bin_str + '1101';
      'E' : bin_str := bin_str + '1110';
      'F' : bin_str := bin_str + '1111';
    END;
  end;

for j:=1 to length (bin_str) do
  begin
  if ord (bin_str [j]) = ord ('1') then bin [i]:=1
                                    else bin [i]:=0;
  inc (i);
  end;

t:=1;
N:=0;
for j:=i-1 downto 1 do
  begin
    N:=N+bin [j]*t;
    if i <> j then t:=t*2;
  end;
writeln (N);
close (input);
close (output);
end.
Сортировки

1. Пузырьком
Код:
program bubble;
var mas: array [1..1000] of longint;
    n:longint;

procedure indata;
const infile = 'input.txt';
var i:longint;
begin
  assign (input, infile); reset (input);

  readln (N);
  for i:=1 to n do read (mas [i]);

  close (input);
end;

procedure outdata;
const outfile = 'output.txt';
var i:longint;
begin
  assign (output, outfile); rewrite (output);

  for i:=1 to n do write (mas [i], ' ');

  close (output);
end;

procedure sort;
var i,j:longint;
    cc:longint;
    p:boolean;
begin
p:=true;
for i:=1 to n-1 do
  begin
    {if p=false then break;
    p:=false;}
    for j:=1 to n-i do
      begin

        if mas [j]<mas [j+1] then
          begin
            p:=true;
            cc:=mas [j];
            mas [j]:=mas [j+1];
            mas [j+1]:=cc;
          end;
      end;
  end;
end;

begin
indata;

sort;

outdata;
end.
2. Быстрая сортировка (qsort)
Код:
program qsort;
var mas: array [1..1000] of longint;
    n:longint;

procedure indata;
const infile = 'input.txt';
var i:longint;
begin
  assign (input, infile); reset (input);
   
  readln (N);
  for i:=1 to n do read (mas [i]); 

  close (input);
end;

procedure outdata;
const outfile = 'output.txt';
var i:longint;
begin
  assign (output, outfile); rewrite (output);
   
  for i:=1 to n do write (mas [i], ' '); 

  close (output);
end;

procedure qsort (l,r:longint);
var i,j,m,cc:longint;
begin
i:=l;
j:=r;
m:=mas [(i+j) div 2];
while i<j do
  begin
    while mas [i]<m do inc (i);
    while mas [j]>m do dec (j);
      if i<=j then
        begin
          cc:=mas [i];
          mas [i]:=mas [j];
          mas [j]:=cc;
          inc (i);
          dec (j);
        end;
  end;
if i<r then qsort (i,r);
if l<j then qsort (l,j);
end;

begin
indata;
qsort (1,N);
outdata;
end.
быстрое возведение в степень
Код:
program task;
var a, b:int64;

function power (a,b:int64): int64;
var tmp:int64;
begin
if b = 1 then power := a else
  begin
    tmp:= power (a, b div 2);
    if b mod 2 = 0 then power:= tmp*tmp
                  else        power:= tmp*tmp*a;
  end;
end;


begin
assign (input, 'input.txt'); reset (input);
readln (a,b);
close (input);

assign (output, 'output.txt');  rewrite (output);
writeln (power (a,b));
close (output);
end.

Tronix 13.10.2009 22:14
Ответ: Некоторые алгоритмы написанные на чистом pascal-е
 
Ну конечно не оптимальны, но зато принцип понятен. Понятен принцип - не проблема соптимизить.
А вот я в школе так забавлялся над системами счислений:
PHP код:
Function Dec2Bin(N: Word): String;
Var
   b : Byte;
   S : String;
   T : Byte;
Begin
     S := '';
     T := 0;
     For b := 15 downto 0 do
         Begin
              If N and (1 shl b) = 0 then S := S+'0' else S := S+'1';
              Inc(T);
              If (T Mod 4 = 0) and (t < 14) then S := S+'.';
         End;
     Dec2Bin := S;
End;

Function Dec2Hex(N: Word): String;
Const
     HD : Array [0..15] of Char = ('0','1','2','3','4','5','6','7',
                                   '8','9','A','B','C','D','E','F');
Begin
     Dec2Hex := (HD[Hi(N) shr 4]+HD[Hi(N) and $F])+
                (HD[Lo(N) shr 4]+HD[Lo(N) and $F])+'h';
End;

Function Dec2Oct(N: Word): String;
Var
   Mas : String;
   B,BB: Word;
   I   : Byte;
   C   : Char;
Begin
     I := 1;
     B := N;
     Repeat
           BB := B div 8;
           Mas[i] := Chr((B - (8 * BB))+48);
           B := BB;
           Inc(I);
     Until B < 8;
     Mas[i] := Chr(B+48);
     Mas[0] := Chr(I);
     For I := 1 to Ord(Mas[0]) shr 1 do
         Begin
              C := Mas[i];
              Mas[i] := Mas[Length(Mas)-I+1];
              Mas[Length(Mas)-I+1] := C;
         End;
     Dec2Oct := Mas;
End;

Function BinAndOct2Dec(N: String; Os: Byte): String;
Function Stepen(B,D: Byte): Word;
Var
   P : Word;
   II : Byte;
Begin
     P := 1;
     If D <> 0 then For II := 1 to D do P := P*B else P := 1;
     Stepen := P;
End;

Var
   S    : Word;
   I    : Byte;
   T    : String;
Begin
     S := 0;
     For I := 1 to Length(N) do
         Begin
              S := S+((Ord(N[i])-48)*Stepen(Os,Length(N)-I));
         End;
     Str(S,T);
     BinAndOct2Dec := T;
End;

Function Hex2Dec(N : String): String;
Const
  HexDigit   : Array [0..15] of Char = '0123456789ABCDEF';
  BinNibbles : Array [0..15] of String[4] = (
    '0000', '0001', '0010', '0011',
    '0100', '0101', '0110', '0111',
    '1000', '1001', '1010', '1011',
    '1100', '1101', '1110', '1111');

Var
   I,J  : Byte;
   S    : String;
Begin
     S := '';
     For I := 1 to Length(N) do
         Begin
              For J := 0 to 15 do If UpCase(N[i]) = HexDigit[J] then
                  S := S+BinNibbles[J];
         End;
     Hex2Dec := BinAndOct2Dec(S,2);
End; 

_Nox_ 13.10.2009 22:20
Ответ: Некоторые алгоритмы написанные на чистом pascal-е
 
Tronix у тебя ипользуются битовые сдвиги, а я пока в этом не силён, я знаю что так быстрее

ViNT 13.10.2009 22:22
Ответ: Некоторые алгоритмы написанные на чистом pascal-е
 
Почистил.
Дальнейший флуд не приветствуется.
Алгоритмы может и не самые оптимальные, но может кому-то и пригодятся.

Ksanatos 11.02.2010 17:23
Ответ: Некоторые алгоритмы написанные на чистом pascal-е
 
А я недавно сидел над УГАТУ'шными лабораторками и смог сделать перевод из десятичной системы в любую другую. И ограничивается это всё только 35-тиричной системой счисления.

Xao 06.07.2010 15:47
Ответ: Некоторые алгоритмы написанные на чистом pascal-е
 
расчёт функции Эйлера для числа N
Код:
function gcd (A,B: longint): longint;
begin
  while (A <> B) do
  begin
    if (A > B) then
      Dec(A, B)
    else
      Dec(B, A);
  end;
  gcd := A;
end;
 
var
  N: longint;
  I,A: longint;
 
begin
  ReadLn (N);
  A := 0;
  for I := 1 to N-1 do
    if (gcd(I, N) = 1) then
      Inc (A);
  WriteLn (A);
  ReadLn;
end.

cHeRsAnYa 08.07.2010 20:10
Ответ: Некоторые алгоритмы написанные на чистом pascal-е
 
Это крайне не оптимальная реализация. Если её нужно запускать один раз и для небольших чисел (до миллиона например), то не важно, но если нужно много раз в секунду или для больших чисел, то не катит совсем. Не намного сложнее сделать разложением на простые множители, а быстрее значительно.


Часовой пояс GMT +4, время: 12:52.

vBulletin® Version 3.6.5.
Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Перевод: zCarot