|
13.10.2009, 20:26
|
#1
|
ПроЭктировщик
Регистрация: 21.06.2009
Адрес: Беларусь, Столбцы
Сообщений: 148
Написано 32 полезных сообщений (для 57 пользователей)
|
Некоторые алгоритмы написанные на чистом 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. Быстрое возведение числа А в степень В
алгоритмы писал сам, так что они могут быть не самыми оптимальными, и написаны, не слишком красиво, полную совместимость с МП не гарантирую, может что и надо будет переписать, всётаки на чистом паскале писалось, могу написать ещё и длинную арифметику, кому надо, напишите, но на это нужно будет троху времени
|
(Offline)
|
|
13.10.2009, 20:58
|
#2
|
ПроЭктировщик
Регистрация: 21.06.2009
Адрес: Беларусь, Столбцы
Сообщений: 148
Написано 32 полезных сообщений (для 57 пользователей)
|
Ответ: Некоторые алгоритмы написанные на чистом 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.
|
(Offline)
|
|
Эти 3 пользователя(ей) сказали Спасибо _Nox_ за это полезное сообщение:
|
|
13.10.2009, 22:14
|
#3
|
Знающий
Регистрация: 26.07.2009
Адрес: Россия, Москва
Сообщений: 318
Написано 103 полезных сообщений (для 331 пользователей)
|
Ответ: Некоторые алгоритмы написанные на чистом pascal-е
Ну конечно не оптимальны, но зато принцип понятен. Понятен принцип - не проблема соптимизить.
А вот я в школе так забавлялся над системами счислений:
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;
|
(Offline)
|
|
Сообщение было полезно следующим пользователям:
|
|
13.10.2009, 22:20
|
#4
|
ПроЭктировщик
Регистрация: 21.06.2009
Адрес: Беларусь, Столбцы
Сообщений: 148
Написано 32 полезных сообщений (для 57 пользователей)
|
Ответ: Некоторые алгоритмы написанные на чистом pascal-е
Tronix у тебя ипользуются битовые сдвиги, а я пока в этом не силён, я знаю что так быстрее
|
(Offline)
|
|
13.10.2009, 22:22
|
#5
|
Модератор
Регистрация: 03.04.2007
Сообщений: 2,252
Написано 597 полезных сообщений (для 817 пользователей)
|
Ответ: Некоторые алгоритмы написанные на чистом pascal-е
Почистил.
Дальнейший флуд не приветствуется.
Алгоритмы может и не самые оптимальные, но может кому-то и пригодятся.
|
(Offline)
|
|
11.02.2010, 17:23
|
#6
|
ПроЭктировщик
Регистрация: 31.01.2010
Адрес: Россия, респ. Башкортостан, г. Бирск
Сообщений: 137
Написано 12 полезных сообщений (для 17 пользователей)
|
Ответ: Некоторые алгоритмы написанные на чистом pascal-е
А я недавно сидел над УГАТУ'шными лабораторками и смог сделать перевод из десятичной системы в любую другую. И ограничивается это всё только 35-тиричной системой счисления.
|
(Offline)
|
|
06.07.2010, 15:47
|
#7
|
AnyKey`щик
Регистрация: 02.05.2010
Сообщений: 8
Написано 0 полезных сообщений (для 0 пользователей)
|
Ответ: Некоторые алгоритмы написанные на чистом 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.
|
(Offline)
|
|
08.07.2010, 20:10
|
#8
|
ПроЭктировщик
Регистрация: 18.12.2007
Сообщений: 157
Написано 24 полезных сообщений (для 27 пользователей)
|
Ответ: Некоторые алгоритмы написанные на чистом pascal-е
Это крайне не оптимальная реализация. Если её нужно запускать один раз и для небольших чисел (до миллиона например), то не важно, но если нужно много раз в секунду или для больших чисел, то не катит совсем. Не намного сложнее сделать разложением на простые множители, а быстрее значительно.
|
(Offline)
|
|
Ваши права в разделе
|
Вы не можете создавать темы
Вы не можете отвечать на сообщения
Вы не можете прикреплять файлы
Вы не можете редактировать сообщения
HTML код Выкл.
|
|
|
Часовой пояс GMT +4, время: 22:58.
|