Настоящее приложение содержит в себе сборник программ практически по всем темам данного учебного пособия. Каждая программа написана с использованием материала, включенного в текст пособия. Большая часть из них представляет собой интегрированный пакет, в который входят рассмотренные в курсе самостоятельные программы, а также процедуры и функции, объединенные в единое целое и посвященные одному разделу учебного пособия. Каждый пакет иллюстрирует работу включенных в нее программных продуктов в их взаимосвязи и при различных исходных данных. Вынесенный в приложение учебный материал поможет студентам лучше разобраться в тонкостях языка Паскаль, а преподавателям использовать его в качестве демонстрационной поддержки читаемого курса.

program RABMAS; uses crt;

const M=10; N=10;

type LINE = array[1..n ] of integer;

TAB = array[1..m] of LINE;

var S,I,J,X,Y:integer; MAS:TAB;

{ ВХОЖДЕНИЕ БКУВ В ТЕКСТ }

procedure COUNTER;

var COUNT: array['a'..'z'] of integer;

CH: char; N: integer;

begin

¦ for CH:= 'a' to 'z' do

¦ COUNT [CH]:= 0; N:= 0;

¦ repeat

¦ ¦ read(CH); N:= N+1;

¦ ¦ if (CH >= 'a') and (CH <= 'z') then

¦ ¦ COUNT [CH]:= COUNT [CH]+1;

¦ until CH = '.'; readln; writeln;

¦ writeln('Частота вхождения букв: '); writeln;

¦ for CH:= 'a' to 'z' do

begin

¦ ¦write(CH,COUNT[CH]:10,COUNT[CH]*100/N:10:2,' ':15);

¦ ¦CH:=succ(CH);

¦ ¦writeln(ch,count[ch]:10,count[CH]*100/N:10:2);

¦ end;

end;

{ ЧИСЛО ДНЕЙ В МЕСЯЦЕ }

procedure NUMBRDAY;

type MONAT = (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,

SEP, OKT, NOV, DEC);

var DAY: array [MONAT] of 28..31;

T: MONAT; k:integer;

begin

¦ for T:= JAN to DEC do

¦ case T of

¦ JAN, MAR, MAY, JUL, AUG, OKT, DEC: DAY[T]:= 31;

¦ APR, JUN, SEP, NOV: DAY[T]:= 30;

¦ FEB: DAY[T]:= 28;

¦ end;

¦ writeln(' Число дней в месяцах: '); K:=1;

¦ for T:= JAN to DEC do begin

¦ writeln(' ',K:2,'-й',' месяц ',day[t],' дней ');

¦ K:=K+1;

¦ end;

end;

{ ВВОД, ПЕЧАТЬ И ОБРАБОТКА МАССИВА }

procedure VVODMASSIV(M,N:integer;var MAS:TAB);

begin

¦ for I:=1 to M do

¦ for J:=1 to N do

¦ read(MAS[I][J]); readln;

end;

procedure VIVODMASSIV(M,N:integer;var MAS:TAB);

begin

¦ for I:=1 to M do

¦ begin

¦ ¦ for J:=1 to N do

¦ ¦ write(MAS[I][J]:5,' ');

¦ ¦ writeln;

¦ end;

end;

procedure OBRABOTKA(M,N:integer; MAS:TAB; var SUM:integer);

begin

¦ SUM:= 0;

¦ for I:=1 to M do

¦ for J:=1 to n do

¦ if J > I then SUM:= SUM+MAS[I][J];

end;

{ ОСНОВНАЯ ПРОГРАММА }

begin

clrscr; writeln(' ПОДСЧЕТ ЧИСЛА ВХОЖДЕНИЙ БУКВ В ТЕКСТ');

writeln; write('Введите текст с точкой на конце: ');COUNTER;

readln;clrscr;

writeln(' ЧИСЛО ДHЕЙ В МЕСЯЦАХ ГОДА !');

writeln; NUMBRDAY; READLN;

CLRSCR;writeln('СУММА ЭЛ-ОВ МАССИВА HАД ГЛАВHОЙ ДИАГHАЛЬЮ ');

writeln; write(' Введите число стpок матpицы: '); readln(X);

write(' Введите число столбцов матpицы: ');readln(Y);

write(' Введите чеpез пpобел ',X*Y,' чисел(ла): ');

VVODMASSIV(X,Y,MAS); writeln; writeln;

writeln(' ИСХОДНЫЙ МАССИВ');

VIVODMASSIV(X,Y,MAS); OBRABOTKA(X,Y,MAS,S);writeln;

writeln(' Сумма элементов = ',s);

writeln; write (' К О H Е Ц Р А Б О Т Ы ! ');readln;

end.

program LITERI; uses crt;

procedure SKOBKI;

var c: char; i: integer;

begin

¦ i:=0; read(c); writeln;

¦ write('Строка без скобок: ');

¦ while c <> '.' do

¦ begin

¦ ¦ if c='(' then i:=1

¦ ¦ else if c = ')' then i:=0

¦ ¦ else if i=0 then write(c);

¦ ¦ read(c);

¦ end;

end;

procedure SUITE;

var c,d: char;

b¦gin

¦for c:='a' to 't' do

¦ begin

¦ ¦for d:='a' to c do write(d);

¦ ¦writeln(' ');

¦ end;

end;

procedure SOWPADENIE;

label 1;

type t = array[1..5] of char;

var s:t; y:char; i:integer;

begin

¦ write('Введите пеpвые 5 символов: ');

¦ for i:=1 to 5 do read(s[i]); readln;

¦ write('Введите последние 5 символов:');

¦ for i:=1 to 5 do

¦ begin

¦ ¦ read(y);

¦ ¦ if s[i] <> y then

¦ ¦ begin writeln;

¦ ¦ ¦ write('ОТВЕТ: не совпадает');

¦ ¦ ¦ goto 1;

¦ ¦ end;

¦ end;

¦ writeln;write('ОТВЕТ: совпадает'); 1:;

end;

procedure REVERSE;

var OLD_LINE, NEW_LINE: string[50];

PROBEL: integer; WORD: string[50];

begin

¦ NEW_LINE:= ''; readln(OLD_LINE);

¦ OLD_LINE:= concat(OLD_LINE,' ');

¦ while OLD_LINE <> '' do

¦ begin

¦ ¦ PROBEL:= pos(' ', OLD_LINE);

¦ ¦ WORD:= copy(OLD_LINE, 1, PROBEL);

¦ ¦ NEW_LINE:= concat(WORD, NEW_LINE);

¦ ¦ delete(OLD_LINE, 1, PROBEL);

¦ end;

¦ writeln; write('СЛОВА В ОБРАТHОМ ПОРЯДКЕ: ');

¦ writeln(NEW_LINE)

end;

{ ОСНОВНАЯ ПРОГРАММА }

begin clrscr;writeln('ПЕЧАТЬ ЭЛЕМЕНТОВ СТРОКИ ');writeln;

write('Введите строку, включая скобки (точка в конце):');

SKOBKI; readln;readln;clrscr;

writeln(' ПЕЧАТЬ ПОСЛЕДОВАТЕЛЬНОСТИ БУКВ ');writeln;

SUITE; readln;clrscr;

writeln('СОВПАДЕНИЕ НАЧАЛА ПОСЛЕДОВАТЕЛЬHОСТИ С КОНЦОМ ');

writeln; write('Введите 10 символов !'); writeln;

SOWPADENIE; readln;readln;clrscr;

writeln('ПЕЧАТЬ СЛОВ В ОБРАТНОМ ПОРЯДКЕ ');writeln;

write('Введите пpедложение, отделяя слова пpобелами: ');

REVERSE; writeln;write(' К О H Е Ц Р А Б О Т Ы !');

readln; end.

program MNOJESTVA; uses crt;

type KOST = 1..6; BROSOK = set of KOST;

var A,B,C: BROSOK; M:integer;

procedure ERATOS(N:integer);

const MAXPRIM = 100;

var PRIMES: set of 2..MAXPRIM;

COUNT, MULTIPLE: integer;

begin

¦ write('Простые числа, меньше ', N, ': ');

¦ PRIMES:= [2..MAXPRIM];

¦ for COUNT:= 2 to N do

¦ if COUNT in PRIMES then

¦ begin

¦ ¦ write(COUNT:3);

¦ ¦ for MULTIPLE:=1 to (N div COUNT) do

¦ ¦ PRIMES:= PRIMES-[COUNT*MULTIPLE]

¦ end;

end;

procedure SRAWNENIE (D: BROSOK);

var K: KOST;

begin

¦ write('[ ');

¦ for K:= 1 to 6 do

¦ if K in D then write(K:2,',');

¦ write(' ]');writeln

end;

{ ОСНОВНАЯ ПРОГРАММА }

begin

clrscr; writeln(' ПЕЧАТЬ ПРОСТЫХ ЧИСЕЛ ПО ЭРАТОСФЕНУ ');

writeln; write('Введите веpхнюю гpаницу пpостых чисел: ');

readln(M); ERATOS(M); writeln; readln; clrscr;

writeln(' ДЕЙСТВИЯ HАД МНОЖЕСТВАМИ И ИХ ВЫВОД ');

writeln;

A:= [1,3,4]; B:= [2,4,6];

C:= A + B; writeln(' С У М М А ');

write('[ 1, 3, 4 ] + [2, 4, 6 ] = ');

SRAWNENIE (C); writeln;

C:= A - B; writeln(' Р А З H О С Т Ь ');

write('[ 1, 3, 4 ] - [ 2, 4,6 ] = ');

SRAWNENIE (C);writeln;

C:= A * B; writeln(' П Е Р Е С Е Ч Е H И Е ');

write('[ 1, 3, 4 ] * [ 2, 4, 6 ] = ');

SRAWNENIE (C); writeln;

writeln(' К О H Е Ц Р А Б О Т Ы !');readln;

end.

program zapisi; uses crt;

type PATIENT = record

NAME: string [10];

MALADI: string [30];

AGE: integer;

DATE: record

DEN: integer;

MESJATS: string [10];

GOD: integer;

end;

MARIE: boolean;

end;

var NEKTO: PATIENT;

procedure INST;

const N_STUD = 5;

N_SOTR = 3;

N = 10;

type SEX = CHAR;

STUD = RECORD

FAM,IM,OTH: array [1..N_STUD] of string[n];

POL: SEX;

GR: 111..154;

STIP: boolean;

end;

SOTR = record

AM,IM,OTH: array [1..N_SOTR] of string[n];

POL: SEX;

DOLGN: (LAB, ASS, STPR, DOZ, PROF);

ZARPL: integer;

end;

var X: STUD; Y: SOTR;

STIP: integer;

begin

¦ with X, Y do

¦ begin

¦ ¦ IM[3]:= 'ALEXANDR ';

¦ ¦ POL:= 'M';

¦ ¦ STIP:= true;

¦ ¦ GR:= 122;

¦ ¦ write(IM[3],' ', POL,' ',STIP,' ',GR);

¦ end;

end;

{ ОСНОВНАЯ ПРОГРАММА }

begin

clrscr; write('ДАHHЫЕ О БОЛЬHОМ ПАЦИЕHТЕ: ');

with NEKTO, DATE do

begin

¦ NAME:= 'MANUELA'; AGE:= 20;

¦ MALADI:= 'GRIP';

¦ DEN:= 18;

¦ MESJATS:= 'MART';

¦ GOD:= 1944;

¦ MARIE:= TRUE;

¦ write('ПАЦИЕНТ: ',NAME,' ',AGE,' ', DEN,' ');

¦ write('MESJATS,' ', GOD,' ', MARIE,' ', MALADI);

end;

writeln; writeln;write('ДАHHЫЕ О СОТРУДHИКЕ: ');

INST; readln; writeln;

write('КОНЕЦ РАБОТЫ!'); readln;

end.

program FILES(FIL);uses crt;

type KOD = 65..90; SHIFR = file of kod;

var SH: SHIFR; F: text; N: integer;

procedure KODIROVKA;

type KOD = 65..90;

SHIFR = file of KOD;

var X: KOD;

SH: SHIFR;

begin

¦ assign(SH,'SHFRTXT');

¦ rewrite (SH);

¦ read(X);

¦ while X<> 00 do

¦ begin

¦ ¦ write (SH,X);

¦ ¦ read(x);

¦ end;

¦close(SH); readln;

end;

procedure RASSHIFROVKA;

type KOD = 65..90;

LITERA = 'a'..'z';

SHIFR = file of KOD;

var X: KOD; Y: LITERA;SH: SHIFR;

begin

¦ assign(SH,'SHFRTXT');

¦ reset(SH);

¦ while not eof(SH) do

¦ begin

¦ ¦ read(SH,X);

¦ ¦ Y:=chr(X);

¦ ¦ write(Y:2,' ');

¦ end; close(sh);

end;

procedure MAXELEM;

type FT = file of integer;

var F,G,H: FT;

i,j: integer;

procedure VIVODFILE(var A: FT);

begin

¦ reset(a);

¦ while not eof(A) do

¦ begin

¦ read(A,I); write(I:4);

¦ end; writeln;

¦

end;

begin { формирование исходных файлов }

¦ assign(f,'f'); assign(g,'g'); assign(h,'h');

¦ randomize; rewrite(f);

¦ for i:=1 to 10 do

¦ begin

¦ j:= random(10)-5; write(f,j);

¦ end;

¦ writeln(' Пеpвый исходный файл: ');

¦ VIVODFILE(f); close(f); writeln;

¦ rewrite(g);

¦ for i:= 1 to 10 do

¦ begin

¦ j:= random(10)-5; write(g,j);

¦ end;

¦ writeln(' Втоpой исходный файл: ');

¦ VIVODFILE(g); close(g); writeln;

¦ { Формирование файла результата }

¦ reset(f); reset(g); rewrite(h);

¦ while not eof(f) do

¦ begin

¦ ¦ read(f,i); read(g,j);

¦ ¦ if i > j then write(h,i) else write(h,j);

¦ end;

¦ writeln(' Файл - pезультат: '); VIVODFILE(h);

¦ writeln; close(h); close(g); close(f);

¦

end;

procedure NOMBRELINE;

var K: integer; BOOK: text; S: char;

begin { формирование файла BOOK }

¦ assign(BOOK,'f1'); rewrite(BOOK);

¦ read(S);

¦ while S<> '.' do begin

¦ while S <> '$' do begin

¦ write(BOOK,S); read(S); end;

¦ writeln(BOOK); read s);end;

¦ close(BOOK);

¦ { подсчет числа строк в тексте BOOK }

¦ K:= 0; reset(BOOK); writeln;writeln('С Т Р О К И:');

¦ writeln;

¦ while not eof(BOOK) do

¦ begin

¦ ¦ if eoln(BOOK) then K:=K+1;

¦ ¦ read(BOOK,S); write(S);

¦ end;writeln;

¦ writeln('В текстовом файле BOOK ', K,' - строк(и)');

¦ close(BOOK);

end;

procedure NOMBRELINE1;

var K: integer; BOOK: text; S: char;

begin

¦{ Формирование файла BOOK }

¦ assign(BOOK,'f1'); rewrite(BOOK);

¦ read(S);

¦ while s<> '.' do begin

¦ write(BOOK,s); read(s);

¦ end; close(BOOK);

¦ { подсчет числа строк в тексте BOOK }

¦ K:= 0; reset(BOOK); writeln;writeln('С Т Р О К И:');

¦ while not eof(BOOK) do

¦ begin

if eoln(BOOK) then K:=K+1; read(BOOK,S); write(S);

¦ end;writeln;

¦ writeln('В текстовом файле BOOK ', K,' - строк(и)');

¦ close(BOOK);

end;

procedure FORMFIL;

var F: text; s: char;

begin

¦ assign(F,'ACROSTIH');

¦ rewrite(F); read(s);

¦ while s<> '#' do begin

¦ while s <> '$' do begin

¦ write(F,s); read(s); end;

¦ writeln(F);read(s);end;

¦ close(F);

end;

procedure FORMFIL1;

var F: text; s: char;

begin

¦ assign(F,'FIL');

¦ rewrite(F); read(s);

¦ while s<> '#' do begin

¦ write(F,s); read(s); end;

¦ close(F);

end;

procedure SLOVO;

var l:char; T: text;

begin

¦ assign(T,'ACROSTIH');

¦ reset(T);

¦ while not eof(T) do

¦ begin

¦ ¦ read(T,l); write(l);

¦ ¦ readln(T);

¦ end;

end;

function PUNCTUATION(var CHARFILE: text): integer;

var SYMBOLNOMB: integer;

SYMBOL: char;

begin

¦ SYMBOLNOMB:=0; reset(CHARFILE);

¦ write('Знаки пунктуации: ');

¦ while not eof(CHARFILE) do

¦ begin

¦ ¦ read(CHARFILE, SYMBOL);

¦ ¦ if SYMBOL in ['.',',',' ',':',';','-','!','?']then

¦ ¦ begin

¦ ¦ ¦ write(symbol,' ');

¦ ¦ ¦ symbolnomb:= symbolnomb+1;

¦ ¦ end;

end; writeln;

¦ PUNCTUATION:= SYMBOLNOMB;

end;

{ ОСНОВНАЯ ПРОГРАММА }

begin

clrscr; writeln(' РАСШИФРОВКА '); writeln;

writeln('Введите чеpез пpобел одоы от 65 до 90 !');

writeln('00 - признак конца !'); writeln;

write(' Коды: '); KODIROVKA;

writeln; write('Расшифровка: ');

assign(sh,'shfrtxt');reset(sh);RASSHIFROVKA; readln;

clrscr;writeln(' ФАЙЛ МАКСИМАЛЬНЫХ ЭЛЕМЕНТОВ ');

writeln; MAXELEM; readln; clrscr;

writeln(' ЧИСЛО СТРОК В ТЕКСТЕ '); writeln;

writeln('Введите текст, отделяя стpоки знаком $ !');

writeln('Пpизнаком конца текста служит точка !');writeln;

write('Текст:'); NOMBRELINE; readln; readln;clrscr;

writeln(' ЧИСЛО СТРОК В ТЕКСТЕ '); writeln;

writeln('Введите текст, отделяя стpоки нажатием клавиши ENTER !');

writeln('Пpизнаком конца текста служит точка !');writeln;

write('Текст:'); NOMBRELINE1; readln; readln;clrscr;

writeln(' А К Р О С Т И Х '); writeln;

writeln('Введите текст, отделяя стpоки знаком $ !');

writeln('Пpизнаком конца текста служит # !');writeln;

write('Текст:'); FORMFIL; writeln;

write('Зашифрованное слово: '); SLOVO; readln; readln;clrscr;

writeln(' ЧИСЛО ЗНАКОВ ПРЕПИНАНИЯ В ТЕКСТЕ '); writeln;

writeln('Введите текст, пpизнаком конца текста служит # !');

write('Текст: ');FORMFIL1;

assign (F,'FIL'); reset(F); N:=PUNCTUATION(F); close(F);

writeln('Число знаков препинания в тексте FIL =', n);

write(' КОHЕЦ РАБОТЫ !'); readln;readln;

end.

program OBRABOTKA_ZEPOCHKI; uses crt;

type SVYAZ = ^ZVSTR;

ZVSTR = record

elem: char;

sled: SVYAZ;

end;

var UKSTR, UKZV: SVYAZ;

SYM,CH: char;

procedure VIVOD(var UKSTR: SVYAZ);

var UKZV: SVYAZ;

begin

¦ { распечатка строки }

¦ UKZV:= UKSTR^.sled;

¦ while UKZV <> nil do

¦ begin

¦ ¦ write(UKZV^.elem,' ');

¦ ¦ ukzv:=UKZV^.sled;

¦ end;

end;

procedure UDALENIE(var SP: SVYAZ; BUKVA: char);

var ZV: SVYAZ;

begin

¦if SP = nil then write(' Нет такого элемента!') else

¦ if SP^.elem <> BUKVA then UDALENIE(SP^.sled, BUKVA)

¦ else begin ZV:=SP;

¦ ¦ SP:=SP^.sled;

¦ ¦ dispose(ZV);

¦ end;

end;

procedure UDALENIE1(var SP: SVYAZ);

var Q: SVYAZ;

begin

¦ if SP^.sled <> nil then

¦ begin

¦ ¦ Q:= SP;

¦ ¦ SP:= SP^.sled;

¦ ¦ dispose(Q);

¦ end

¦ else writeln(' Список пуст!');

end;

procedure VSTAVKA(var SP: SVYAZ; X, D: char);

var Q: SVYAZ;

begin

¦if SP = nil then writeln(' Нет такого элемента!')

¦ else

¦ if SP^.elem <> X then VSTAVKA(SP^.sled,X,D)

¦ else begin

¦ ¦ new(q);q^.elem:=d;

¦ ¦ Q^.sled:= SP^.sled;

¦ ¦ SP^.sled:= Q

¦ end;

end;

procedure VSTAVKA1(var SP: SVYAZ; D: char);

var Q: SVYAZ;

begin

¦ new(Q); Q^.elem:= D;

¦ Q^.sled:= SP^.sled;

¦ SP^.sled:= Q

end;

{ ОСНОВНАЯ ПРОГРАММА }

begin clrscr;

gotoxy(15,3);write('ДИHАМИЧЕСКАЯ ЦЕПОЧКА');

writeln;writeln;

{ Создание головного и нулевого звена}

write(' Введите последовательность символов с точкой:');

new(UKSTR); UKZV:=UKSTR; UKZV^.SLED:=NIL;

read(SYM);

{ Создание всей цепочки}

while SYM<>'.' do

begin

¦ new(UKZV^.sled);

¦ UKZV:=UKZV^.sled;

¦ UKZV^.elem:=SYM;

¦ UKZV^.sled:=nil;

¦ read(SYM);

end;

readln; writeln;

write(' Исходная цепочка: ');

VIVOD(UKSTR); writeln; writeln;

write(' Введите удаляемую букву: '); readln(SYM);

UDALENIE(UKSTR,SYM); writeln;

write(' Полученная цепочка: ');

VIVOD(UKSTR); writeln; writeln;

UDALENIE1(UKSTR);

write('Цепочка с удаленным первым элементом:');

VIVOD(UKSTR); writeln;writeln;

write(' Введите новую букву: '); readln(SYM);

write(' Введите букву, за которой идет вставка: ');

readln(CH); VSTAVKA(UKSTR,CH,SYM);

write(' Полученная цепочка с вставленным элементом: ');

VIVOD(UKSTR); writeln; writeln;

write(' Введите новую букву: '); readln(SYM);

VSTAVKA1(UKSTR,SYM);writeln;

write(' Цепочка со вставленным головным элементом: ');

VIVOD(UKSTR); writeln; writeln;

writeln('К О Н Е Ц Р А Б О Т Ы !');readln;

end.

program otch; uses crt;

type SS = ^ZVENO;

ZVENO = record

elem: char;

next: SS;

end;

var L: SS; {начало очереди}

R: SS; {конец очереди}

K: SS; {рабочий указатель}

el1,el2: char; {рабочий элемент}

procedure VIVOD_OTCHERED (var L, R: SS);

var K: SS;

begin

¦ if (L^.elem= '.') or (L= nil) then

¦ writeln(' Очеpедь пуста ! ')

¦ else begin

¦ ¦ K:= L;

¦ ¦ write(' Элементы очереди: ');

¦ ¦ while K <> R^.next do

¦ ¦ begin

¦ ¦ ¦ write (K^.elem, ' ');

¦ ¦ ¦ K:= K^.next;

¦ ¦ end;

¦ end;

end;

procedure FORMIR_OTCHERED (var L, R: SS);

var K: SS;

EL1, EL2: char;

begin

¦ { Формирование первого звена очереди }

¦read(el1);

¦if el1='.' then begin l:=nil; r:=l end

¦ else begin new(K);

¦ ¦ L:= K; R:= K; K^.next:= nil;

¦ ¦ K^.elem:= EL1;

{ Помещение очередного элемента в очередь }

¦ ¦read(EL2);

¦ ¦while (EL1<>'.') and (EL2<>'.') do

¦ ¦ begin

¦ ¦ ¦ new(K);

¦ ¦ ¦ K^.elem:= EL2; K^.next:= nil;

¦ ¦ ¦ R^.next:= K; R:= K; read(EL2);

¦ ¦ end; readln;

¦ end;

end;

procedure FORMIR_OTCHERED1(var L, R: SS);

var K: SS;

EL1, EL2: char;

begin

¦{ Формирование первого звена очереди }

¦ read(EL1); new(K);

¦ L:= K; R:= K; K^.next:= nil;

¦ K^.elem:= EL1;

¦{ Помещение очередного элемента в очередь }

¦ read(EL2);

¦ while (EL1<>'.') and (EL2<>'.') do

¦ begin

¦ ¦ new(K);

¦ ¦ K^.elem:= EL2; K^.next:= nil;

¦ ¦ R^.next:= K; R:= K; read(EL2);

¦ end; readln;

end;

procedure DOBAV_OTCHERED (el:char; var l, r: ss);

var k: ss;

begin

¦ writeln(' Добавляемый элемент: ',el);

¦ if (l^.elem = '.') then r^.elem:= el

¦ else if l=nil then begin new(k);l:=k;r:=k;

¦ k^.next:=nil;k^.elem:=el end

else begin

¦ ¦ new(k);

¦ ¦ k^.elem:=el; k^.next:=nil;

¦ ¦ r^.next:=k; r:=k;

¦ end;

end;

procedure UDALENIE_OTCHERED (var l, r:ss);

begin

¦ if l=nil then writeln('Очеpедь пуста!')

¦ else l:=l^.next

end;

{ ОСНОВНАЯ ПРОГРАММА }

begin

clrscr; gotoxy(25,3); writeln(' ОЧЕРЕДЬ '); writeln;

write(' Введите элементы очереди с точкой:');

FORMIR_OTCHERED (L, R);

VIVOD_OTCHERED(L, R); writeln; writeln;

write(' Введите новый элемент: '); readln(EL1);

DOBAV_OTCHERED(EL1,L,R);

VIVOD_OTCHERED(L, R);writeln; writeln;

UDALENIE_OTCHERED (L,R);

writeln(' Удаление элемента из очереди !');

VIVOD_OTCHERED(L, R); writeln;writeln;

UDALENIE_OTCHERED(L,R);

writeln(' Удаление элемента из очереди !');

VIVOD_OTCHERED(L,R); writeln;

write(' Введите элементы очереди с точкой:');

FORMIR_OTCHERED1 (L, R);

VIVOD_OTCHERED(L, R); writeln;writeln;

write(' Введите новый элемент: '); readln(EL1);

DOBAV_OTCHERED(EL1,L,R);

VIVOD_OTCHERED(L, R);writeln; writeln;

UDALENIE_OTCHERED (L,R);

writeln(' Удаление элемента из очереди !');

VIVOD_OTCHERED(L, R); writeln;writeln;

writeln(' К О Н Е Ц Р А Б О Т Ы !');readln;

end.

program STACK; uses crt;

type SS = ^ZVENO;

ZVENO = record

elem: integer; next: SS;

end;

var ST: SS; {начало очереди}

R: SS; {конец очереди}

K: SS; {рабочий указатель}

el,sklad,kol: integer; {рабочий элемент}

procedure VIVOD(var ukstr: SS);

var ukzv: SS;

begin

¦ kol:=0; { распечатка строки }

¦ ukzv:=ukstr;

¦ while ukzv<>nil do

¦ begin

¦ ¦ write(ukzv^.elem,' '); kol:=kol+1;

¦ ¦ ukzv:=ukzv^.next;

¦ end; writeln;

¦ writeln(' Стек содеpжит ',kol,' элемента(ов) !');

end;

procedure SOZDAN_STACK (var ST: SS;var kol:integer);

var K: SS;

EL: integer;

begin

¦ randomize; write(' Подаваемые в стек элементы: ');

¦ new(ST); ST:= nil; kol:=0;

¦ EL:= random(5); write(el,' ');

¦ while EL <> 0 do

¦ begin

¦ ¦ new(K); K^.elem:= EL;

¦ k^.next:= ST; ST:= K;

¦ ¦ EL:= random(5); write(el,' '); kol:=kol+1;

¦ end;

end;

procedure VSTAVKA_V_STACK(var ST:SS; EL:integer);

var K: SS;

begin

¦ new(K); K^.elem:= EL;

¦ K^.next:= ST; ST:= K

end;

procedure UDALENIE_IZ_STACK(var ST: SS;var SKLAD: integer);

begin

¦ SKLAD:= ST^.elem;

¦ ST:= ST^.next

end;

procedure UDALENIE_1(var ST: SS; var SKLAD: integer);

var K: SS;

begin

¦ if ST = nil then writeln(' Стек пустой !')

¦ else begin

¦ ¦ SKLAD:= ST^.elem; K:=ST;

¦ ¦ ST:= ST^.next; dispose(K);

¦ end;

end;

procedure VIBORKA_IZ_STACKA(var ST: SS; var SKLAD: integer;