Основні прийоми роботи в середовищі ТР

program one;

uses crt;

var a, b, P: integer;

begin clrscr;

writeln ('a =');

readln (a);

writeln ('b =');

readln (b);

P: = (a + b) * 2;

writeln ('P =', P);

end.

program one;

uses crt;

var a, b, h, s: real;

begin clrscr;

writeln ('A = B = H =');

readln (a, b, h);

s: = h * (a + b) / 2;

writeln ('S =', s: 0:4);

readln;

end.

program one;

uses crt;

var Q, c, m, t2, t1: integer;

begin clrscr; textcolor (10);

writeln ('c =');

readln (c);

writeln ('m =');

readln (m);

writeln ('t2 =');

readln (t2);

writeln ('t1 =');

readln (t1);

Q: = c * m * (t2-t1);

writeln ('Q = c * m * (t2-t1) =', Q);

end

program one;

uses crt;

var I, U, R: real;

begin clrscr; textcolor (10);

writeln ('U ='); readln (U);

writeln ('R =');

readln (R);

I: = U / R;

writeln ('I =', I: 5:0);

end.

program one;

uses crt;

var r: real; x1, x2, y1, y2: integer;

begin clrscr;

writeln ('znachenie x1 =');

readln (x1);

writeln ('znachenie x2 =');

readln (x2);

writeln ('znachenie y1 =');

readln (y1);

writeln ('znachenie y2 =');

readln (y2);

r: = sqrt (sqr (x2-x1) + sqr (y2-y1));

writeln ('rasstoyanie =', r);

end.

program one;

uses crt; var a, b, c: real; begin clrscr;

writeln ('summa deneg =');

readln (a);

writeln ('cena ed.tovara =');

readln (b);

c: = a / b;

writeln ('ostatok =', c);

end.

program one;

uses crt;

var a: integer; s, d, e, f: real;

begin clrscr;

writeln ('vvedi 3-hznachnoe chislo');

program one;

uses crt;

var a, S: real;

begin clrscr;

writeln ('Vvedite storonu treugolnika');

readln (a);

S: = 0;

S: = a * a * sqrt (3) / 4;

writeln ('Ploshad ravna:', S: 3:1);

readln;

end.

program one;

uses crt; var det, jen, muj, ned, mes: integer;

begin clrscr;

writeln ('det :=');

readln (det);

writeln ('jen :=');

readln (jen);

writeln ('muj :=');

readln (muj);

ned: = muj + jen + det;

mes: = 4 * ned;

writeln ('dohod =', mes);

end

Program one;

Uses crt;

Var a, b, p: integer;

begin clrscr; textcolor (9 +5);

writeln ('a = b =');

readln (a, b);

p: = a * b;

textcolor (9 +16);

writeln ('p =, p');

end.

Program one;

Uses crt;

Var l: real; r: integer;

begin clrscr; textcolor (5);

writeln ('R =');

readln (r);

l: = 2 * pi * r;

writeln ('radius =, r');

end.

Program one;

Uses crt; Var а: integer;

begin clrscr; textcolor (5);

writeln ('a =');

readln (a);

p: = 4 * a;

writeln ('perimetr =, р');

end.

Program one;

Uses crt; Var s: integer;

begin clrscr; textcolor (5);

writeln ('s =');

readln (s);

writeln ('ви ввели число, s ');

end.

Program one;

Uses crt; Var k, s: integer; p: real;

begin clrscr; textcolor (5);

writeln ('число жителів = ');

readln (k);

writeln ('plosh =');

readln (s);

p: = s / k;

writeln ('plotnost =', p);

end.

program one;

var x, y: integer;; begin write ('x ='); readln (x); if x> 0 then y: = sqr (sin (x)) else y: = 1-2 * sin (sqr (x )); writeln (y); end.

Program ch;

Uses crt;

Var a, m, n: integer;

Begin clrscr;

Writeln ('m = n =');

Readln (m, n);

a: = m mod n;

If a = 0 then write (m div n)

Else write ('net resh')

End.

program one;

var x, y: real;

begin writeln ('');

write ('Vvedite x =');

readln (x); if x <= 0.8 then

y: = exp (x-1) +3.14 else if (0.8 <x) and (X <= 5.27) then

y: = ln (x +5.96) else y: = 2 * x;

writeln ('y =', y: 4:2); readln; end.

program one; var x, y, z: real; begin writeln (''); write ('Vvedite x ='); readln (x); write ('Vvedite y ='); readln (y);

if xy> 0 then z: = 1 / (x * y) else z: = sqr (x) * sqr (y); writeln ('z =', z: 4:2); readln; end.

program one; var x, y, z, a, b: real; begin writeln (''); write ('Vvedite a ='); readln (a); write ('Vvedite b ='); readln (b) ; x: = ln (sqr (a)); y: = 1/arctan (b); if xy> 0 then z: = 1 / (x * y) else z: = sqr (x) * sqr (y) ; writeln ('z =', z: 4:2); readln; end.

program one; var a1, a2, b1, b2, c1, c2: integer; begin writeln ('vvedite shiriny, dliny, vusoty 1');

readln (a1, b1, c1); writeln ('vvedite shiriny, dliny, vusoty 2'); readln (a2, b2, c2); if ((a1 <= a2) and (b1 <= b2) and (c1 < = c2)) or ((a1> a2) and (b1> b2) and (c1> c2)) then writeln ('mogno') else writeln ('nelzya'); readln; end.

program one; var a, b, c, d: integer; begin read (a, b); read (c, d); if (a = c) or (b = d) or (abs (ca) = abs ( db))

then write ('ga') else write ('HeT');

readln

end

begin clrscr;

writeln ('Сторони трикутника =   ');

readln (a, b, c);

if (a <b + c) and (b <a + c)

and (c <a + b) then write ('можна')

else write ('неможливо');

readkey;

end.

program one; var a, b, c: real; begin read (a, b, c); if (a> b) and (a> c) then write ('a ^ 2 =', a * ​​a: 1: 4); if (b> a) and (b> c) then write ('b ^ 2 =', b * b: 1:4); if (c> a) and (c> b) then write (' c ^ 2 = ', c * c: 1:4); readln end.

Program b_ch;

Uses crt;

Var a, b: integer;

Max: integer;

Begin clrscr;

Writeln ('a = b =');

Readln (a, b);

If a> b then max: = a else max: = b

Writeln ('max =', max);

End.

Program m_ch;

Uses crt;

Var a, b: integer;

Min: integer;

Begin clrscr;

N: = n +1;

Until n> 20; Readln;

End.

8. Опис: Відомі оцінки з інформатики кожного з 20 учнів класу. На початку списку Перераховано всі «5», потім інші оцінки. Скільки учнів мають оцінку «5»?

Program 5;

Uses crt;

Var x, n: word;

Begin clrscr;

Writeln (vvedi ocenki);

Readln (x);

N: = 0;

While x = 5 do begin n: = n +1;

Writeln (vvedi ocenki);

Readln (x);

End;

Writeln (imeyut 5, n, uchenikov);

Readln;

End.

9. Опис: Обчислити найбільший спільний дільник двох натуральних чисел А і В, використовую для цього алгоритм Евкліда. Будемо зменшувати щораз більше з чисел на величину меншого до тих пір, поки обидва числа не стануть рівними.

Program nod;

Uses crt;

Var a, b: integer;

Begin clrscr;

Writeln (vvedi 2 chisla);

Readln (a, b);

While a <> b do if a> b then a: = ab else b: = ba;

Writeln (nod =, a); Readln;

End.

10.Опісаніе: Програма підрахунку суми S перших 1000 членів гармонійного ряду 1 +1 / 2 +1 / 3 +1 / 4 + ... +1 / N

Program S;

Uses crt;

Var s: real; n: integer;

Begin clrscr;

S: = 0; N: = 0;

While n <1000 do begin N: = n +1;

S: = s +1 / n;

End;

Writeln (s);

Readln;

End.

11.Опісаніе: Є чотири (A, B, C, D) числа. Необхідно відповісти на запитання: «Чи правда що всі серед цих чисел є рівні?» Відповідь вивести у вигляді тексту: «Правда», або «Неправда».

Program z 1;

var a, b, c, d: integer; {описуємо наявні змінні}

begin writeln ('vvedite chislo a '); {вводимо всі числа по черзі}

readln (a);

writeln ('vvedite chislo b');

readln (b);

writeln ('vvedite chislo c');

readln (c);

writeln ('vvedite chislo d');

readln (d);

if (a = b) or (a = c) or (a = d) or (b = c) or (b = d) or (d = c) then writeln ('pravda') else writeln ('nepravda') ;

readln;

end.

12.Опісаніе: Скласти програму обчислення і видачі на друк суми (твору) N елементів нескінченного ряду. Оформити перевірку завдання. Y = (-512) * 256 * (-128) * 64 ... ... Загальна формула має вигляд: y = ± 2 ^{10 - i}

program z 2;

var i, j, zn, n: integer; s: real;

begin writeln;

writeln ('vvedite kolichestvo elementov ryada');

write ('N ='); {вводимо кількість елементів ряду}

readln (n);

s: = 1;

for i: = 1 to n do begin zn: = 1;

for j: = 1 to i +1 do begin zn: = zn * (-1);

end;

s: = s * (-zn) * (exp ((10-i) * ln (2))); {вводимо формулу}

end;

writeln ('s =', s: 4:2);

readln;

end.

13.Опісаніе: Дана функція Y = 1 - [x -2] ^ 2 / 10 обчислити і надрукувати значення цієї функції для послідовних значень x = c, x = c + (b +1), x = c +2 (b + 1), x = c +3 (b +1) де а = 1; b = 9; з = 2. Порахувати до тих пір поки сума Y +6 не стане негативною.

program zad3;

const b = 9; c = 2;

var x, n: integer; f, s: real; function y (x: integer): real;

begin y: = 1 - (sqr (xc)) / (b +1);

end;

begin writeln ('Y = 1 - [x-2] ^ 2 / 10');

n: = 0;

repeat x: = c + n * (b +1);

inc (n);

f: = y (x);

write ('x', n, '=', x, '');

writeln ('y', n, '=', f: 6:5)

until f +6 <0;

readln

end.

14.Опісаніе: Є масив А з N довільних чисел (A (n)), серед яких є позитивні, негативні та рівні нулю. Надрукувати лише ті числа з масиву які більше попереднього числа.

program z4;

uses Crt;

const MAX = 100;

var mas: array [1 .. MAX] of integer; n, i: byte; k, p: integer;

begin ClrScr;

Write ('N :=');

Readln (n);

for i: = 1 to n do begin Write ('vvedite', i, 'element massiva :>'); Readln (mas [i]); end;

begin k: = 0;

for i: = 1 to n do begin if mas [i]> mas [(i-1)] then writeln (mas [i]); end;

readln; end;

end.

15.Опісаніе: Скласти програму обчислення числового ряду для відомого числа членів ряду N. Y = (7 +3 ⁵ / 1) (8-3 ^-4 / 2) (9 +3 ³ / ​​3) ....

program z5;

var i, j, zn, n: integer; s: real;

begin writeln;

writeln ('vvedite kolichestvo elementov ryada');

write ('N =');

readln (n);

s: = 1;

for i: = 1 to n do begin zn: = 1;

for j: = 1 to i +1 do begin zn: = zn * (-1); end;

s: = s * ((6 + i) + exp ((zn * (6-i)) * ln (3)) / i); end;

writeln ('s =', s: 4:2);

readln;

end.

Розділ: Масиви

1 Опис: Знайти, скільки разів кожен елемент зустрічається в масиві

Додаткових масивів не створювати.

Program msv;

Const Size = 10; Diap = 10;

var a: array [1 .. Size] of integer; i, n, k, j: integer;

begin writeln;

repeat write ('Введіть розмірність 1 масиву (від 2 до', Size ,'):');

Read (n);

Until (n> 1) and (n <= Size); Randomize;

a [1]: = Random (Diap);

Write ('A =', a [1], '');

For i: = 2 to n do begin A [i]: = Random (Diap);

Write (a [i], ''); End;

writeln;

k: = 0;

For i: = 1 to n do if a [i] = 0 then Inc (k);

If k> 0 then writeln ('0: ', k);

For i: = 1 to n-1 do if a [i] <> 0 then begin K: = 1;

For j: = i +1 to n do if a [i] = a [j] then begin A [j]: = 0;

Inc (k); End;

writeln (a [i], ':', k); end;

end.

2. Опис: Об'єднати 2 упорядкованих масиву за зростанням.

Program msv;

const Size = 10; Step = 5;

var a, b: array [1 .. Size] of integer; c: array [1 .. 2 * Size] of integer; i, n1, n2, ia, ib, ic: integer;

begin writeln;

repeat write ('Введіть розмірність 1 масиву (від 2 до', Size ,'):');

read (n1);

until (n1> 1) and (n1 <= Size);

Randomize;

a [1]: = Random (Step);

write ('A =', a [1], '');

for i: = 2 to n1 do begin a [i]: = a [i-1] + Random (Step);

write (a [i], ''); end;

writeln;

repeat

write ('Введіть розмірність 2 масиви (від 2 до', Size ,'):');

read (n2);

until (n2> 1) and (n2 <= Size);

b [1]: = Random (Step);

write ('B =', b [1], '');

for i: = 2 to n2 do begin b [i]: = b [i-1] + Random (Step);

write (b [i], '');

end;

writeln;

ia: = 1; ib: = 1;

write ('C =');

for i: = 1 to n1 + n2 do begin if a [ia] <= b [ib] then begin c [i]: = a [ia];

if ia <n1 then Inc (ia) else begin a [n1]: = b [ib];

if ib <n2 then Inc (ib); end; end

else begin c [i]: = b [ib];

if ib <n2 then Inc (ib) else begin b [n2]: = a [ia];

if ia <n1 then Inc (ia); end; end;

write (c [i], '');

end;

writeln;

end.

3. Опис: Дано масив чисел. Знайти найбільше.

Program msv;

Uses crt;

Var i, n, max: integer; a: array [1 .. 100] of integer;

begin clrscr;

read (n);

for i: = 1 to n do read (a [i]); {введення чисел в масив}

max: = a [1];

for i: = 2 to n do if a [i]> max then max: = a [i]; {порівнюється з вже знайденим найбільшим,}

write ('maksimalnoe chislo =', max);

readln;

end.

4. Опис: Знайти суму елементів числового масиву

Program msv;

uses crt;

Var i, n, s: integer; a: array [1 .. 1000] of integer;

begin clrscr;

read (n);

for i: = 1 to n do read (a [i]); {введення значень в масив}

s: = 0;

for i: = 1 to n do s: = s + a [i];

write ('Summa =', s); readln;

readln;

end.

5. Опис: Дан числовий масив. Обчислити суму елементів, що мають парне значення індексу. Обчислювальну частина організувати у вигляді функції

Program msv;

Uses crt;

type mas = array [1 .. 100] of integer;

Var a: mas; i, n: integer; function calc (b: mas; m: integer): integer;

var i, s: integer;

begin s: = 0;

for i: = 1 to m do;

if i mod 2 = 0 then s: = s + b [i];

calc: = s;

end;

begin clrscr;

read (n);

for i: = 1 to n do read (a [i]);

write ('Сума кожного другого елементу =', calc (a, n));

readln;

readln;

end.

6. Опис: Дано масив символів. Обчислити, скільки в ньому елементів 'a'

Program msv;

Uses crt;

Var i, n, s: integer; a: array [1 .. 100] of char;

begin clrscr;

readln (n); {Оголошення а: array [1 .. 1000] of char означає,}

for i: = 1 to n do readln (a [i]);

s: = 0;

for i: = 1 to n do readln (a [i]);

s: = 0;

for i: = 1 to n do if a [i] = 'a' then s: = s +1;

write ('Kolichestvo elementov ravnyh "a" =', s);

readln;

end.

7. Опис: Дан двовимірний масив цілих чисел розмірністю NxN. Знайти суму його елементів

Program msv;

Uses crt;

Var s, i, j, n: integer; a: array [1 .. 10,1 .. 10] of integer;

begin clrscr;

read (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 s: = s + a [i, j];

write ('Сума елементів =', s);

readln;

readln;

end.

8. Опис: По заданому масиву X [7] сформувати масив Y, елементи якого обчислюються за формулою

Y [i] = | X [i] - B |, де B - максимальний елемент масиву X

program msv;

const Size = 7; {Розмірність масиву}

var x: array [1 .. Size] of real; b: real; i: integer;

begin writeln;

writeln ('Чекаю введення елементів масиву розмірністю', Size ,':');

for i: = 1 to Size do begin write ('x [', i ,']=');

readln (x [i]); end;

b: = x [1];

for i: = 2 to Size do if x [i]> b then b: = x [i];

writeln ('Максимальний елемент =', b: 10:3);

writeln ('Вихідний Новий');

writeln ('масив масив');

for i: = 1 to Size do begin write (x [i]: 10:4);

x [i]: = abs (x [i]-b);

writeln (x [i]: 10:4); end;

end.

9. Опис: Знайти максимальний елемент у лінійному масиві.

Вивести результат на екран

program msv;

uses crt;

const

nn = 10; var max, i: integer; a: array [1 .. nn] of integer; begin clrscr;

for i: = 1 to nn do a [i]: = random (500);

max: = a [1];

for i: = 2 to nn do if a [i]> max then max: = a [i];

for i: = 1 to nn do write (a [i], ''); writeln;

writeln ('Max =', max);

readkey;

end.

10. Опис: Відсів. Видалити в заданому масиві x (n) зайві (крім першого) елементи так, щоб залишилися утворювали зростаючу послідовність (за один перегляд масиву)

program msv;

uses crt;

const n = 10; {dlina massiva}

var a: array [1 .. n] of integer; i, max, j, k, mi: integer; begin clrscr; randomize;

for i: = 1 to n do begin a [i]: = random (51);

write (a [i], ''); end;

max: = a [1];

k: = 2; {tk uslovie zadachi "preobarzovat 'za odin prosmotr massiva", to}

{K ne mozhet bit 'bol'she N, chem mi vospol'zuemsya v cikle}

for i: = 2 to n do begin if k> n then break;

if a [i] <= max then {esli a [i] <= max to udalyaem etot element}

begin for j: = i to n - 1 do {etogo cikl mog bi ne viiti, no u nas est 'K}

a [j]: = a [j + 1];

dec (i); end;

if a [i]> max then begin max: = a [i];

mi: = i; {MI - poziciya maksimuma v massive} end;

inc (k); {uvelichivaem K, k = [2 .. n]} End;

Write (# 10 # 13, a [1], '');

For i: = 2 to mi do Write (a [i], '');

readkey;

end.

11. Опис: У масиві X з n елементів кожен з елементів дорівнює 0, 1 або 2. Переставити елементи масиву так, щоб спочатку розташовувалися нулі, потім одиниці і двійки. Додатковий масив не використовувати.

Програма розширена для можливості переставляти елементи масиву, що є будь-якими числами (не тільки 0, 1, 2)

Program msv;

Const n = 10; {к-вл елементів масиву}

var a, b, t: integer; X: array [1 .. n] of integer; {сам масив з n елементів}

BEGIN For a: = 1 to n do {введення масиву X} Begin Write ('Введіть X [', a, ']:');

Readln (X [a]); End;

for a: = 1 to n do begin t: = X [a];

b: = a - 1;

While (b> = 0) and (t <X [b]) do Begin X [b +1]: = X [b];

B: = b - 1; End;

X [b +1]: = t; end;

for a: = 1 to n do {висновок результату}

Write (X [a]: 2);

END. {Кінець програми}

12. Опис: Операції з масивом, сортування суммірованіе.В одновимірному масиві, що складається з N речових елементів, обчислити: 1) кількість елементів масиву, рівних 0; 2) суму елементів масиву, розташованих після мінімального елемента.

Упорядкувати елементи масиву за зростанням модулів елементів.

Program msv;

Uses CRT;

Const N = 10; {скільки всього елементів}

Var a: Array [1 .. N] of Real; i, j: Byte; Zero: Byte; Min: Real; Summ: Real;

Procedure Print;

Begin For i: = 1 to N do Write (a [i]: 0:1, '');

Writeln; End;

Procedure CreateMassive;

BeginWriteln ('Вихідна послідовність');

For i: = 1 to N do Begin a [i]: = Random (4);

a [i]: = a [i] - 2; {Цей і попередній оператори можна об'єднати}

End;

Print;

Writeln; End;

Begin ClrScr; Randomize;

CreateMassive;

Min: = a [1];

For i: = 2 to N do Begin Summ: = Summ + a [i];

If (a [i] <Min) then Begin Min: = a [i];

Summ: = 0; End; End;

Writeln ('Мінімальний елемент', Min: 0:1, '. Сума елементів після:', Summ: 0:1);

For i: = 1 to N do Begin For j: = i + 1 to N do If (abs (a [j]) <abs (a [i])) then Begin a [i]: = a [i] + a [j];

a [j]: = a [i] - a [j];

a [i]: = a [i] - a [j]; End; End;

Writeln (# 13 # 10, 'Отсортіровання послідовність '); Print;

For i: = 1 to N do If a [i] = 0 then Inc (Zero);

Write (# 13 # 10, 'Нульових елементів: ', Zero); ReadKey;

End.

13. Опис: Обчислити кут між двома заданими векторами розмірності 8, використовуючи функцію скалярного твори a = arccos ((x, y) / ((x, x) * (y, y)))

program msv;

uses crt;

type TVector = array [1 .. 8] of Real;

function scal (var Vec1, Vec2: TVector): real; var p: Real; i: integer;

begin p: = 0;

for i: = 1 to 8 do p: = p + (Vec1 [i] * Vec2 [i]);

scal: = p; end;

var Vec1, Vec2: TVector; i: integer; sc, a, angle: Real;

BEGIN writeln ('Умова:');

writeln ('обчислити кут між двома заданими векторами розмірності 8,');

writeln ('використовуючи функцію скалярного твори');

writeln;

Writeln ('Введення першого вектора');

for i: = 1 to 8 do begin Write ('Vec1 [', i, ']:');

Readln (Vec1 [i]); end;

Writeln ('Введення другого вектора');

for i: = 1 to 8 do begin Write ('Vec2 [', i, ']:');

Readln (Vec2 [i]); end;

sc: = scal (Vec1, Vec2);

a: = sc / sqrt (scal (Vec1, Vec1) * scal (Vec2, Vec2)); {Обчислюється косинус}

if a = 0 then angle: = 90 else angle: = arctan (sqrt (1-a * a) / a) * 180/pi;

if a =- 1 then angle: = 180;

if angle <0 then angle: = 180 + angle;

writeln ('Кут між векторами:', angle: 7:3, 'градусів');

END.

14. Опис: Обчислити суму двох векторів, перший з яких вводиться, а елементи другого обчислюються за формулою b [i]: = sin (i * x), де 0 <= x <= 3.14

program msv;

const Nm = 10; {розмірність вектора}

var Vec1, Vec2, ResVec: array [1 .. Nm] of Real; i: integer; x: Real; N: integer;

BEGIN writeln ('Умова:');

writeln ('обчислити суму двох векторів, перший з яких вводиться, а елементи ");

writeln ("другого обчислюються за формулою b [i]: = sin (i * x), де 0 <= x <= 3.14 ');

writeln;

Write ('введіть розмірність вектора (N <', Nm, '):');

Readln (N);

if n <= Nm then begin Writeln ('Введення вектора');

for i: = 1 to N do begin Write ('Vec1 [', i, ']:');

Readln (Vec1 [i]); end;

Write ('Введіть X (від 0 до 3.14):'); Readln (x);

if (X <= 3.14) and (X> = 0) then begin for i: = 1 to N do begin Vec2 [i]: = sin (Vec1 [i] * X); ResVec [i]: = Vec1 [i ] * Vec2 [i]; {відразу ж обчислюємо проізведніе} end;

Write ('Результуючий вектор:'); {виводимо на екран результат}

for i: = 1 to N do Write (ResVec [i]: 6:2); end else Writeln ('Введено невірне X ');

end else Writeln ('невірна розмірність');

END.

15. Опис: Складається випадковий масив з 5 елементів. Замінити всі парні значення на 1, непарні - на 0.

Program msv;

uses crt;

const n = 5;

var a: array [1 .. n] of integer; i: integer;

begin clrscr; randomize;

for i: = 1 to n do begin a [i]: = random (9);

write (a [i]); end;

writeln;

for i: = 1 to n do begin if odd (a [i]) = false then a [i]: = 1 else a [i]: = 0;

write (a [i]);

end;

readkey;

end.

Розділ: Процедури і функції

1.Описание: Знайти послідовності цілих чисел ті, які зустрічаються в ній рівно два рази.

program one;

uses crt;

type mas = array [1 .. 100] of integer; func = function (var x: mas): integer; var a: mas; j, n, m, x: integer;

function kolichestvo (var c: mas): integer; var k, i: integer;

begin k: = 0;

for i: = 1 to n do if c [i]> m then k: = k +1;

kolichestvo: = k; end;

procedure deist (var b: mas; operation: func);

begin writeln ('b [j]');

for j: = 1 to n do readln (b [j]);

for j: = 1 to n do write (b [j], ''); writeln;

x: = operation (a); end;

begin clrscr;

writeln ('vvedite celoe chislo mi razmer massiva (n)');

readln (m, n);

deist (a, kolichestvo);

writeln ('kolichestvo =', x);

readkey;

end.

2.Опісаніе: Процедура відображення рамки в текстовому режимі

program frame;

uses Crt;

procedure Frm (l: integer; t: integer; w: integer; h: integer);

var x, y: integer; i: integer; c1, c2, c3, c4, c5, c6: char;

begin clrscr;

c1: = chr (218); c2: = chr (196);

c3: = chr (191); c4: = chr (179);

c5: = chr (192); c6: = chr (217); GoToXY (l, t);

write (c1);

for i: = 1 to w-2 do write (c2);

write (c3);

y: = t +1;

x: = l + w-1;

for i: = 1 to h-2 do begin GoToXY (l, y);

write (c4);

GoToXY (x, y);

write (c4);

y: = y +1; end;

GoToXY (l, y);

write (c5);

for i: = 1 to w-2 do write (c2);

write (c6);

end;

begin Frm (2,2,15,10);

readln;

end.

3.Описание: Твір непарних елементів

Program one;

type massiv = array [1 .. 100] of integer;

var A1, A2: massiv; i, j: integer; n1, n2: integer; function pr_nec (m: massiv; n: integer): integer;

var i, j, pr: integer;

begin pr: = 1;

for i: = 1 to n do if odd (m [i]) then pr: = pr * m [i];

pr_nec: = pr;

end;

begin writeln ('Vvedite PERVYI massiv:');

write ('ego razmer "n":'); readln (n1);

for i: = 1 to n1 do begin write ('A1 [', i ,']='); readln (A1 [i]); end;

writeln ('_______________________');

writeln ('Vvedite VTOROI massiv:');

write ('ego razmer "n":'); readln (n2);

for i: = 1 to n2 do begin write ('A2 [', i ,']='); readln (A2 [i]); end;

writeln ('_______________________');

writeln;

writeln ('Vi vveli:');

write ('A1:'); for i: = 1 to n1 do write (A1 [i], ''); writeln;

write ('A2:'); for i: = 1 to n2 do write (A2 [i], ''); writeln;

writeln;

writeln ('Proizvedenie iz A1 =', pr_nec (A1, n1));

writeln ('Proizvedenie iz A2 =', pr_nec (A2, n2));

readln;

end.

4.Опісаніе: Знаходження тангенса tg і котангенс ctg кута, використовуючи вирази sin (x) cos (x) і зворотне йому.

Program one;

uses crt;

var y1, y2, z: real; function tg (x: real): real;

begin tg: = sin (x) / cos (x);

end;

function ctg (x: real): real;

begin ctg: = cos (x) / sin (x);

end;

Begin clrscr;

write ('input x:');

readln (z);

y1: = tg (z); y2: = ctg (z);

writeln ('tg (', z: 0:2 ,')=', y1: 0:2);

writeln ('ctg (', z: 0:2 ,')=', y2: 0:2); readln;

End.

5. Опис: Визначити максимальне число з чотирьох запроваджених, шляхом порівняння їх спочатку попарно, а потім результат між собою.

program one;

uses crt;

var a, b, c, d, z, x, y, x1, y1: integer; function max (x, y: integer): integer;

begin if x> y then max: = x else max: = y;

end;

begin clrscr;

writeln ('Vvedite chisla');

readln (a, b, c, d);

x1: = max (a, b); y1: = max (c, d); z: = max (x1, y1);

writeln ('max =', z);

readkey;

end.

6.Опісаніе: Обчислити день тижня за датою

program Kalendar;

uses crt; var y, d, m, c, w: integer; {m-mesiac, d-den, y-god} Procedure WriteDay (d, m, y: Integer);

constDays_of_week: rray [0 .. 6] of String [11] = ('Voskresen `e', 'Ponedelnik', 'Vtornik', 'Sreda', 'Chetverg', 'Piatnica', 'Subbota');

Begin if m <3 then begin m: = m + 10;

y: = y - 1; end else m: = m - 2; c: = y div 100; y: = y mod 100; w: = (d + (13 * m-1) div 5 + y + y div 4 + c div 4-2 * c +777) mod 7;

WriteLn (Days_of_week [w]); end;

Procedure InputDate (var d, m, y: Integer);

Begin Write ('Vvedite datu v formate DD MM GG');

ReadLn (d, m, y);

if (d> = 1) and (d <= 31) and (m> = 1) and (m <= 12) and (y> = 1582) and (y <= 4903) then Writeday (d, m, y ) else begin writeln ('Nekorrektnyj vvod!'); end; end;

BEGIN clrscr;

InputDate (d, m, y);

readkey;

End.

7. Опис: Знаходження відсотка від числа

Program one;

uses crt;

var k, n: byte; x: real; function procent (n, m: byte): real;

begin procent: = m * 100 / n;

end;

begin clrscr;

writeln ('Vvedite chisla');

readln (k, n);

x: = procent (k, n);

writeln ('x =', x: 5:2);

readkey;

end.

8. Вивести задане число зірочок.

program one;;

uses crt;

var n: byte; function zvezda (n: byte): real; var i: integer; s: string;

begin i: = 1;

s :='';

while i <= n do begin s: = s +'*';

inc (i); end;

writeln (s); end;

begin clrscr;

writeln ('Vvedite chislo'); readln (n);

zvezda (n); readkey;

end.

9. Опис: Функція піднесення числа до степеня. З урахуванням дробових чисел та окремих випадків, коли числа негативні або дорівнювати нулю

program one;

Uses crt;

var x, y, z: real; Function Pow (A, B: Real): Real; Var T, R: Real; L: integer;

Begin T: = Abs (A);

If A <0 Then R: = (-1) * Exp (B * Ln (T)) else if A> 0 Then R: = Exp (B * Ln (T)) else R: = 0;

L: = round (B);

If (L mod 2 = 0) Then R: = Abs (R);

If (B = 0) Then R: = 1;

Pow: = R;

End;

BEGIN clrscr;

Writeln ('vvedite chislo:');

readln (x);

Writeln ('vvedite stepen:');

readln (y);

z: = Pow (x, y);

Writeln (z: 0:2);

readkey;

END.

10. Опис: Вивести заданий символ задану кількість разів

program one;

uses crt;

var n: byte; l: string; function zvezda (n: byte; l: string): real; var i: integer; s: string;

begin i: = 1;

s :='';

while i <= n do begin s: = s + l;

inc (i); end;

writeln (s); end;

begin clrscr;

writeln ('Vvedite chislo'); readln (n);

writeln ('Vvedite simvol'); readln (l);

zvezda (n, l);

readkey;

end.

11.Опісаніе: Визначити до чого ближче менше з двох чисел: до їх середнього арифметичного або середнього геометричного.

Program one;

vara, b: real; average: real; geometricmean: real; minstr: string; function min (a, b: real): real;

begin min: = a;

minstr: = 'Pervoe';

if (b <a) then begin min: = b;

minstr: = 'Vtoroe'; end; end;

beginwrite ('Vvedite 1-e chslo:'); readln (a);

write ('Vvedite 2-e chslo:'); readln (b);

average: = (a + b) / 2;

geometricmean: = sqrt (a * a + b * b);

a: = min (a, b);

writeln ('Naimenshee chislo -', minstr, '(', a: 0:3 ,')');

write ('Blize k srednemu');

if (abs (average - a) <abs (geometricmean - a)) thenbegin writeln ('arifmeticheskomu (', average: 0:3 ,')');

end else begin writeln ('geometricheskomu (', geometricmean: 0:3 ,')'); end;

readln;

end.

12.Опісаніе: Зведення в ступінь для цілого показника, обчислюваного за час log2 (ступінь).

Program power_maximal;

Uses crt;

Var a, b, c: integer; function power (x, pow: integer): integer; var res: integer;

begin res: = 1;

while (pow> 0) do beginif (pow and 1 = 1) then res: = res * x;

x: = x * x;

pow: = pow shr 1; end;

power: = res; end;

Begin Clrscr;

Writeln ('input a, b:');

Readln (a, b);

c: = power (a, b);

Writeln ('a ^ b =', c);

Readkey;

End. '

13.Опісаніе: арккосинуса числа. Знаходження з математичних міркувань

var ca, al, albeg: real; function ArcCos (arg: real): real;

var r: real;

begin if (abs (arg)> 1) then begin writeln ('Unavailable argument');

halt; end;

if abs (arg) <0.000001 then r: = pi / 2 else r: = ArcTan (sqrt (1/arg/arg-1)); {arccos}

if arg <0 then r: = pi-r;

ArcCos: = r; end;

begin albeg: = pi / 2 +0.2;

ca: = cos (albeg);

al: = arccos (ca);

writeln ('ArcCos (', ca: 10:7 ,')=', al: 10:7, 'AlBeg =', albeg: 10:7,

'ChekSum =', al-albeg, 'Must be sero');

readln;

end.

14.Опісаніе: Чи є в рядку числові значення

Function NumInStr (S: String): Boolean;

VAR C, I: INTEGER; N: BOOLEAN;

BEGIN; I: = 0;

Repeat;

I: = I +1;

C: = Ord (S [I]);

N: = ((C> = 48) AND (C <= 57));

Until (NOT N) OR (I = Length (S));

NumInStr: = N;

END;

15.Опісаніе: Знаходження функції методом половинного ділення

program half_del;

uses crt;

type ms = array [1 .. 100] of real; {[x, y]}

var Eps, XH, DX, Y, z, X, YH, P, S, A, B: real; N, U, Er: integer; masx, masy: ms; Function F (X: real): real;

beginF: = exp (x) + x * x-2

end;

Function FuncA (Eps, s, p, YH: real): real;

begin if F (p) * F (s) <0 then begin YH: = 0.5 * (p + s);

while abs (F (YH))> EPS do begin If F (p) * F (YH) <0 then S: = YH else P: = YH;

YH: = 0.5 * (P + S) end; end else er: = 1;

FuncA: = YH; end;

procedure P1 (a, b, XH: real; N: integer); var z, q: real; u: integer;

begin if x> 1 then begin Z: = sqrt (X * sqrt (X-1));

a: = FuncA (Eps, s, p, YH);

for U: = 1 to N do begin masx [U]: = X;

masy [U]: = sin (x) / z;

X: = X + DX; end;

{Else writeln ('Error: x <1');} end; end;

Begin clrscr;

write ('vvedite eps:'); readln (eps);

Write ('vvedite dx:'); readln (DX);

write ('vvedite N:'); readln (N);

write ('vvedite x> 1:'); readln (x);

if x1; writeln;

Writeln ('--------------------');

Writeln ('| X | Y');

writeln ('--------------------');

P1 (a, b, XH, N);

for U: = 1 to N do writeln ('', masx [u]: 10:7, '', masy [u]: 10:7); readln;

end.

Розділ: Файли

1.Описание: Вирішує найпростіші арифметичні приклади записані у файл.

program pn12;

var f: text; s, sa, sb: string; c: char; i, a, b, o, j, code: integer; m, op: set of char;

begin m: = ['1 ', '2', '3 ', '4', '5 ', '6', '7 ', '8', '9 ', '0'];

op :=['+','-','*','/'];

assign (f, 'file.txt'); reset (f);

while not (eof (f)) do begin readln (f, s);

writeln (s);

for i: = 2 to length (s) -1 do if (s [i] in op) and (s [i-1] in m) and (s [i +1] in m) then begin j: = 1 ;

sa :='';

while (s [ij] in m) and (ij> 0) do begin sa: = s [ij] + sa;

j: = j +1 end;

j: = 1;

sb :='';

while (s [i + j] in m) and (i + j <= length (s)) do begin sb: = sb + s [i + j];

j: = j +1 end;

val (sa, a, code); val (sb, b, code);

case s [i] of '+': O: = a + b;

'-': O: = ab;

'*': O: = a * b;

'/': O: = a div b; end;

writeln (a, s [i], b ,'=', O, '')

end; end; close (f);

readln;

end.

2.Опісаніе: Робота з текстовими файлами передбачає собою: створення, редагування, додавання, видалення.

Program one;

uses Dos, Crt;

var f: text;

FileName: string [9];

st: string; ch: char; vibor: byte;

procedure Head;

begin Writeln ('esli vy otkazyvaetes ot deistviya, to naberite v nazvanii faila simvola ""');

Write ('vvedite imya faila :>');

Readln (FileName);

if FileName = '~' then halt (1) else Assign (f, FileName); end;

procedure TextEdit;

begin Writeln ('Seichas vy smojetedobavlyat informaciyu v file.');

Writeln ('esli vyzahotite prekratit vvod, to naberite sleduschuyu posledovatelnost :"~~"');

repeat Write ('>'); Readln (st);

if st <>'~~' then Writeln (f, st);

until st ='~~'; end;

procedure WriteToFile;

begin Head;

ReWrite (f);

TextEdit;

Close (f);

Writeln ('Vy okonchili vvodit info v file.Najmite lubuyu knopku ...');

ReadKey; end;

procedure ReadFromFile;

Head;

Reset (f);

if IOresult <> 0 then begin Writeln ('file', FExpand (filename), 'ne sushestvuet.');

Writeln ((Y / N ).');

ch: = ReadKey;

if (ch = 'Y') or (ch = 'y') then ReadFromFile;

end else begin Writeln ('Soderjimoe faila:'); Writeln;

while not eof (f) do begin Readln (f, st);

Writeln ('>', st); end;

Close (f);

Writeln;

Writeln ('Najmite lubuyu knopku');

ReadKey; end; end;

procedure AddToFile;

begin Head;

Append (f);

if IOresult <> 0 then begin

Writeln ('faila', FExpand (filename), 'ne sushestvuet.');

Writeln ('hotite vvesti drugoe imya faila? (Y / N ).');

ch: = ReadKey;

if (ch = 'Y') or (ch = 'y') then AddToFile; end else begin TextEdit; Close (f);

Writeln ('Vy okon4ili vvodit info v file.Najmite lubuyu knopku ...');

ReadKey; end; end;

procedure DelFile;

begin Head;

Reset (f);

if IOresult <> 0 then begin Writeln ('file', FExpand (filename), 'ne sushestvuet.');

Writeln ('hotite vvesti drugoe imya file?? (Y / N ).');

ch: = ReadKey; if (ch = 'Y') or (ch = 'y') then DelFile; end else begin Writeln ('vy uvereny 4to hotite udalit etot file? (Y / N)');

ch: = ReadKey; if (ch = 'Y') or (ch = 'y') then Erase (f);

Writeln ('vy tolko 4to udalili file.Najmite lubuyu klavishu ..');

Readkey; end; end;

procedure Menu;

begin repeat repeat ClrScr;

Writeln ('1. Record file / sozdanie faila ');

Writeln ('2. Read file ');

Writeln ('3. Dobavlenie info v file ');

Writeln ('4. Delet file ');

Writeln ('5. Exit ');

Write ('Vash vybor :>'); Readln (vibor);

until (vibor> 0) and (vibor <6);

Writeln;

Write (', л ўлЎа «Е:');

case vibor of 1: begin Writeln ('record file / sozdanie faila');

WriteToFile; end;

2: begin Writeln ('read file');

ReadFromFile; end;

3: begin Writeln ('Dobavlenie info v file');

AddToFile; end;

4: begin Writeln ('delet file');

DelFile; end; end;

until vibor = 5; end;

begin Menu;

end.

3.Описание: Дан файл, що містить текст і арифметичні вирази виду, а * у, де * - один із знаків +, -, *, /. Виписати всі арифметичні вирази і обчислити їх значення

program pn12;

var f: text; s, sa, sb: string; c: char; i, a, b, o, j, code: integer; m, op: set of char;

begin m: = ['1 ', '2', '3 ', '4', '5 ', '6', '7 ', '8', '9 ', '0'];

op :=['+','-','*','/'];

assign (f, 'e: \ tp \ tp6 \ Arif.dat'); reset (f);

while not (eof (f)) do begin readln (f, s);

writeln (s);

for i: = 2 to length (s) -1 do if (s [i] in op) and (s [i-1] in m) and (s [i +1] in m) then begin j: = 1 ;

sa :='';

while (s [ij] in m) and (ij> 0) do begin sa: = s [ij] + sa;

j: = j +1 end;

j: = 1; sb :='';

while (s [i + j] in m) and (i + j <= length (s)) do begin sb: = sb + s [i + j];

j: = j +1 end;

val (sa, a, code); val (sb, b, code);

case s [i] of '+': O: = a + b;

'-': O: = ab; '*': O: = a * b; '/': O: = a div b; end;

writeln (a, s [i], b ,'=', O, '')

end; end;

close (f);

end.

4.Опісаніе: Вивести максимальне число з файлу in. Txt

Program one;

var t: text; i, p, code: integer; s: string; m: array [1 .. 100] of real; max: real;

begin assign (t, 'in.txt'); reset (t);

read (t, s);

i: = 0;

repeat p: = pos ('', s);

inc (i);

val (copy (s, 1, p-1), m [i], code);

delete (s, 1, p);

until p = 0;

max: = m [1];

for p: = 2 to i do if m [p]> max then max: = m [p];

writeln ('MAX =', max);

close (t);

readln;

end.

5.Опісаніе: Перекодування файлу з формату DOS у формат Windows.

Program one;

var f, g: text; i, p, n: integer; m: array [1 .. 100] of string; s: string;

begin assign (f, 'in.txt'); reset (f);

assign (g, 'out.txt'); rewrite (g);

while not eof (f) do begin readln (f, s); {зчитуємо чергову рядок}

i: = 0; {ставимо лічильник слів на 0}

repeat inc (i); {збільшуємо лічильник поточного ПРОПОЗИЦІЇ}

p: = pos ('', s); {дивимося де знаходиться пробіл}

m [i]: = copy (s, 1, p-1); {записуємо поточне слово в масив}

delete (s, 1, p); {те слово, яке запрісалі в масив - видаляємо}

until p = 0; {****************}

n: = i +1; {кінець масиву}

if s [length (s )]='.' then begin m [n]: = copy (s, 1, length (s) -1); m [1]: = m [1 ]+'.' {то цю точку переміщаємо на 1 слово}

end else m [n]: = s; {а якщо немає точки - то просто його записуємо в масив}

writeln (g);;

for i: = n downto 1 do write (g, m [i], ''); {йдемо з кінця масиву в початок і записуємо слова в зворотному порядку} end;

writeln ('PEREZAPISANO ...'); readln;

close (f); close (g);

end.

6.Опісаніе: Видалення наступних один за одним декількох прогалин з файлу.

Program one;

const

FileName: String = 'Strings.txt';

VAR f: Text; S: String;

BEGIN Assign (f, FileName); {$ I-} Reset (f); {$ I +}

if IOResult = 0 then begin ReadLn (f, S); Close (f) end;

WriteLn ('input string:', S);

while (POS ('', S)> 0) do delete (S, POS ('', S), 1);

if (length (S)> 1) and (S [1] = '') then Delete (S, 1, 1);

if (length (S)> 1) and (S [length (S)] = '') then Delete (S, length (S), 1);

writeln ('output string:', s);

readln;

END.

7.Описание: Вивести вміст файлу в зворотному порядку в новий файл.

program one;

uses crt;

var fl1, fl2: text; a, b: string; i, l: longint;

begin clrscr;

assign (fl1, 'input.txt');

assign (fl2, 'output.txt'); reset (fl1); readln (fl1, a);

close (fl1);

l: = length (a);

for i: = l downto 1 do b: = b + a [i];

rewrite (fl2); write (fl2, b);

close (fl2);

write (b); readln;

end.

8.Опісаніе: Бінарний пошук елемента в тіпізрованном longint файлі.

program searches;

uses crt, dos;

type longint_file = file of longint;

procedure files_names_query (var read_file, error: string; var search_value: longint);

var f: text;

begin error :='';

write (''зчитує файл: ');

readln (read_file);

assign (f, read_file);

reset (f);

if (ioresult = 0) then begin close (f);

write ('находиме значення = ');

readln (search_value);

end else begin error: = 'помилка: файл НЕ існує '; end; end;

function bin_search (left, right, search_value: longint; var f: longint_file): boolean;

var center, value, new_left, new_right, right_value, center_value: longint;

begin if (left = right) then begin seek (f, left);

read (f, value);

if (value = search_value) then begin bin_search: = TRUE;

end else begin bin_search: = FALSE; end;

end else begin center: = ((left + right) div 2) +1;

seek (f, right);

read (f, right_value);

seek (f, center);

read (f, center_value);

if ((search_value> = center_value) and (search_value <= right_value)) then begin new_left: = center;

bin_search: = bin_search (new_left, right, search_value, f);

end else begin new_right: = center-1;

bin_search: = bin_search (left, new_right, search_value, f); end; end; end;

function search (read_file: string; search_value: longint): boolean;

var f: longint_file;

finded: boolean;

elements_count: longint;

begin assign (f, read_file);

reset (f);

finded: = FALSE;

elements_count: = filesize (f);

finded: = bin_search (0, elements_count-1, search_value, f);

close (f);

search: = finded; end;

procedure writing_to_file (write_file: string; finded: boolean; begin_time: longint);

var f: text; hour, minutes, seconds, seconds100: word; end_time: longint; time: real;

begin gettime (hour, minutes, seconds, seconds100);

end_time: = minutes * 60 * 100 + seconds * 100 + seconds100;

time: = (end_time-begin_time) / 100;

assign (f, write_file);

rewrite (f);

if (finded) then writeln (f, 'ok') else writeln (f, 'error');

writeln (f, time: 4:2);

close (f); end;

procedure writing (finded: boolean; begin_time: longint);

begin if (finded) then begin writeln ('Element finded complete');

end else begin writeln ('Element not finded'); end;

readln; end;

var read_file, write_file, error, search_value_string: string; hour, minutes, seconds, seconds100: word;

begin_time, search_value: longint; k: integer; result: boolean;

begin gettime (hour, minutes, seconds, seconds100);

begin_time: = minutes * 60 * 100 + seconds * 100 + seconds100;

if (paramstr (1 )<>'') then begin read_file: = paramstr (1);

search_value_string: = paramstr (2);

val (search_value_string, search_value, k);

write_file: = paramstr (3);

result: = search (read_file, search_value);

writing_to_file (write_file, result, begin_time);

end else begin files_names_query (read_file, error, search_value if (error ='')

then begin result: = search (read_file, search_value);

writing (result, begin_time);

end else begin writeln (error);

writeln ('натисніть Enter для продовження. ");

readln; end; end;

end.

9.Опісаніе: Вивести таблично результати розрахунку функції y = sin (x) / x на вказаному діапазоні у файл.

Program one;

Const M = 24;

Var FName: Text; AB, H, X: Real;

Function F (X: Real): Real;

Begin F: = Abs (Sin (X) / X);

End;

Begin Write ('vvedite na4alo diapazona:');

ReadLn (A);

Write ('vvedite konec diapazona:');

ReadLn (B);

WriteLn ('sozdayu LA-BA.TAB');

H: = (BA) / M;

X: = A;

Assign (FName, 'LA-BA.TAB');

ReWrite (FName);

WriteLn (FName, 'X | F (X)');

While (X <= B) Do Begin WriteLn (FName, X, '|', F (X));

X: = X + H;

End;

Close (FName);

End.

10.Опісаніе: Дан файл, що містить текст. Скільки слів у тексті? Скільки цифр в тексті?

program one;

Const mn = ['0 '.. '9'];

Var f3: text; i, j, ch, sl: integer; name: string; s: char; wrd: string;

Begin writeln ('vvedite imya faila');

readln (name);

assign (f3, name);

reset (f3);

s: = ''; sl: = 0; ch: = 0;

while not eof (f3) do begin readln (f3, wrd);

i: = 1;

While i <= length (wrd) do begin if wrd [i] <> '' then sl: = sl +1;

while (wrd [i] <> '') and (i <= length (wrd)) do inc (i);

inc (i) end; end;

close (f3);

reset (f3);

while not eof (f3) do begin while not eoln (f3) do begin read (f3, s);

if (s in mn) then ch: = ch +1;

end; readln (f3); end;

writeln ('4 islo slov: ', sl,' 4islo cifr: ', ch);

close (f3);

End.

11.Опісаніе: Замінити синонімами слова у файлі

program;

var f1, f2, f3: text; i, n, k, l: integer; s, sout, ss, slovoT, slovo, sinonim: string;

begin assign (f1, 'text1.txt');

assign (f2, 'text2.txt'); assign (f3, 'text3.txt');

rewrite (f1);

writeln (', ўҐ ¤ Е⥠⥪бв: ');

repeat readln (s);

writeln (f1, s)

until s ='';

close (f1); reset (f1);

rewrite (f3);

while not (eof (f1)) do begin readln (f1, s);

s: = s + '';

sout :='';

while length (s)> 0 do begin l: = pos ('', s);

slovoT: = copy (s, 1, l-1);

delete (s, 1, l);

reset (f2);

while not (eof (f2)) do begin readln (f2, ss);

k: = pos (',', ss); sinonim: = copy (ss, 1, k-1);

if sinonim = slovoT then slovoT: = copy (ss, k +1, length (ss)-k) end;

close (f2);

sout: = sout + slovot + '' end;

writeln (s);

writeln (f3, sout) end;

close (f3); reset (f3);

while not (eof (f3)) do begin readln (f3, s);

writeln (s) end;

close (f3); readln

end.

12.Опісаніе: Очистити файл, залишивши лише перший рядок.

program one;

uses crt;

var fl1: text; a: string; i, l, poz: longint; label m;

begin clrscr;

assign (fl1, 'input.txt');

reset (fl1); readln (fl1, a); close (fl1);

l: = length (a);

rewrite (fl1);

for i: = 1 to l do if a [i ]='.' then begin poz: = i; goto m; end;

m: for i: = 1 to poz do write (fl1, a [i]); close (fl1);

writeln ('complete !!!');

readkey;

end.

13.Опісаніе: Виведення статистики по файлу

program one; uses crt; var infile: text; file_name, s: string; i, commas, points, blanks, lines: integer; begin clrscr; commas: = 0; points: = 0; blanks: = 0; lines: = 0; write ('vvedite imya faila'); readln (file_name); assign (infile, file_name); reset (infile); while not eof (infile) do begin readln (infile, s); for i: = 1 to length (s) do begin case s [i] of ',': inc (commas); '.' : Inc (points); '': inc (blanks); end; end; inc (lines); end; close (infile); gotoxy (1,3); writeln ('zapyatih:', commas); writeln (' predlogenii: ', points); writeln (' probelov: ', blanks); writeln (' strok: ', lines); readln; end.

14 Задано файл F, компонентами якого є цілі числа. Переписати у файл G спочатку всі негативні, потім всі нульові, а потім всі позитивні числа, упорядкувавши їх за зростанням модуля величини. Файл G - текстовий. Program Pascal; Const fname = 'num.txt'; fname2 = 'num2.txt'; Var f, g: text; stroka: string; k, code, i, j, tmp: integer; a: array [1 .. 20] of integer; begin Assign (F, fName); ReSet (F); k: = 0; While Not Eof (F) Do Begin ReadLn (F, Stroka); k: = k +1; val (Stroka, tmp, code); a [k]: = tmp; writeln (a [k]); End; close (f); writeln; writeln (k); writeln; for i: = 2 to k do for j: = k downto 2 do if a [j-1]> a [j] then begin tmp: = a [j-1]; a [j-1]: = a [j]; a [j]: = tmp; end; for i: = 1 to k do write (a [i], ''); Assign (g, fName2); rewrite (g); for i: = 1 to k do begin writeln (g, a [ i]); end; close (g); writeln; readln; end.

15 Задано тектовий файл, що містить текст. Визначити скільки разів зустрічається в ньому найдовше слово.

program tp7; const razd = ['','.',',','?','!',':',')','(']; var f: text; s, slo, slovo, name: string; k, i: integer; begin write ('Введіть ім'я файлу: '); readln (Name); assign (f, name); reset (f); slovo :=''; k: = 0; while not (EOF (F)) do begin readln (f, s); slo :=''; for i: = 1 to length (s) do begin if s [i] in razd then begin if (i> 1) and not (s [i-1] in razd) then begin if (length (slo) = length (slovo)) and (slo = slovo) then k: = k +1; if length (slo)> length (slovo) then begin slovo: = slo; k: = 1 end; end; slo: =''end else begin slo: = slo + s [i] end; end; if (length (slo) = length (slovo)) and (slo = slovo) then k: = k +1; if length (slo) > length (slovo) then slovo: = slo; end; writeln ('слово', slovo, 'зустрічається', k, 'раз'); close (f); readln end.

Розділ: Записи

1.Описание: У файл вводяться імена, стать і зріст людини. Програма зчитує дані з файлу і видає збіги, якщо в ньому є чоловіки одного зросту.

program one;

const n = 2;

type group = record

ser: string [30]; p: string [1]; h: 100 .. 250;

end;

var person: array [1 .. n] of group; f: text; r: boolean; ar: array [1 .. n] of integer; i, j, z, obr: integer;

begin assign (f, 'AAAAAAA.txt');

rewrite (f);

for i: = 1 to n do with person [i] do begin writeln ('person', i);

writeln (f, 'person', i);

writeln ('sername');

readln (ser);

writeln (f, 'sername:', ser, '');

writeln ('pol');

readln (p);

writeln (f, 'pol:', p, '');

writeln ('rost');

readln (h);

writeln (f, 'rost:', h, '');

writeln (f);

writeln; end;

close (f);

reset (f);

append (f);

writeln (f, 'poisk dvuh men s odinakovim rostom');

j: = 1; for i: = 1 to n do begin with person [i] do begin if (p = 'm') or (p = 'M') then begin ar [j]: = h;

j: = j +1; z: = j-1; end; end; end;

r: = false;

for j: = 1 to z do begin obr: = ar [j]; i: = j;

repeat if ar [i +1] = obr then r: = true else i: = i +1;

until (i> z) or (r); end;

if r = true then writeln (f, 'sovpadenie naydeno');

if r = false then writeln (f, 'sovpadenie ne naydeno');

close (f);

readln;

end.

2.Опісаніе: Телефонний довідник

program one; type Zapis = record fam: string; tel: string;

end; var out: file of Zapis; nam: Zapis; kon: char; begin assign (out, 'nomera'); rewrite (out); repeat write ('fam?'); readln (nam.fam); write ( 'nomer?'); readln (nam.tel); write (out, nam); writeln ('prodolgim? y / N'); readln (kon); until kon <> 'y'; reset (out); while not eof (out) do begin read (out, nam); writeln (nam.fam ,'-', nam.tel); end; close (out); end.

3.Описание: Програма, яка створює файл з описом студентів:

program one;

type TStudentInfo = record name: string [30]; kurs: string [20]; ekz: array [1 .. 5] of byte; end; var f: file of TStudentInfo; st: TStudentInfo; p: byte; begin assign ( f, 'students.dat'); reset (f); {Відкриємо   файл. Позиція   на   даний   момент   в   самому   початку} if ioresult <> 0 then rewrite (f);   {Якщо   помилка,   занчіт   файлу   немає,   і   значить   откоем   його   поіншому} seek (f, filesize (f));

with st do repeat write ('Введіть   ім'я   студента   (Порожню   рядок   для   виходу):   '); Readln (name); if name =''then break; write (' Введіть   курс: '); readln (kurs); for p: = low (ekz) to high (ekz) do begin write (' Введіть   оцінку   по   іспиту   № ', p,':   '); Readln (ekz [p]); end; write (f, st);   {Ось   ця   рядок   і   записує   інформацію   про   студента   в   файл} until false; close (f);   {Цю   команду   ми   ще   НЕ   розглядали,   але   про   цьому   я   розповім   в   Наприкінці} end.

4.Опісаніе: Виконується введення дати послідовно: число, місяць, рік. Програма перевіряє наявність помилок при введенні.

program lab 4;

uses crt;

type day = 1 .. 31; mon = 1 .. 12; year = 1 .. 3000;

var data: record

d: day; m: mon; y: year; end; s: boolean;

function vernaydat: boolean;

begin with data do begin write ('chslo:');

readln (d);

write ('mesyc:');

readln (m);

write ('god:');

readln (y);

s: = true;

if y> 3000 then s: = false;

if m> 12 then s: = false;

case m of 1,3,5,7,8,10,12: begin if d> 31 then s: = false; end;

4,6,9,11: begin if d> 30 then s: = false; end;

2: begin if (y mod 4) <> 0 then if d> 28 then s: = false;

if (y mod 4) = 0 then if d> 29 then s: = false;

end; end;

if s = true then write ('OK');

if s = false then write ('ERROR'); end; end;

begin clrscr;

writeln ('Vvedite datu');

Vernaydat; readln;

end.

5.Опісаніе: Формування бази даних інформації про студентів. Висновок з таблиці список студентів:-отримали оцінку 4;-які отримали оцінки 4 та 5;-прізвище яких починається на "А".

Program Laba6;

Uses Crt;

Type Exam = Record

Name: String [20]; Year: Integer; Lesson: String [10]; Prise: Integer;

End;

Mass = Array [1 .. 30] Of Exam;

Var Student: Mass; Prise1, Prise2, Num, I: Integer; Letter: Char;

Procedure InputStudent (Var InpNum: Integer);

Var I: Integer;

Begin ClrScr;

Write ('4 islo studentov: ');

ReadLn (InpNum);

For I: = 1 To InpNum Do Begin Write ('vvvedite familiyu stud nomer', I, '[20]:'); ReadLn (Student [I]. Name);

Write ('god rojden stud nomer', I, ':'); ReadLn (Student [I]. Year);

Write ('predmet studenta nomer', I, '[10]:'); ReadLn (Student [I]. Lesson);

Write ('ocenka stud nomer', I, ':'); ReadLn (Student [I]. Prise);

WriteLn; End; End;

Procedure OutLine (Line: Integer);

Begin Write (Student [Line]. Name: 20);

Write (Student [Line]. Year: 6);

Write (Student [Line]. Lesson: 10);

Write (Student [Line]. Prise: 7);

WriteLn; End;

Procedure OutStudent (OutNum: Integer); Var I: Integer;

Begin ClrScr;

WriteLn ('familiya': 20, 'god': 6, 'predmet': 10, 'ocenka': 7);

For I: = 1 To OutNum Do OutLine (I); End;

Procedure OutStudentPrise1 (OutNum, OutPrise: Integer); Var Col, I: Integer;

Begin WriteLn;

Col: = 0;

WriteLn ('dannye o stud-h polu4ivshih ocenki:', OutPrise);

For I: = 1 To OutNum Do If (Student [I]. Prise = OutPrise) Then Begin Col: = Col +1;

OutLine (I); End;

WriteLn ('4 islo stud polu4ivshih ocenku ', OutPrise,': ', Col); End;

Procedure OutStudentPrise2 (OutNum, OutPrise1, OutPrise2: Integer);

Var I: Integer;

Begin WriteLn;

WriteLn ('dannye o stud polu4ivshih ocenku:', OutPrise1, 'Е', OutPrise2);

For I: = 1To OutNum Do If ((Student [I]. Prise = OutPrise1) Or (Student [I]. Prise = OutPrise2)) Then OutLine (I);

End;

Procedure OutStudentName (OutNum: Integer; OutLetter: Char); Var I: Integer;

Begin WriteLn;

WriteLn ('dannye o studentah 4i familii na4inayutsa na "', OutLetter ,'"');

For I: = 1 To OutNum Do If (Copy (Student [I]. Name, 1,1) = OutLetter) Then OutLine (I); End;

Begin InputStudent (Num);

OutStudent (Num); Prise1: = 4;

OutStudentPrise1 (Num, Prise1); Prise2: = 5;

OutStudentPrise2 (Num, Prise1, Prise2); Letter: = 'Ђ';

OutStudentName (Num, Letter);

ReadLn;

End.

6.Опісаніе: Дана таблиця матеріалів з ​​наступною інформацією по кожному матеріалу: назва, питома вага, вид провідності (діелектрик, напівпровідник, провідник). Виписати з таблиці всі напівпровідники та їх питома вага.

program one;

Uses CRT;

Const Veshestvo = 1;

Type Material = Record

Name: String [20]; Weight: Real; Provod: Integer;

End;

Var Result, I, J, N: Integer; F: Array [1 .. 20] Of Material; Begin

F [1]. Name: = 'med'; F [1]. Weight: = 4.00; F [1]. Provod: = 2;

F [2]. Name: = 'bumaga'; F [2]. Weight: = 66.0; F [2]. Provod: = 0;

F [3]. Name: = 'ЉаҐ ¬ Е ©'; F [3]. Weight: = 5.40; F [3]. Provod: = 1;

F [4]. Name: = 'germany'; F [4]. Weight: = 21.5; F [4]. Provod: = 1;

F [5]. Name: = 'arsenid gallia'; F [5]. Weight: = 3.00; F [5]. Provod: = 1;

F [6]. Name: = 'alluminiy'; F [6]. Weight: = 50.0; F [6]. Provod: = 2;

F [7]. Name: = 'keramika'; F [7]. Weight: = 9.90; F [7]. Provod: = 0;

F [8]. Name: = 'rezina'; F [8]. Weight: = 80.0; F [8]. Provod: = 0;

F [9]. Name: = 'ftoroplast'; F [9]. Weight: = 4.00; F [9]. Provod: = 0;

ClrScr;

N: = 9;

Result: = 0;

Writeln ('naimenovanie materiala udelny ves provodimost');

Writeln ('----------------------------------------------- ------------');

For I: = 1 to N Do If (F [I]. Provod = Veshestvo) Then Begin

Write (F [I]. Name: 22, F [I]. Weight: 15:2);

Case F [I]. Provod Of

0: WriteLn ('izolyator': 15);

1: WriteLn ('poluprovodnik': 15);

2: WriteLn ('provodnik': 15); End;

Result: = Result + 1; End;

Writeln ('----------------------------------------------- ------------');

Writeln ('naideno', Result, 'material.');

If Result = 0 Then WriteLn ('takogo materiala net'); Readln;

End.

7.Описание: Вивести з введеної рядка слова з максимальною кількістю входжень буквл 'l' і 'o' і підрахувати кількість цих входжень.

Type Info = record

wrd, num: Byte; ch: Char;

End;

Var S, Temp: String; P, I: Byte; M, N: Info;

Function CalkChar (A: String; C: Char): Byte; Var I, Result: Byte;

Begin Result: = 0;

For I: = 1 To Length (A) Do If UpCase (A [I]) = UpCase (C) Then Inc (Result);

CalkChar: = Result;

End;

Begin WriteLn ('vvedite frazu po-angl:');

ReadLn (S);

I: = 1;

M.num: = 0; M.wrd: = 0; M.ch: = 'l';

N.num: = 0; N.wrd: = 0; N.ch: = 'o';

While Pos ('', S) <> 0 Do Begin P: = Pos ('', S);

Temp: = Copy (S, 1, P);

If M.wrd <CalkChar (Temp, M.ch) Then Begin M.num: = I;

M.wrd: = CalkChar (Temp, M.ch); End;

If N.wrd <CalkChar (Temp, N.ch) Then Begin N.num: = I;

N.wrd: = CalkChar (Temp, N.ch); End;

Delete (S, 1, P); Inc (I); End;

If M.wrd <CalkChar (S, M.ch) Then Begin M.num: = I;

M.wrd: = CalkChar (S, M.ch); End;

If N.wrd <CalkChar (S, N.ch) Then Begin N.num: = I;

N.wrd: = CalkChar (S, N.ch); End;

WriteLn ('-------------');

If M.wrd <> 0 Then WriteLn ('bukva', M.ch, '4 asche vstre4aetsa v ', M.num,' - ¬ slove, celyh ', M.wrd,' raz () ');

If N.wrd <> 0 Then WriteLn ('bukva', N.ch, '4asche vstre4aetsa v', N.num, '-m slove, celyh', N.wrd, 'raz ()'); readln;

End.

8.Опісаніе: З вихідної таблиці іграшок з полями: назва іграшки, вартість, вікові обмеження, виписати відомості для іграшок вартістю менше 4 рублів, що підходять дітям 5 років.

Uses CRT;

Const Vozrast = 5;

Cena = 400;

Type Toy = Record

Name: String [20]; Sale: Integer; Min: Integer; Max: Integer;

End;

Var Sum, Result, I, J, N: Integer; F: Array [1 .. 20] Of Toy;

Begin

F [1]. Name: = 'mya4'; F [1]. Sale: = 400; F [1]. Min: = 1; F [1]. Max: = 9;

F [2]. Name: = 'kukla'; F [2]. Sale: = 660; F [2]. Min: = 3; F [2]. Max: = 7;

F [3]. Name: = 'samolet'; F [3]. Sale: = 540; F [3]. Min: = 3; F [3]. Max: = 5;

F [4]. Name: = 'pupsik'; F [4]. Sale: = 210; F [4]. Min: = 1; F [4]. Max: = 3;

F [5]. Name: = 'knijka'; F [5]. Sale: = 300; F [5]. Min: = 1; F [5]. Max: = 5;

F [6]. Name: = 'mashinka'; F [6]. Sale: = 500; F [6]. Min: = 3; F [6]. Max: = 8;

F [7]. Name: = 'parovoz'; F [7]. Sale: = 990; F [7]. Min: = 4; F [7]. Max: = 7;

F [8]. Name: = 'ula'; F [8]. Sale: = 800; F [8]. Min: = 2; F [8]. Max: = 5;

F [9]. Name: = 'konstruktor'; F [9]. Sale: = 400; F [9]. Min: = 6; F [9]. Max: = 9;

ClrScr;

N: = 9;

Result: = 0;

Sum: = 0;

Writeln ('igryshka cena, kop. Min vozrast Max vozrast');

Writeln ('----------------------------------------------- ------------');

For I: = 1 to N Do If (F [I]. Min <= Vozrast) And (Vozrast <= F [I]. Max) And (F [I]. Sale <= Cena) Then Begin

WriteLn (F [I]. Name: 20, F [I]. Sale: 12, F [I]. Min: 14, F [I]. Max: 13);

Result: = Result + 1; Sum: = Sum + F [I]. Sale; End;

Writeln ('----------------------------------------------- ------------');

Writeln ('stoimost pokupki:', Sum/100: 3:2, 'rub.');

If Result = 0 Then WriteLn ('pokupku sovershit nevozmojno!');

Readln;

End.

9.Опісаніе: З першої таблиці, де задані коефіцієнти для рівнянь завдання ліній виписати в нову таблицю тільки ті коефіцієнти, які формують лінію, паралельну першою в вихідній таблиці.

Uses CRT;

Type Line = Record

A, B, C: Integer;

End;

Var Result, I, J, N: Integer; F, G: Array [1 .. 20] Of Line;

Begin

F [1]. A: = 1; F [1]. B: = 9; F [1]. C: = 2;

F [2]. A: = 2; F [2]. B: = 6; F [2]. C: = 3;

F [3]. A: = 3; F [3]. B: = 5; F [3]. C: = 1;

F [4]. A: = 4; F [4]. B: = 2; F [4]. C: = 4;

F [5]. A: = 3; F [5]. B: = 3; F [5]. C: = 1;

F [6]. A: = 2; F [6]. B: = 5; F [6]. C: = 2;

F [7]. A: = 1; F [7]. B: = 9; F [7]. C: = 5;

F [8]. A: = 2; F [8]. B: = 6; F [8]. C: = 1;

F [9]. A: = 3; F [9]. B: = 5; F [9]. C: = 2;

ClrScr;

N: = 9; Result: = 0; I: = 1;

For J: = 2 to N Do If (F [I]. A = F [J]. A) And (F [I]. B = F [J]. B) Then Begin Write ('liniya', I, 'paralelna linii', J, '');

WriteLn (F [I]. A, 'X +', F [I]. B, 'Y +', F [I]. C);

Result: = Result + 1; End;

Writeln ('naideno', Result, 'liniy');

If Result = 0 Then WriteLn ('takih liniy net');

Readln;

End.

10.Опісаніе: Є запис про багаж пасажира (к-ть речей та загальна вага речей). З'ясувати, чи є пасажир, багаж якого перевищує багаж кожного з решти пасажирів і за кількістю речей і по вазі. Дати відомості про багажі, число речей в якому не менше, ніж у будь-якому іншому багажі, а вага речей не більше, ніж у будь-якому іншому багажі.

uses crt; type bagaj = record ves: double; kol_veshei: integer; end; var bagage: array [1 .. 20] of bagaj; i, j, n, temp: byte; rez, k: double; a: boolean; begin clrscr; writeln ('Vvedite kol-vo passajirov (n <= 20 ):'); readln (n); for i: = 1 to n do begin writeln (' Vvedite svedeniya o ', i,'-om bagaje passajira : '); writeln (' Vvedite ves bagaja: '); readln (bagage [i]. ves); writeln (' Vvedite kol-vo veshei bagaja: '); readln (bagage [i]. kol_veshei); end; clrscr ; writeln ('Bagage, sredniy ves odnoi veshi otlichaetsya ne bolee'); writeln ('chem na 0.3 kg ot obshego srednego vesa:'); writeln; a: = true; for i: = 1 to n do begin rez: = bagage [i] .ves / bagage [i]. kol_veshei; if (abs (bagage [i]. ves - rez) <= 0.3) then begin a: = false; writeln ('Bagage nomer', i); writeln ( 'ves bagaja:', (bagage [i]. ves): 5:2, 'kg'); writeln ('kol-vo veshei:', bagage [i]. kol_veshei); writeln; end; end; if ( a) then writeln ('Takogo bagaja net!'); writeln; writeln ('Kol-vo passajirov imeyushih bolee 2 veshei:'); writeln; temp: = 0; for i: = 1 to n do if (bagage [i ]. kol_veshei> 2) then temp: = temp +1; writeln ('Takih passajirov', temp, 'chelovek'); if temp = 0 then writeln ('Takih passajirov net!'); writeln; writeln ('Kol- vo veshei bolshe srednego chisla veshei: '); writeln; rez: = 0; temp: = 0; for i: = 1 to n do rez: = rez + bagage [i]. kol_veshei; for i: = 1 to n doif (bagage [i]. kol_veshei> (rez / n)) then temp: = temp +1; writeln ('Takih veshei', temp); if temp = 0 then writeln ('Takih veshei 0');. writeln; writeln ('Bagage iz 1 veshi s vesom ne menee 30 kg'); writeln; temp: = 0; for i: = 1 to n doif bagage [i]. kol_veshei = 1 thenif bagage [i]. ves> = 30 thentemp: = temp +1; writeln ('Imeetsya', temp, 'passajirov s takim bagajom'); readln; end.

11.Опісаніе: 1.Спісок книг складається з 10 записів. Запис містить поля: Прізвище автора, назва книги, рік ізданія.Найті назва книг даного автора, виданих з 1960 року. Program df; Uses crt; Type knigi = record Fam: string [15]; Naz: string [30]; Gad: integer; End; Var s: array [1 .. 10] of knidi; I, k: integer; Av : string; Begin clrscr; For i: = 1 tio 10 do begin with s [i] do begin Writeln (vvedi fam, i); Readln (fam); Writeln (vvedi nazv, i); Readln (nazv); Writeln ( god); Readln (god); End; end; Writeln (vvedi av); Readln (avt); K: = length (av); For i: = 1 to 10 do begin With s [i] do begin If (copy (fam, 1, k) = av) and (god> 1960) then writeln (nazv, nazv); End; End; End.

12.Опісаніе: З відомості 3-х студентів з їх оцінками (порядковий номер, П.І.Б. та три оцінки) визначити кількість відмінників і середній бал кожного студента. Program Spic; Type wed = record n: integer; fio: string [40]; bal: array [1 .. 3] of integer end; Var spisok: wed; i, j, kol, s: integer; sr: real; Begin kol: = 0; with spisok do For i: = 1 to 3 do begin n: = i; Write ('Vvedite FIO #', i, ''); Readln (fio); s: = 0; For j: = 1 to 3 do begin write ('Vvedite ocenky:'); readln (bal [j]); s: = s + bal [j]; end; if s = 15 then kol: = kol +1; sr: = s / 3; writeln (fio, ', Sredniy bal =', sr: 4:1); end; writeln ('Kolichestvo otlichnikov =', kol); readln; end.

13.Опісаніе: програма показує приклад об'єднання координат точок до запису. Тут використовується масив із записів типу RecPoint. Кожна така запис містить в собі поля з координатами x, y, z і поле коментаря. Таким чином, один запис описує одну точку, а масив із записів представляє собою набір крапок. Program Records; Uses crt; type RecPoint = record x, y, z: real; comment: string end; var Point: array [1 .. 10 ] of RecPoint; i: integrer; delta: real; begin Clrscr; for i: = 1 to 10 do begin Point [i]. x: = 2 * i - 3; Point [i]. y: = 3 * Point [ i]. x + 2; Point [i]. z: = 6 * Point [i]. y - 2 * Point [i]. x + 1; delta: = Point [i]. z - Point [i]. x; if delta> 100 then Point [i]. comment: = 'z - x> 100.' else Point [i]. comment: = 'Немає коментарів. '; end; Writeln (' Результа розрахунку (поля запису ):'); Write ('': 7, 'x'); Write ('': 8, 'y'); Write ('': 8, 'z'); Writeln ('коментарі'); for i: = 1 to 10 do begin Write (Point [i]. x: 8:3, ''); Write (Point [i]. y: 8:3, ''); Write (Point [i]. z : 8:3, '': 2); Writeln (Point [i]. comment); end; Readkey; end.

14.Опісаніе: Вирівнювання тексту

uses crt;

const

l = 79; {kolvo liter, umeshayushihsya na ekrane v DOSe}

var t: text; i, j: integer; s: string; c, ost: byte;

begin clrscr;

assign (t, 'input.txt'); reset (t);

while not EoF (t) do begin readln (t, s);

for i: = 1 to length (s) do if s [i] = '' then incc;

ost: = l - length (s); {ost - kolichestvo probelov, kotorie nado}

j: = 1;

while ost> 0 do begin for i: = 1 to length (s) + c - 1 do if (s [i] = '') then begin if ost <= 0 then break;

insert ('', s, i); dec (ost); inc (i, j); end;

inc (j); {tk pri prohozhdenii cikla FOR mi vstrechaem pervii probel} end;

c: = 0; {obyazatel'no obnulayem kol-vo strok v stroke}

writeln (s); end;

close (t); readkey;

end.

15.Опісаніе: Програма контролю студентів за літературе.Форміруется файл питань і відповідей

program zavd1;

uses crt;

const qfile = 'quest.txt'; afile = 'ansver.txt'; var f1, f2: text; i, k: integer; name, ansv: string;

begin clrscr;

assign (f1, qfile);

assign (f2, afile);

rewrite (f2);

reset (f1);

write ('vvedi imya? ¬ `п, gruppu:');

readln (name);

writeln (f2, name);

while not eof (f1) do begin readln (f1, name);

writeln (name);

write (', і ў? ¤ Ї ® ў? ¤ м: ');

readln (name);

writeln (f2, name);

readln (f1, ansv);

if ansv = name then k: = k +1;

i: = i +1; end;

writeln (f2, ', бм ® Ј ® ЇЕв  ­ м: ');

writeln (f2, i);

writeln (f2, 'Џа   ўЕ «м ­ Її ЇЕв  ­ м: ');

writeln (f2, k);

close (f1); close (f2);

end.

Розділ: Рядки

1. Опис: Із рядка повторюваних слів, відокремлених комами і закінчуються крапкою, виписати всі голосні літери в алфавітному порядку, які входять не більш ніж в одне слово.

program one;

Uses CRT;

Type MyType = Set Of Char; Var S, W: String; I, K, L: Integer; J: Char; M, N: MyType; B, C: Array [1 .. 32] of MyType;

Begin ClrScr;

M: = ['', 'Г', 'з', 'Е','®',' г', 'л', 'н', 'про', 'п']; S: = 'є « ҐЎ ,¬®«® Є ®, аЎг §, алЎ, ᥠ«Г ¤ Є. '; K: = 1;

writeln (s);

While pos (',', S)> 0 Do Begin W: = copy (S, 1, pos (',', S));

B [K]: = [];

For I: = 1 To Length (W) Do B [K]: = B [K] + [W [I]];

Inc (K);

delete (S, 1, pos (',', S)); End;

W: = S; B [K]: = [];

For I: = 1 To Length (W) Do B [K]: = B [K] + [W [I]];

For I: = 1 To K Do Begin C [I]: = B [I]; For L: = 1 To K Do If I <> L Then C [I]: = C [I] - B [L]; End;

N: = [];

For I: = 1 To K Do N: = N + C [I];

M: = M * N;

For J: = '' To 'п' Do If J in M Then Write (J, '');

WriteLn; ReadKey;

End.

2.Опісаніе: Основа алгоритму гри, відповідно до якої з слова зразка, яка є першим в рядку (у даному випадку Pascal), складаються інші слова з тих же букв. Кількість входжень однієї і тієї ж букви повинно бути не більше, ніж у зразку.

program one;

Uses CRT;

Var S, T: String; N, I, J: Integer; A: Array [1 .. 100] of String; F: Boolean;

Begin ClrScr;

S: = 'pascal cal lasca nosok pasca sapca lapca caplan capla';

N: = 1;

While pos ('', S)> 0 Do Begin A [N]: = copy (S, 1, pos ('', S) -1);

delete (S, 1, pos ('', S));

inc (N); End;

A [N]: = S;

For I: = 2 To N Do Begin F: = True;

T: = A [I];

For J: = 1 To Length (T) Do Begin If (pos (T [J], A [1]))> 0 Then T [J]: = '*' Else F: = False; End;

If F Then WriteLn (A [I]); End;

readln;

End.

3.Описание: Вивести кожне слово пропозиції задом наперед.

Program Stroki;

const chars =['.',',','!','?',' ']; var S, S_out, slovo: string; i, j: integer;

begin Writeln ('Vv stroku');

Readln (S);

S: = S + '';

for i: = 1 to Length (S) do if not (S [i] in chars) then Slovo: = slovo + S [i] else if slovo <>''then begin for j: = Length (slovo) downto 1 do S_out: = s_out + slovo [j];

s_out: = s_out + '';

slovo :=''; end;

Writeln (S_out);

Readln;

end.

4.Опісаніе: Розташувати слова в порядку зростання їх довжини в тексті.

program one;

uses crt;

var a, d, sl1, sl2: string; i, l, k, j: longint; b: array [1 .. 50] of string;

begin clrscr;

write ('input s:'); readln (a); l: = length (a);

if a =''then halt;

if a [l] <> '' then begin inc (l); a [l]: = ''; end;

for i: = 1 to l do if a [i] = '' then begin inc (j); b [j]: = d; d :=''; end else d: = d + a [i];

for i: = 1 to j-1 do for k: = i +1 to j do begin sl1: = b [i]; sl2: = b [k];

if length (sl1)> length (sl2) then begin b [i]: = sl2; b [k]: = sl1; end; end;

for i: = 1 to j do write ('', b [i]); readln;

end.

5.Опісаніе: Знайти і замінити певні символи в тексті (замінні) введеним символом з клавіатури (замінює). Кожну заміну супроводжувати підтвердженням.

program one;

uses crt;

var i, l: longint; a, a1, a2, p: string;

begin clrscr; textcolor (11);

write ('vvedite text:'); readln (a);

write ('zamenyaemyi simvol:'); readln (a1);

write ('zamenyauschiy simvol:'); readln (a2);

if (length (a1)> 1) or (length (a2)> 1) then halt; l: = length (a);

for i: = 1 to l do if a [i] = a1 then begin clrscr; a [i ]:='_';

writeln (a);

writeln ('Vy podtverzhdaete zamenu', i, '-ogo simvola? (y / n)'); readln (p);

if p = 'y' then a [i]: = a2 [1] else a [i]: = a1 [1]; end;

clrscr;

write (a); readln;

end.

6.Опісаніе: Знайти схоже слово в реченні, яке відрізняється не більше, ніж на два символи. Приклад: Pascal = Paskal = Pacsal.

program one;

var s, sl: string; m: array [1 .. 100] of string; i, j, k, p, n, kol: integer;

beginwrite ('Vvedite TEXT (slova cerez PROBEL):'); readln (s);

write ('ISCEM -?:'); readln (sl);

i: = 0;

repeat inc (i);

p: = pos ('', s);

m [i]: = copy (s, 1, p-1);

delete (s, 1, p);

until p = 0; n: = i; m [n]: = s;

writeln ('Naideno:'); writeln;

for i: = 1 to n do begin kol: = 0;

for j: = 1 to length (sl) do if pos (sl [j], m [i]) <> 0 then inc (kol);

if (length (m [i])-kol) <3 then writeln ('*', m [i]); end; readln;

end.

7.Описание: Підрахунок кількості слів у тексті.

program one;

uses crt;

var tec: string; l, i, n: longint;

begin clrscr;

write ('input s:'); readln (tec);

l: = length (tec) +1; tec [l]: = '';

for i: = 1 to l do if tec [i] = '' then n: = n +1;

write ('in s', n, 'words');

readln;

end.

8.Опісаніе: Максимальне слово в прдложеніі

program one;

Uses CRT;

Var MaxL, C: String; Pb: Byte;

Begin ClrScr;

WriteLn (vvedite predlojenie: '); ReadLn (C);

MaxL: ='';

While Pos ('', C) <> 0 Do Begin Pb: = Pos ('', C);

If Length (MaxL) <Length (Copy (C, 1, Pb-1)) Then MaxL: = Copy (C, 1, Pb-1);

Delete (C, 1, Pb); End;

If Length (MaxL) <Length (C) Then MaxL: = C;

WriteLn;

WriteLn ('Samaya bolshayaposledovatelnost'simvolov v predlojenii:');

WriteLn (MaxL);

ReadLn;

End.

9.Опісаніе: Виписати слова з рядка, які починаються з заданої літери.

program one;

uses crt;

var a, aa, b: string; i, l, o, oo: longint;

begin clrscr;

write ('string:'); readln (a);

write ('bukva:'); readln (aa); l: = length (a);

if length (aa)> 1 then halt;

if a [l] <> '' then begin inc (l); a [l]: = ''; end;

for i: = 1 to l do if a [i] = '' then begin if b [1] = aa then writeln (b) else inc (o); inc (oo); b :='';

end else b: = b + a [i];

if o = oo then write ('takix slov net!'); readln;

end.

10.Вводітся 10 літер, а потім слово. Перевіряється можливість скласти введене слово з цих символів.

program one;

uses crt;

var as: Array [1 .. 10] of Char; s, s2: String; i, b: Byte;

beginclrscr;

Writeln ('vvedite 10 simvolov:');

for i: = 1 to 10 do begin rite ('ь', i, ':');

readln (mas [i]); end;

write ('vvedite stroku:'); readln (s);

for i: = 1 to Length (s) do for b: = 1 to 10 do if s [i] = mas [b] then begin s2: = s2 + mas [b];

mas [b]: = ''; b: = 10; end;

if s2 = s then write ('Iz etih simvolov mozhno sostavit' slovo ', s) else writeln (' Iz etih simvolov nelzya sostavit slovo ', s);

readln;

end.

11.Опісаніе: Знайти в рядку мінімальне та максимальне слова

program gdy;

label 1;

var s: string; m: array [1 .. 100] of string; i, p, n: integer; ax, min: string; c: char;

begin 1: write ('Vvedite stroky:'); readln (s);

if s [length (s )]<>'.' then begin writeln ('ERROR: konec stroki okancivaetsia na "."'); goto 1; end;

if length (s)> 79 then begin writeln ('ERROR: stroka doljna biti <= 79 simvolov'); goto 1; end;

write ('Vvedite ZADANII SIMVOL:'); readln (c);

i: = 0;

repeat p: = pos ('', s);

if pos (c, copy (s, 1, p-1)) <> 0 then begin inc (i); m [i]: = copy (s, 1, p-1); end; delete (s, 1 , p); until p = 0; n: = i; f pos (c, copy (s, 1, length (s) -1)) <> 0 then begin n: = i +1; m [n]: = copy (s, 1, length (s) -1); end;

max: = m [1]; min: = m [1];

for i: = 2 to n do begin if length (m [i])> length (max) then max: = m [i];

if length (m [i]) <length (min) then min: = m [i]; end; writeln;

writeln ('MakS:', max);

writeln ('MIN:', min);

readln; readln;

end.

12.Опісаніе: Рахунок кількості входжень кожного символу в рядок.

program one;

Var I: Word; M: Array [0 .. 255] Of Byte; S: String;

Begin For I: = 0 To 255 Do M [I]: = 0;

writeln ('input string');

Readln (S);

For I: = 1 To Length (S) Do Begin Inc (M [ORD (S [I ])]); End;

For I: = 0 To 255 Do Begin If M [I]> 0 Then WriteLn (CHR (I): 3, M [I]: 3); End; readln;

End.

13.Опісаніе: Видалення пробілів з ​​заданого рядка і вивід результату.

program one;

Var S, T: String; I: Integer;

Begin writeln ('input string');

readln (s);

T: ='';

For I: = 1 To Length (S) Do Begin If (S [I] <> '') Then T: = T + S [I];

End;

WriteLn (T);

ReadLn;

End.

14.Опісаніе: Вивести заданий символ задану кількість разів

program one;

uses crt;

var n: byte; l: string; n function zvezda (n: byte; l: string): real; var i: integer; s: string;

begin i: = 1;

s :='';

while i <= n do begin s: = s + l;

inc (i); end;

writeln (s); end;

begin clrscr;

writeln ('Vvedite chislo'); readln (n);

writeln ('Vvedite simvol'); readln (l);

zvezda (n, l);

readkey;

end.

15.Опісаніе: Замінити рядок зірочками, якщо рядок містить лапки

Program one;

var S: string; i: integer;

found: boolean;

begin Write ('vvedite stroku simvolov:');

Readln (S); Found: = FALSE;

for i: = 1 to Length (S) do {Length (s) = довжина рядки, стандартна функція}

if s [i] =''''then found: = TRUE; if Found then {якщо знайдено символ "", замінюємо}

for i: = 1 to Length (S) do s [i]: = '*'; Writeln ('Rezultiruyuschaya stroka:', S);

readln;

end

Розділ: Графіка

1.Описание: Зелений перевернутий листок папороті, що заповнює точками.