Функция НОД:integer Aлгоритма Эвклида
function NOD(a, b: longint): longint; begin while (a <> 0) and (b <> 0) do if a > b then a:= a - b else b:= b - a; nod:= a + b; end;
Функция НОД:integer. Оптимизация алг. Эвклида
function NOD(a, b: longint): longint; begin while (a <> 0) and (b <> 0) do if a > b then a:= a mod b else b:= b mod a; nod:= a + b; end;
Функция НОK:integer
function NOK(m,n:integer):integer; begin NOK:=(m*n) div NOD (m,n); end;
Kод: НОД и НОК для N чисел
for i:=1 to s do read(f_in,mass[i]); g:=mass[1]; for i:=2 to s do g:=NOD(g, mass[i]); k:=NOK(mass[1],mass[2]); for i:=3 to s do k:=NOK(k,mass[i]);
Пример: Разбивка числа на цифры. Вывод в обратном порядке
var i,q : longint; procedure to_dec(i,q : longint); begin while i<>0 do begin q:=i mod 10; writeln(q); i:=i div 10; end; end; BEGIN read(i); to_dec(i,q); readln; END.
Пример: Разбивка числа на цифры. Прямой вывод:Array
var n:longint; a:array[1..10] of byte; i,k,x:byte; begin write('n='); readln(n); n:=abs(n); k:=0; while n>0 do begin k:=k+1; a[k]:=n mod 10;//собираем в массив с конца n:=n div 10; end; for i:=1 to k div 2 do begin x:=a[i]; a[i]:=a[k-i+1];//переворачиваем a[k-i+1]:=x; end; writeln('Массив цифр:'); for i:=1 to k do write(a[i],' '); readln end.
Функция: Число в обратном порядке
function invers_dec(i: int64): int64; var p: int64; s: int64; q: byte; tm: int64; begin tm := i; p := 1; while tm <> 0 do begin q := tm mod 10; tm := tm div 10; p := p * 10; end; p := p div 10; s := 0; while i <> 0 do begin q := i mod 10; s := s + q * p; p := p div 10; i := i div 10; end; invers_dec := s; end;
Пример: Перевод числа в двоичную систему:string
var r:integer; function ToBin(var x: integer): string; var rez: string; y: integer; begin rez := ''; y := x; while y>=1 do begin if (y mod 2 = 0) then rez := '0' + rez else rez := '1' + rez; y := y div 2; end; ToBin := rez; end; BEGIN readln(r); writeln(toBin(r)); END.
Пример: Перевод числа в двоичную систему: Array
var b:array [1..255] of integer; a,i,n:integer; begin write('A='); readln(a); i:=0; while a>=1 do begin i:=i+1; b[i]:=a mod 2; a:=a div 2; end; n:=i; for i:=n downto 1 do write(b[i]:3); readln; end.
Пример: Перевод числа с двоичной в десятичную систему:string
var bin: string; function pow2(m: byte):integer; var i: byte; p: integer; begin p := 1; for i := 1 to m do p := p * 2; pow2:=p; end; function ToDec(var x: string): integer; var y: string; rez: real; i,t: integer; begin y := x; rez := 0; for i:=0 to length(y)-1 do begin t := StrToInt(y[Length(y) - i]); rez := rez + t*pow2(i); end; ToDec := Round(int(rez)); {Функция int() - захватывает целую часть числа, функция Round() - округление числа до целых} end; BEGIN readln(bin); writeln(ToDec(bin)); END.
Функция: Проверка, простое ли число
function isPrime(a : longint): boolean; var i : integer; f : boolean; begin f := true; for i := 2 to round(sqrt(a)) do if a mod i = 0 then begin f := false; break; end; isPrime := f; end;
Пример: Генератор простых чисел от 1 до 100
var counter:integer; function isPrime(a : longint): boolean; var i : integer; f : boolean; begin f := true; for i := 2 to round(sqrt(a)) do if a mod i = 0 then begin f := false; break; end; isPrime := f; end; BEGIN For counter:=1 to 100 do if isPrime(counter) then write(counter:3); readln; END.
Пример: Разложение числа на простые множители
var n,k:integer; begin readln(n); k:=2; while n<>1 do begin n:=n div k; Writeln(n,' ',k); if (n mod k<>0) then k:=k+1; end; readln; end.
Пример: Проверка на перевертыш. Проще
var s1,s2:string; i:integer; begin readln(s1); s2:=''; for i:=length(s1) downto 1 do begin s2:=s2+s1[i]; end; if s1=s2 then writeln(s1, ' - Yes') else writeln(s1, ' - No'); end.
Функция: Расстояние между точками:real
function dl(x1,y1,x2,y2:integer):real; begin dl:=sqrt(sqr(x2-x1)+sqr(y2-y1)); end;
Функция: Максимум из двух чисел:real
function max(a,b:real):real; begin If a>b then max:=a else max:=b; end;
Функция: Максимум из трёх чисел:real
function max(a,b,c:real):real; var t:real; begin if a>b then t:=a else t:=b; if t>c then max:=t else max:=c; end;
Функция: Площадь треугольника заданного координатами вершин:real
function Area(xa,ya,xb,yb,xc,yc:integer):real; var l1,l2,l3,p:real; begin l1:=sqrt(sqr(xa-xb)+sqr(ya-yb)); l2:=sqrt(sqr(xb-xc)+sqr(yb-yc)); l3:=sqrt(sqr(xc-xa)+sqr(yc-ya)); p:=(l1+l2+l3)/2; Area:=sqrt(p*(p-l1)*(p-l2)*(p-l3)); end;
Пример: Сортировка массива. Пузырек
const m = 10; var arr: array[1..m] of integer; i, j, k: integer; begin randomize; write ('Исходный массив: '); for i := 1 to m do begin arr[i] := random(99); write (arr[i]:3); end; Writeln; writeln('***********************'); for i := 1 to m-1 do for j := 1 to m-i do if arr[j] > arr[j+1] then begin k := arr[j]; arr[j] := arr[j+1]; arr[j+1] := k end; write ('Отсортированный массив: '); for i := 1 to m do write (arr[i]:3); Writeln; writeln('Press Enter to Exit'); readln; end.
Пример: Сортировка массива. Перестановка
const nmax=10; var arr:array[1..nmax] of integer; i,j,x:integer; begin randomize; writeln ('Исходный массив: '); for i := 1 to nmax do begin arr[i] := random(99); write (arr[i]:3); end; writeln; writeln('***********************'); for i:=1 to nmax-1 do for j:=i+1 to nmax do if arr[i]>arr[j] then begin x:=arr[i]; arr[i]:=arr[j]; arr[j]:=x; end; writeln ('Отсортированный массив: '); for i := 1 to nmax do write (arr[i]:3); writeln; writeln('Press Enter to Exit'); readln; end.
Пример: Генератор чисел Фибоначчи:Array
const n=10; var a:array[1..n]of int64; i:integer; begin a[1]:=1;// fib[0]=1 a[2]:=1; Write(a[1],' ',a[2]); for i:=3 to n do begin a[i]:=a[i-1]+a[i-2]; write(a[i]:3); end; Writeln; writeln('Press Enter to Exit'); readln; End.
Пример: Генератор чисел Фибоначчи:Прямое вычисление
var a,b,c,i,n: integer; begin write('n = '); readln(n); a := 0; write(a,' '); b := 1; write(b,' '); for i:=3 to n do begin write(a+b,' '); c := b; b := a + b; a := c end; readln end.
Функция: Проверка на перевертыш(палиндром)
function isPalindrom(a : longint): boolean; var m : array [1..20] of byte; f : boolean; i, c : integer; begin f := true; c := 0; while a <> 0 do begin c := c + 1; m[ c ] := a mod 10; a := a div 10; end; for i := 1 to c div 2 do if m[i] <> m[ c - i + 1 ] then begin f := false; break; end; isPalindrom := f; end;
Функция: Генератор перестановок
{ http://www.cyberforum.ru/pascalabc/thread138180.html Алгоритм Нарайаны — нерекурсивный алгоритм, генерирующий по данной перестановке следующую за ней перестановку (в лексикографическом порядке). Придуман индийским математиком Пандитом Нарайаной в XIV веке. Каждая следующая перестановка строится следующим образом: На первом шаге программы, двигаясь с конца массива, сравниваем соседние элементы, если предыдущий (по расположению в массиве) элемент больше следующего, двигаемся дальше, если меньше, останавливаемся и запоминаем его номер (m), этот элемент будет изменен (на этом шаге он отмечается красным треугольником снизу, а потом просто красным цветом). Элементы, стоящие слева от m-го, не изменяем (они станут окрашенными в серый цвет). Среди элементов, стоящих справа, нужно выбрать элемент (k), который должен встать на место m-го. Это минимальный элемент среди тех, которые больше m-го (отмечается синим треугольником, потом просто синим цветом). Меняем m-ый и k-ый элементы. Осталось упорядочить по возрастанию элементы, стоящие справа от нового m-го элемента, но т.к. они упорядочены по убыванию, достаточно их обернуть (оборачиваемая часть обозначена стрелками). } var RS: String; function StRevers(St: String): String; var ii: Longint; St0: String; begin St0 := ''; for ii := length(St) downto 1 do St0 := St0 + St[ii]; StRevers := St0; end; function LexNext(S: String): String; var len, m, k, t: Longint; Sch: Char; cs: String; flag: Boolean; begin len := Length(S);flag := True; for m := len - 1 downto 1 do if S[m] < S[m + 1] then Break; for k := len downto m + 1 do if S[k] > S[m] then begin flag := False; Break; end; if flag then LexNext := '' else begin for t := len downto m + 1 do if (S[t] > S[m]) and (S[t] <= S[k]) then k := t; cs := S; Sch := cs[m]; cs[m] := cs[k]; cs[k] := Sch; LexNext := Copy(cs, 1, m) + StRevers(Copy(cs, m + 1, len - m)); end; end; begin RS := '1234'; while RS <> '' do begin Writeln(RS); RS := LexNext(RS); end; end.
Функция Pow:real Возведение в степень
uses crt; var n, p: integer; function Pow(n, p: integer): real; var t: int64; i, p1: integer; begin p1 := abs(p); t := 1; for i := 1 to p1 do t := t * n; if p < 0 then pow := 1 / t; if p=0 then pow:=1; if p>0 then pow := t; end; begin readln(n, p); writeln(pow(n, p)); end.
Сообщить об опечатке
Текст, который будет отправлен нашим редакторам: