Статьи :Операционные системы :Железо :
OS FAQ :
Кодинг : |
Новости :Примеры решения задач...
Примеры решения задач...
Материал подготовил(и): AlaRic 1. Задан массив A из 100 чисел. Описать функцию для определения количества нечетных чисел среди его первых N элементов. В качестве параметров взять A и N. Если нечетных нет, то результат функции - число 7777777.
CODE
uses crt;
var a:array[1..100] of integer; i,n:integer; function Nech(b:array of integer; m:integer):word; var k,j:integer; begin k:=0; j:=0; for j:=1 to m do begin if b[j] mod 2<>0 then k:=k+1; end; if k=0 then Nech:=7777 else Nech:=k; end; begin ClrScr; Randomize; for i:=1 to 100 do begin a[i]:=random(9)+1; write(a[i]:2); end; writeln; write('Input n -> ');readln(n); writeln('Output -> ',Nech(a,n)); readln; end. 2. Задан двумерный целочисленный массив G размером 10 на 10 элементов. Написать процедуру для определения числа тех строк массива, которые не содержат чисел из первой строки.
CODE
uses crt;
const n=5;{ Размерность массива } var a:array[1..n,1..n] of integer; q:array[1..n] of integer; i,j,k,y,t:integer; b:boolean; begin ClrScr; Randomize; {=== Заполняем массив ===} for i:=1 to n do begin for j:=1 to n do begin a[i,j]:=random(99)+1; write(a[i,j]:4); end; writeln; end; {--------- Begin --------} k:=0;t:=1; for i:=2 to n do begin b:=true; for j:=1 to n do begin for y:=1 to n do if a[i,j]=a[1,y] then begin b:=false; break; end; end; if b then begin k:=k+1; q[t]:=i; t:=t+1; end; end; {---------- End ---------} writeln('Таких строк: ',k); write('Вот их номера: ');for i:=1 to t-1 do write(q[i],' '); readln; end. 3. Даны 2 матрицы A(M,N) и B(N,N). Подсчитать и вывести на экран общее количество отрицательных элементов, определить в какой из матриц среднее арифметическое значение прочих элементов имеет большую величину.
CODE
program too_matrix;
const m=4; n=5; var A:array[1..m,1..n] of integer; B:array[1..n,1..n] of integer; i,j,Sa,Sb,k: integer; ka,kb : integer; SredA,SredB: real; begin k:=0; ka:=0; kb:=0; for i:=1 to m do begin for j:=1 to n do begin a[i,j]:=random(10)-5; write(a[i,j]:3); if a[i,j]<0 then begin k:=k+1; ka:=ka+1; Sa:=Sa+abs(a[i,j]); end; end; writeln; end; writeln; for i:=1 to n do begin for j:=1 to n do begin b[i,j]:=random(10)-5; write(b[i,j]:3); if b[i,j]<0 then begin k:=k+1; kb:=kb+1; Sb:=Sb+abs(b[i,j]); end; end; writeln; end; writeln('Elements < 0: ',k); if ka<>0 then SredA:=Sa/ka; if kb<>0 then SredB:=Sb/kb; if SredA>SredB then writeln('В массиве A среднее арифметическое отрицательных элементов больше.') else if SredB>SredA then writeln('В массиве B среднее арифметическое отрицательных элементов больше.') else writeln('Одинаково!'); readln; end. 4. Дан вещественный массив X(M) найти элемент массива, значение которого наиболее близко к какому нибудь целому числу.
CODE
program n_2;
const m=10; var x : array[1..m] of real; i,index : integer; min,res : real; begin for i:=1 to m do begin write('x[',i,']='); readln(x[i]); end; min:=1; for i:=1 to m do begin if frac(x[i])>=0.5 then res:=1-frac(x[i]) else res:=1-(1-frac(x[i])); if res min:=res; index:=i; end; end; write('Output: ',x[index]:0:3); readln; end. 5. Составить программу, выводящую на экран номера элементов массива, кратных четырем.
CODE
program Mod4;
const n=8; { Размерность массива } var i : byte; a : array [1..n] of integer; begin { Заполнение массива } for i:=1 to n do begin write('a[',i,']='); readln(a[i]); end; for i:=1 to n do if a[i] mod 4 = 0 then write(i,' '); readln; end. 6. Составить алгоритм и программу для сортировки массива по следующему принципу следования элементов: максимальный элемент, минимальный элемент, 2й по величине, предпоследний, 3й по величине, 3й с конца и т.д.
CODE
program Sort_Mas;
const n=8; { Размерность массива } var i,j : byte; { Счетчики в циклах } imin: byte; { Индекс минимального элемента } k,c : integer; min : integer; { Минимальный элемент } a : array [1..n] of integer; begin { Заполнение массива } for i:=1 to n do begin write('a[',i,']='); readln(a[i]); end; { Пузырьковая сортировка по возрастанию } for i:=2 to n do for j:=n downto i do begin if a[j-1]>a[j] then begin c:=a[j-1];a[j-1]:=a[j];a[j]:=c; end; end; { Ставим максимальные элементы на нужные позиции } i:=1;k:=n; while k>(n div 2)+1 do begin c:=a[i]; a[i]:=a[k]; a[k]:=c; i:=i+2; k:=k-1; end; { Ставим минимальные элементы на нужные позиции } i:=2;k:=0; while k<(n div 2) do begin min:=a[i-1];imin:=i-1; for j:=i-1 to n do if a[j] a[i]:=a[imin]; a[imin]:=c; i:=i+2; k:=k+1; end; { Вывод отсортированного массива } for i:=1 to n do write(a[i],' '); readln; end. 7. Задача: определить номер минимального элемента заданного одномерного массива.
CODE
uses crt;
const Len = 10 var mas: array[1 .. Len] of integer; min, n, i:integer; begin { заполняем массив } randomize; for i:=1 to Len do mas[i]:=random(100); { собственно сортировка } min:=mas[1]; {начальный минимальный эл-т} for i := 1 to Len do begin if min n:=i; end; end; { В n содержится номер минимального элемента } end. Материал подготовил(и): AlaRic 8. Даны 10 вещественых чисел. Определить наибольшее из отрицательныхчисел, округлить его к ближайшему целому.
CODE
program desyat;
var a:array[1..10] of real; min:real; i:integer; begin writeln('Ввести 10 чисел'); for i:=1 to 10 do read(a[i]); min:=a[1]; for i:=2 to 10 do if (min>a[i]) and (a[i]<0) then min:=a[i]; writeln('Ответ: ',round(min)); end. 9. Ввести два вещественых числа aи b. Найти остаток от деления aи b. Определить принадлежность остатка интервалу [0 .. 4].
CODE
program dva;
var q,a,b,c:real; begin writeln('Ввести A'); readln(a); writeln('Ввести B'); readln(B); c:=a/b; q:=a-(b*trunc( c )); if (q>=0) or (q<=4) then writeln('Принадлежит отрезку'); writeln('Остаток: ',q:3:1); end. 10. Вводятся различные целые числа. Надо определить четные и нечетные. Результат вывести на экран.
CODE
Program by_Deadly;
Uses crt; Var massiv:array[1..10] of longint; x:byte; Begin for x:=1 to 10 do begin write('massiv[',x,']:=? '); readln(massiv[x]); end; ClrScr; for x:=1 to 10 do begin if odd(massiv[x])=true then writeln('massiv[',x,']=',massiv[x],' - Нечетное число') else writeln('massiv[',x,']=',massiv[x],' - Четное число'); end; End. 11. Нужно преобразовать матрицу, осуществив поворот элементов вокруг ее центра на 90 градусов против часовой стрелки.
CODE
const n = 3;
var a, b : array[1..n, 1..n] of byte; i, j : integer; begin { ввод матрицы } writeln('input your matrix ', n, ' x ', n); for i:=1 to n do for j:=1 to n do read(a[i,j]); { переворот } for i:=1 to n do for j:=1 to n do b[n-j+1,i]:=a[i,j]; { вывод матрицы } writeLn; for i:=1 to n do begin for j:=1 to n do write(B[i,j],' '); writeln end; end. 12. Задать двумерный массив n*n. Посчитать число элементов бОльших, мЕньших, равных нулю. Вывести исходный массив элементов в виде таблицы и результаты вычислений.
CODE
uses crt;
const n=10; var mas:array[1..n,1..n] of integer; i,j,max,min,nol:integer; begin randomize; clrscr; min:=0; max:=0; nol:=0; for i:=1 to n do begin for j:=1 to n do begin mas[i,j]:=random(20)-10; if mas[i,j]>0 then max:=max+1 else if mas[i,j]<0 then min:=min+1 else nol:=nol+1; write(mas[i,j],'|'); end; writeln; end; writeln; writeln('bolshe 0 - ',max); writeln('menshe 0 - ',min); writeln('ravnih 0 - ',nol); end. 13. Как расположить элементы отсортированной матрицы в ввиде "улитки"?
CODE
const m = 5;
var a: array[1..m, 1..m] of integer; i, j, di, dj, n : integer; min_i, min_j, max_i, max_j : integer; begin i:=1; j:=m; dj:=-1; di:=0; A[i,j]:=1; min_i:=2; min_j:=1; max_i:=m; max_j:=m; for n:=2 to m*m do begin {1} if (dj<>0) and (j+dj < min_j) then begin dj:=0; di:=1; inc(min_j) end else {2} if (di<>0) and (i+di > max_i) then begin di:=0; dj:=1; dec(max_i) end else {3} if (dj<>0) and (j+dj > max_j) then begin dj:=0; di:=-1; dec(max_j) end else {4} if (di<>0) and (i+di < min_i) then begin di:=0; dj:=-1; inc(min_i) end; inc(i, di); inc(j, dj); A[i,j]:=n end; end. Материал подготовил(и): AlaRic Разбор задач:
14 . Даны натуральное число N и последовательность A1, A2, ... An, состоящая из N целых чисел. Получить последовательность, которая отличается от исходной тем, что все нечетные элементы удвоены. Оба массива вывести на экран.
Код
program N1;
const n=10; var i:integer; a:array[1..n] of integer; begin for i:=1 to n do begin a[i]:=random(9)+1;write(a[i],' '); end; writeln; for i:=1 to n do begin if a[i] mod 2<>0 then a[i]:=a[i]*2; write(a[i],' '); end; readln; end. 15 . Даны натуральное число N и последовательность A1, A2, ... An. Определить количество вхождений N в данную последовательность (N – вводится с клавиатуры).
Код
program N2;
var i,n,k:integer; a:array[1..100] of integer; begin write('Input n (n<=100) -> ');readln(n); k:=0; for i:=1 to n do begin write('-> '); readln(a[i]); if a[i]=n then k:=k+1; end; write(k); readln; end. 16 . Даны натуральное число N и последовательность A1, A2, ... An. Определить наименьшее положительное среди A1, A2, ... An и найти сумму отрицательных.
Код
program N3;
const n=10; var i,min,S:integer; a:array[1..n] of integer; begin S:=0; for i:=1 to n do begin a[i]:=random(10)-5; write(a[i],' '); end; min:=32767; for i:=1 to n do begin if a[i]>0 then if a[i] end; writeln; writeln('Min pol -> ',min); writeln('Summ otriz -> ',S); readln; end. 17 . Дана последовательность из 50 чисел. Найти их среднее арифметическое. Найти сколько среди них отличных от последнего числа
Код
program N4;
uses crt; const n=10; var a:array[1..n] of integer; i,S,k:integer; begin ClrScr; S:=0; k:=0; for i:=1 to n do begin a[i]:=random(10)+1; write(' ',a[i]); S:=S+a[i]; end; for i:=1 to n-1 do if a[i]<>a[n] then k:=k+1; writeln; writeln('Sred arifmet: ',(S/n):0:2); writeln('Otl ot Poslednego: ',k); readln; end. 18 . Дана последовательность из N вещественных чисел. Вычислить сумму тех элементов последовательности, номера которых совпадают со значениями элементов последовательности.
Код
program N5;
const n=10; var i,k:integer; a:array[1..n] of real; begin k:=0; for i:=1 to n do begin write('-> '); readln(a[i]); end; for i:=1 to n do if a[i]=i then k:=k+1; write('Otvet: ',k); readln; end. 19 . Дана последовательность из N вещественных чисел. Все элементы последовательности с четными номерами, предшествующие первому по порядку элементу с наибольшим значением, домножить на него.
Код
program N6;
const n=10; var a:array[1..n] of real; i,k:integer; max:real; begin for i:=1 to n do begin a[i]:=random(9)+1; write(a[i]:3:1,' '); end; for i:=1 to n do if a[i]>max then begin max:=a[i];k:=i; end; for i:=1 to k-1 do if i mod 2=0 then a[i]:=a[i]*max; writeln; for i:=1 to n do write(a[i]:3:1,' '); readln; end. 20 . Дана последовательность из N вещественных чисел. Найти номер первого вхождения данного числа в последовательность или вывести сообщение, что такого числа нет.
Код
program N7;
const n=10; var a:array[1..n] of real; i,k:integer; r:real; begin k:=0; write('Input r -> ');readln(r); for i:=1 to n do begin write('-> '); readln(a[i]); end; for i:=1 to n do if a[i]=r then begin k:=i; break; end; if k=0 then writeln('Net!') else writeln('N: ',k); readln; end. Материал взят с сайта Всё о Паскале Переборные алгоритмы
Материал подготовил(и): virt
Существует особый класс задач ,в которых ответ может быть найден только полным перебором всех вариантов решения. Поэтому необходимо иметь некоторое представление о том как решаются подобные задачи. 1)задача о ферзях : Условие : на шахматной доске размера n*n расставить n ферзей так ,что-бы они не били друг друга. Решение : диагональ первого типа: [attachmentid=1960] диагональ второго типа: [attachmentid=1961]
CODE
var up:array[2..16]of boolean; //признак занятости диагоналей первого типа down:array[-7..7]of boolean; //признак занятости диагоналей второго типа vert:array[1..8]of boolean; //признак занятости вертикали ihor:array[1..8]of integer; //номер вертикали ,на которой стоит ферзь на каждой горизонтали n:integer; function d_hod(i,j:integer):boolean; //проверка на допустимость хода в позицию (i,j) begin d_hod:=vert[j] and up[i+j] and down[i-j]; end; procedure hod(i,j:integer); //сделать ход begin ihor[i]:=j; vert[j]:=false; up[i+j]:=false; down[i-j]:=false; end; procedure o_hod(i,j:integer); //отменить ход begin vert[j]:=true; up[i+j]:=true; down[i-j]:=true; end; Нахождение одного варианта расстановки :
CODE
procedure find_one(i:integer;var q:boolean);
var j:integer; begin j:=0; repeat inc(j); q:=false; if d_hod(i,j) then begin hod(i,j); if i if not q then o_hod(i,j); end else q:=true; end; until q or (j=n); end; Нахождение всех рещений :
CODE
procedure print;
var i:integer; begin write(' ',s,' ');for i:=1 to n do write(ihor[i],' ');writeln; end; procedure find_all(i:integer); var j:integer; begin if i<=n then begin for j:=1 to n do if d_hod(i,j) then begin hod(i,j); find_all(i+1); o_hod(i,j); end; end else begin inc(s); print; end; end; 2)задача о шахматном коне : Условие : Найти количество всех вариантов обхода шахматной доски конем. Решение :
CODE
program kon_in_nm_matr_full_variants;
const _maxnm=8; dx:array[1..8]of integer=(-2,-1,1,2,2,1,-1,-2); dy:array[1..8]of integer=(1,2,2,1,-1,-2,-2,-1); var a:array[-1.._maxnm+2,-1.._maxnm+2]of integer; n,m,i,j:integer; t:longint; procedure solve(x,y,l:integer); var k,i,j:integer; begin a[x,y]:=l; if l=n*m then inc(t) else for k:=1 to 8 do begin i:=x+dx[k];j:=y+dy[k]; if a[i,j]=0 then solve(i,j,l+1); end; a[x,y]:=0; end; begin readln(n,m); for i:=-1 to n+2 do a[i,-1]:=-1; for i:=-1 to n+2 do a[i,0]:=-1; for i:=-1 to n+2 do a[i,m+1]:=-1; for i:=-1 to n+2 do a[i,m+2]:=-1; for j:=1 to m do a[-1,j]:=-1; for j:=1 to m do a[0,j]:=-1; for j:=1 to m do a[n+1,j]:=-1; for j:=1 to m do a[n+2,j]:=-1; for i:=1 to n do for j:=1 to m do a[i,j]:=0; t:=0; for i:=1 to n do for j:=1 to m do begin solve(i,j,1); end; writeln(' ',t); end. Условие : Найти один вариант обхода методом Варнсдорфа. Суть метода : при обходе коня следует ставить на поле ,из которого он может сделать минимальное количество перемещений на еще не занятые поля. Решение :
CODE
program kon_in_nm_matr_one_variant; const _maxnm=8; dx:array[1..8]of integer=(-2,-1,1,2,2,1,-1,-2); dy:array[1..8]of integer=(1,2,2,1,-1,-2,-2,-1); var a:array[-1.._maxnm+2,-1.._maxnm+2]of integer; n,m,i,j:integer; procedure solve(x,y,l:integer); var w:array[1..8]of integer; xn,yn,i,j,m1:integer; begin a[x,y]:=l; if l=n*m then begin writeln; for i:=1 to n do begin for j:=1 to m do write(a[i,j],' '); writeln; end; halt; end else begin for i:=1 to 8 do begin w[i]:=0; xn:=x+dx[i]; yn:=y+dy[i]; if a[xn,yn]=0 then begin for j:=1 to 8 do if a[xn+dx[j],yn+dy[j]]=0 then inc(w[i]); end else w[i]:=-1; end; i:=1; while i<=8 do begin m1:=1; for j:=2 to 8 do if w[j] w[m1]:=maxint; inc(i); end; end; a[x,y]:=0; end; begin readln(n,m); for i:=-1 to n+2 do a[i,-1]:=-1; for i:=-1 to n+2 do a[i,0]:=-1; for i:=-1 to n+2 do a[i,m+1]:=-1; for i:=-1 to n+2 do a[i,m+2]:=-1; for j:=1 to m do a[-1,j]:=-1; for j:=1 to m do a[0,j]:=-1; for j:=1 to m do a[n+1,j]:=-1; for j:=1 to m do a[n+2,j]:=-1; for i:=1 to n do for j:=1 to m do a[i,j]:=0; for i:=1 to n do for j:=1 to m do begin solve(i,j,1); end; end. 3)задача о лабиринте : Условие : Дано клеточное поле ,некоторые клетки заняты препятствиями. Найти количество путей от начальной точки до конечной. Решение :
CODE
program labirint_way;
const _maxn=30; dx:array[1..4]of integer=(1,0,-1,0); dy:array[1..4]of integer=(0,1,0,-1); var a:array[0.._maxn+1,0.._maxn+1]of integer; xn,yn,xk,yk:integer; i,j,n:integer; t:longint; procedure solve(x,y,k:integer); var i:integer; begin a[x,y]:=k; if (x=xk) and (y=yk) then inc(t) else for i:=1 to 4 do if a[x+dx[i],y+dy[i]]=0 then solve(x+dx[i],y+dy[i],k+1); a[x,y]:=0; end; begin fillchar(a,sizeof(a),1); read(n); for i:=1 to n do for j:=1 to n do read(a[i,j]); readln(xn,yn,xk,yk); t:=0; solve(xn,yn,1); writeln(t); end. 4)задача о парламенте : Условие : На некотором демократическом острове каждый из жителей организовал партию которую и возглавил. В каждой партии кроме президента оказался еще как минимум один член. Составить самый малочисленный парламент ,в котором будут представлены члены всех партий. Решение :
CODE
const maxn=150;
type zint=0..maxn+1; zset=set of 0..maxn; person=record man:zint; num_part:zint; part:zset; end; var a:array[zint]of person; n,mn,min,i:zint; rwork,rbest:zset; ........... procedure include(k:zint); begin rwork:=rwork+[a[k].man]; inc(mn); end; procedure exclude(k:zint); begin rwork:=rwork-[a[k].man]; dec(mn); end; procedure solve(k:zint;res,rt:zset); var i:zint; begin if rt=[] then begin if mn min:=mn; rbest:=rwork; end; end else begin i:=k; while i<=n do begin include(i); solve(i+1,res+a[i].part,rt-a[i].part); exclude(i); inc(i); end; end; end; begin init; solve(1,[],[1..n]); for i:=1 to n do if i in rbest then write(i,' '); end. 5)задача о рюкзаке : Условие : Дано - максимальный вес рюкзака . Дано n предметов имеющих свой вес и стоимость. Определить максимальную стоимость груза ,вес которого не превышает максимального веса рюкзака. Решение :
CODE
program rukzak_perebor;
const maxn=20;{?} var n,w:integer; weight,price:array[1..maxn]of integer; best,now:array[1..maxn]of integer; maxprice:longint; procedure init; var i:integer; begin read(n); read(w); for i:=1 to n do read(weight[i]); for i:=1 to n do read(price[i]); end; procedure rec(k,w:integer;st:longint); var i:integer; begin if (k>n) and (st>maxprice) then begin best:=now; maxprice:=st; end else if k<=n then for i:=0 to w div weight[k] do begin now[k]:=i; rec(k+1,w-i*weight[k],st+i*price[k]); end; end; begin init; rec(1,w,0); writeln(' ',maxprice); end. Материал подготовил(и): virt 6)задача о коммивояжёре : Условие : Имеется n городов расстояния между которыми заданы. Коммивояжеру необходимо выйти из какого-то города ,побывать во всех остальных n-1 городах точно по одному разу и вернуться в исходный город. Маршрут должен быть минимальным по длине. Решение :
CODE
const maxv=100;
var a:array[1..maxv,1..maxv]of integer; //матрица расстояний между городами b:array[1..maxv,1..maxv]of byte; way,best:array[1..maxv]of byte; nnew:array[1..maxv]of boolean; //был ли коммивояжер в данном городе bestcost:integer; n,i:integer; .................... procedure sortlines; //сортируем каждую строку матрицы А по возрастанию var k,i,j:integer; //расстояний. Однако сами элементы матрицы А не w:integer; //переставляем ,а изменяем в матрице B номера столбцов begin //матрицы А. for i:=1 to n do for j:=1 to n do b[i,j]:=j; for k:=1 to n do for i:=1 to n-1 do for j:=i+1 to n do if a[k,b[k,i]]>a[k,b[k,j]] then begin w:=b[k,i]; b[k,i]:=b[k,j]; b[k,j]:=w; end; end;
CODE
procedure solve(v,count:byte;cost:integer);
//основная процедура
var i:integer; begin if cost>bestcost then exit; if count=n then begin cost:=cost+a[v,1]; way[n]:=v; if cost bestcost:=cost; best:=way; end; exit; end; nnew[v]:=false; way[count]:=v; for i:=1 to n do if nnew[b[v,i]] then solve(b[v,i],count+1,cost+a[v,b[v,i]]); nnew[v]:=true; end; begin init; sortlines; solve(1,1,0); writeln(bestcost:4); //вывод результата for i:=1 to n do write(best[i],' ');writeln; end. Материал взят с сайта Всё о Паскале Решение уравнений различных степенейМатериал подготовил(и): volvo Очень часто при решении задач необходимо находить корни уравнений различных порядков (квадратных, кубических и т.д.) Вместо того, чтобы писать свое решение этой задачи, можно воспользоваться функциями, которые содержатся в присоединенном модуле Equation:
Код
Function solveQuadratic(Var x, y: Array Of Double): Byte; Решение квадратного уравнения вида:
QUOTE
x[0] * x^2 + x[1] * x + x[2] = 0
Результат, возвращаемый функцией - количество
действительных корней (cами корни возвращаются в y[0], y[1]).Пример использования:
CODE
{$n+}
Uses Equation; Const ax: Array[0 .. 2] Of Double = (24, -50, 25 ); Var ay: array[0 .. 2] Of Float; roots, i: Integer; Begin roots := solveQuadratic(ax, ay); Writeln( 'number of roots = ', roots ); For i := 0 To Pred(roots) Do WriteLn( 'root #', i + 1, ' = ', ay[i]:10:5 ); End.
Код
Function solveCubic(Var x, y: Array Of Double): Byte; Решение кубического уравнения:
QUOTE
x[0] * x^3 + x[1] * x^2 + x[2] * x + x[3] =
0
Результат, возвращаемый функцией - количество
действительных корней (сами корни возвращаются в y[0], y[1],
y[2]).Пример использования:
CODE
{$n+}
Uses Equation; Const ax: Array[0 .. 3] Of Float = (1, 0, -9, 4 ); Var ay: array[0 .. 3] Of Float; roots, i: Integer; Begin roots := solveCubic(ax, ay); Writeln( 'number of roots = ', roots ); For i := 0 To Pred(roots) Do WriteLn( 'root #', i + 1, ' = ', ay[i]:10:5 ); End. Для решения уравнений 4-ой степени применяются 2 функции
Код
Function PolySolve(Const order: Integer; позволяющая решать алгебраические уравнения практически любого порядка (порядок задается константой maxOrder, и изначально установлен равным 12) при помощи последовательности Штурма. Пример использования (решение уравнения 4-ой степени сначала методом Vieta, а затем - методом Штурма):
CODE
{$n+}
Uses Equation; Const Order = 4; coeffs: Array[0 .. Order] Of Double = ( 1, 0, -25, 60, -36 ); Var roots: array[0 .. maxOrder] Of Double; nroots, i: Integer; begin WriteLn('Vieta method :'); nroots := solveQuarticVieta(coeffs, roots); { nroots := solveQuarticAlgebra(coeffs, roots); } Writeln( 'number of roots = ', nroots ); For i := 0 To Pred(nroots) Do WriteLn( 'root #', i + 1, ' = ', roots[i]:7:4 ); WriteLn; WriteLn('Sturm sequence method :'); nroots := PolySolve(Order, coeffs, roots); If nroots = 0 Then Begin WriteLn('solve: no real roots'); Halt(0) End Else Begin WriteLn(nroots, ' distinct real root(s) for x: '); For i := 0 To Pred(nroots) Do WriteLn('root #', i + 1, ' = ', roots[i]:7:4); End; end. Материал взят с сайта Всё о Паскале Нахождение центра окружностиМатериал подготовил(и): Altair Задача: Найти центр описанной окружности возле произвольного многоугольника. Дано: Произвольный n-угольник. Координаты вершин. Требуется: Координаты центра описанной окружности. При: Количество углов 2 Указание: Счиать описанной окружностью, окружность с наименьшим радиусом, в которую "поместиться" (наложением) многоугольник. Материал подготовил(и): Altair
1 решение.
Суть алгоритма: искомая точка обладает следующим свойством - максимальное расстояние от нее до вершин многоугольника минимально! Вот программа под FPC, запускаем, тыкаем мышью, где разместить точки, нажимаем ENTER когда все точки ввели, прога подумает с 2 секунды и нарисует окружность. Вот код, а сама прога в присоединенном архиве
Код
{$MODE OBJFPC}
{$APPTYPE GUI} {$E+} {$E+} Uses GraphiX, GXCRT, GXMouse, GX2D; Type Telem=record X, Y:longint; end; ArrType = array[1..100] of telem; Function MaxR(TX,TY:longint; A:arrType; n:word):Extended; var R:Extended; i:longint; Begin r:=0; for i:=1 to n do begin If r end; Result:=R; end; Var Arr:ArrType; Tx,Ty,n,i,j,TSuperX,SuperY:longint; EnterB:boolean; NK:byte; TRR:Extended; Begin InitGraphix(ig_detect,ig_col16); {Инициализация графической системы} {установка графического режима - 1024*768 16 битный цвет} SetModeGraphix(1024,768,ig_col16); Bar(0,0,1024,768,rgbcolorRgb(0,0,0)); {заливаем экран черной краской} {инициализируем мышь и включаем отображение указателя} InitMouse; MouseON; EnterB:=false; n:=0; {пока не нажата клавиша ENTER} While not EnterB do begin Repeat {ждем нажатия клавиши или мыши} Until (KeyPressed) or (IsMouseInArea(0,0,1024,768)>128); If keypressed then begin NK:=ord(readkey); If NK=13 then EnterB:=true end else begin inc(N); MouseCoords(Tx,Ty); {получаем координаты курсора} delay(100); {задержка что бы не было мерцания указателя} MouseOFF; {выключаем указатель} putPixel(Tx,Ty,rgbcolorrgb(255,255,255)); {рисуем белую точку} MouseOn; {сключаем мышь} arr[n].X:=Tx; {сохраняем в массви координаты точки} arr[n].Y:=Ty; end end; TRR:=MaxR(1,1,arr,n); {поиск точки, максимальное расстояние до остальных в которой минимально} For i:=1 to 1024 do For j:=1 to 768 do begin If MaxR(i,j,Arr,n) end; end; MouseOff; circle(SuperX,SuperY,Trunc(MaxR(SuperX,SuperY,Arr,N)), rgbcolorrgb(1,118,156)); mouseon; readkey; {ожидаем нажатия клавиши} end. Материал подготовил(и): volvo
2 решение.
Вот мое решение задачи (программа написана под Delphi), но по несколько другому алгоритму:
Материал взят с сайта Всё о Паскале Динамические массивы и матрицыМатериал подготовил(и): Altair Модуль для работы с динамическими массивами. Модуль позволяет работать с массивами с динамической длинной Constructor INIT; Инициализирует массив. Требуется запустить лишь один раз - в начале работы с массивом, но после определения начальной длины Procedure SetSizeArray(_Size:word); Устанавливает длинну массива равную _Size. При первом запуске, после нее требуется запустить конструктор. Function GetSizeArray:Word; Возвращает текущую длинну массива. Лучше использовать ее и не открывать доступ к переменной sizeofarray, т.к. последствия могут быть непредсказуемые. Procedure EnteringArray(visible:Byte;VideoMode:Byte); Процедура ввода массива. Не очень надежна, т.к. нет поддержки backspace, но зато возможен ввод в графическом режиме и возможно управлять отображением вводимых чисел. (Для вывода, скажем звездочек вместо вводимых символов, ставим параметр visible=<код звездочки> Videomode может иметь RText или RGraph - соответственно ввод в текстовом и ввод в графическом режиме. Внимание: если тип режима указан неверно, произойдет ошибка периода исполнения. Procedure PrintCRTarray(Videomode:byte); Вывод на экран массива. Возможны 2 режима как и у метода для ввода массива. Procedure QSort(left,right:integer); Быстрая сортировка массива. Procedure HSort; Пирамидальная сортировка массива. Полезна если вы уверены что массив почти или полностью отсортирован. Function GetMaxElem:Telem; Возвращает максимальный элемент массива. Function GetMinElem:Telem; Возвращает мимнимальный элемент массива. Function GetNumMaxElem:Word; Возвращает номер максимального элемента в массиве. (Первого, если таких элементов несколько) Function GetNumMinElem:Word; Возвращает номер минимального элемента. Function ElemInArray(T:Telem):Word; Проверяет вхождение элемента в массив. 0 - если не найдено, иначе индекс элемента. Procedure InvertArray; Инвертирует массив. Вот программа демонстрирующая возможности модуля.
Код
Program TEST_UNIT_ARRAYS; В присоединенном файле сам модуль. (исходник). ЗЫ: при реализации динамического массива, использовался алгоритм, предложенный volvo Материал подготовил(и): volvo Работа с динамическими массивами Для того, чтобы работать с динамическими массивами, необходимо перед началом работы выделить память под такой массив, а после использования массива - освободить выделенную память: [PASCODE]{ Обязательно отключить проверку индексов, иначе возникнет ошибка времени исполнения } {$R-} Type TType = Integer; { Или любой другой тип } { Указатель на динамический массив } PDynArray = ^TDynArray; TDynArray = array[1 .. 1] of TType; Var { Через эту переменную будет осуществляться вся работа с массивом } arr: PDynArray; n, i: integer; Begin Write('n = '); ReadLn(n); { Вводится размер массива } { В "куче" запрашивается блок памяти с размером, достаточным для хранения N элементов типа TType } GetMem(arr, n * SizeOf(TType)); (*** Начало работы с массивом ***) { Обращение к элементу динамического массива - почти такое же, как и к элементу обычного (статического) массива, за исключением операции "^" - разыменования ... Пример: } For i := 1 To n Do arr^[i] := 2 * i; For i := 1 To n Do Write(arr^[i]:4); (*** Закончили работу с массивом - уничтожаем его ***) { Возвращаем память назад в "кучу" } FreeMem(arr, n * SizeOf(TType)); End.[/PASCODE] Еще один модуль для работы с динамическими массивами (ООП). Модуль позволяет работать с массивами с переменной длиной (допускается создание массивов, использующих любые типы данных - встроенные типы Паскаля, перечисления и записи - в качестве базового типа). Дополнительная информация Использование процедур и функций модуля:
Код
Program TestArray; Исходники модуля вместе с текстовой программой: [attachmentid=1632] Скачать: [attachmentid=1630] Данный модуль можно адаптировать для работы с любым встроеннымтипом данных Турбо Паскаля. Все, что потребуется изменить - это:
[attachmentid=1633] Скачать: [attachmentid=1631]
Материал подготовил(и): volvo Работа с динамическими матрицами Для того, чтобы работать с динамическими матрицами, проще всего представить матрицу, как массив векторов (массив, содержащий указатели на строки матрицы). Перед началом работы с такой матрицей нужно сначала выделить память под массив указателей на строки, и только потом выделять память для хранения самих данных. После использования матрицы выделенная память освобождается в обратной последовательности: [PASCODE]{ Обязательно отключить проверку индексов, иначе возникнет ошибка времени исполнения } {$R-} Type TType = Word; { Или любой другой тип } Type PVector = ^TVector; { Это - одна "строка" динамической матрицы } TVector = Array[1 .. 1] of TType; PDynMatrix = ^TDynMatrix; { Сама матрица - представляется как массив указателей на "строки" } TDynMatrix = Array[1 .. 1] of PVector; Var { Через эту переменную будет осуществляться вся работа с матрицей } mxDynamic: PDynMatrix; n, i, j: Word; Begin Write('n = '); ReadLn(n); { Выделяем память под указатели на "строки" } GetMem(mxDynamic, n * SizeOf(PVector)); { И для каждой "строки" - выделяем память для хранения данных } For i := 1 To n Do GetMem(mxDynamic^[i], n * SizeOf(TType)); (*** Работаем с матрицей ***) { Динамическая матрица представлена немного иначе, чем динамический массив, поэтому для того, чтобы обратиться к ее элементу, необходимы 2 операции разыменования указателей. Пример: } For i := 1 To n Do { Строки } For j := 1 To n Do { Столбцы (элементы строки) } mxDynamic^[I]^[J]:=I*J; For i := 1 To n Do Begin WriteLn; For j := 1 To n Do Write(mxDynamic^[I]^[J]:4); End; (*** Закончили работу с матрицей - уничтожаем ее ***) { Освобождаем память в обратном порядке: } { Сначала - удаляем все "строки" } For i := 1 To n Do FreeMem(mxDynamic^[i], n * SizeOf(TType)); { А теперь и указатели на них ... } FreeMem(mxDynamic, n * SizeOf(PVector)); End.[/PASCODE] Модуль для работы с динамическими матрицами В этом модуле для работы с матрицами вводится тип:
CODE
Type TType = Double; PTRows = ^TRows; TRows = Array[1 .. (2 * maxInt) Div SizeOf(TType)] Of TType; PTCol = ^TCol; TCol = Array[1 .. (2 * maxInt) Div SizeOf(PTRows)] Of PTRows; PTMatrix = ^TMatrix; TMatrix = Record nRow, nCol: Integer; matrix: PTCol; End; При таком представлении матрицы к каждому ее элементу нельзя обращаться как к элементу обычного двумерного массива (т.е. так: arr[i, j] := 0). Для того, чтобы работать с TMatrix нужно изменить вызов на: arr.matrix^[i]^[j] := 0. Поля nRow, nCol содержат количество строк и столбцов соответственно. Прилагаемый модуль содержит основные функции для работы с матрицами: Function mxO(size: Integer): PTMatrix; Создание в динамической памяти "нулевой" матрицы, т.е. такой, что: A+O = O+A = A Function mxE(size: Integer): PTMatrix; Создание в динамической памяти "единичной" матрицы (элементы главной диагонали равны единице, все остальные - нули), т.е. такой, что: A*E = E*A = A Function mxCreate(pRows, pCols: Integer): PTMatrix; Функция возвращает указатель на созданную в динамической памяти матрицу (или nil при невозможности выделения памяти) Procedure mxDispose(Var p: PTMatrix); Процедура освобождает динамическую память, занятую матрицей p^, и устанавливает значение p в nil. Procedure mxInput(Var a: TMatrix); Процедура поэлементно вводит с клавиатуры матрицу, переданную ей в качестве параметра. Procedure mxPrint(a: TMatrix); Процедура выводит на экран матрицу, переданную ей в качестве параметра. Function matrixAdd(a, b: TMatrix): PTMatrix; Функция возвращает указатель на созданную в динамической памяти матрицу, являющуюся суммой матриц a и b, передаваемых как параметры (или nil при невозможности выделения памяти или при несоответствии размеров матриц A и B) Function matrixSub(a, b: TMatrix): PTMatrix; Функция аналогична matrixAdd, но возвращает разность матриц A и B Function matrixMult(a, b: TMatrix): PTMatrix; Функция возвращает указатель на созданную в динамической памяти матрицу, являющуюся произведением матриц a и b, передаваемых как параметры (или nil при невозможности выделения памяти или если матрицы a и b не являются "сцепленными", т.е. число столбцов A не равно числу строк B) Function matrixScale(a: TMatrix; f: Double): PTMatrix; Функция возвращает указатель на созданную в динамической памяти матрицу, являющуюся произведением матрицы A на число f (или nil при невозможности выделения памяти) Function matrixDet(a: TMatrix): Double; Возвращает значение определителя квадратной матрицы A (при передаче матрицы, не являющейся квадратной, функция вернет 0) Function matrixEqual(a, b: TMatrix): Boolean; Функция поэлементного сравнения матриц. Если матрицы имеют разный размер или не эквивалентны, функция возвращает False. Function matrixTranspose(a: TMatrix): PTMatrix; Функция возвращает указатель на созданную в динамической памяти матрицу, являющуюся транспонированной матрицей A, т.е. строки исходной матрицы становятся столбцами и наоборот (или nil при невозможности выделения памяти) Function matrixInvert(a: TMatrix; Var multBy: Double): PTMatrix; Функция возвращает указатель на созданную в динамической памяти матрицу, являющуюся инверсной (обратной) по отношению к A, то есть матрицей, результатом умножения которой на A является единичная матрица (или nil при невозможности выделения памяти). (В переменной multBy возвращается значение 1/det(A)) Пример использования модуля:
CODE
Uses crt, matrixUnit; Const size = 3; Var mxCheck, mxA, invA: PTMatrix; mx1, mx2: PTMatrix; i, j: integer; ToMult: Double; Begin clrscr; { Проверка умножения матриц } mx1 := mxCreate(2, 3); mxInput(mx1^); mxPrint(mx1^); mx2 := mxCreate(3, 3); mxInput(mx2^); mxPrint(mx2^); mxCheck := matrixMult(mx1^, mx2^); mxPrint(mxCheck^); { Проверка создания обратной матрицы } mxA := mxCreate(size, size); mxInput(mxA^); mxPrint(mxA^); invA := matrixInvert(mxA^, ToMult); WriteLn(ToMult:5:2); mxPrint(invA^); { Не забываем освобождать память } mxDispose(invA); mxDispose(mxA); mxDispose(mxCheck); mxDispose(mx2); mxDispose(mx1) End. Материал взят с сайта Всё о Паскале |
Поиск :На форуме :
Друзья :Опросы :Получается ли у вас скачивать книги с нашего сервера?Да, получаетсяНет, с ошибками Сейчас на сайте :0 пользователей, 22 гостей : |