учебник по паскалю. Программа 5 Алгоритм 5 Свойства алгоритма 6 Формы записи алгоритма 6
 Скачать 2.21 Mb.
|
Приложение 4. Дополнительные листинги программ1. Решение системы линейных алгебраических уравнений Ax=b методом Гаусса. program Slau; uses crt; const size=30; {максимально допустимая размерность} type matrix=array [1..size,1..size+1] of real; type vector=array [1..size] of real; function GetNumber (s:string; a,b:real):real; {Ввод числа из интервала a,b. Если a=b, то число любое} var n:real; begin repeat write (s); {$I-}readln (n);{$I+} if (IoResult<>0) then writeln ('Введено не число!') else if (a writeln ('Число не в интервале от ', a,' до ',b) else break; until false; GetNumber:=n; end; procedure GetMatrix (n,m:integer; var a:matrix); {ввод матрицы} var i,j:integer; si,sj: string [3]; begin for i:=1 to n do begin str (i,si); for j:=1 to m do begin str (j,sj); a[i,j]:=GetNumber ('a['+ si+ ','+ sj+ ']=', 0,0); end; end; end; procedure GetVector (n:integer; var a:vector); {ввод вектора} var i:integer; si:string [3]; begin for i:=1 to n do begin str (i,si); a[i]:=GetNumber ('b['+si+']=',0,0); end; end; procedure PutVector (n:integer; var a:vector); {вывод вектора} var i:integer; begin writeln; for i:=1 to n do writeln (a[i]:10:3); end; procedure MV_Mult (n,m:integer; var a:matrix;var x,b:vector); {умножение матрицы на вектор} var i,j:integer; begin for i:=1 to n do begin b[i]:=0; for j:=1 to m do b[i]:=b[i]+a[i,j]*x[j]; end; end; function Gauss (n:integer; var a:matrix; var x:vector):boolean; {метод Гаусса решения СЛАУ} {a - расширенная матрица системы} const eps=1e-6; {точность расчетов} var i,j,k:integer; r,s:real; begin for k:=1 to n do begin {перестановка для диагонального преобладания} s:=a[k,k]; j:=k; for i:=k+1 to n do begin r:=a[i,k]; if abs(r)>abs(s) then begin s:=r; j:=i; end; end; if abs(s) {нулевой определитель, нет решения} Gauss:=false; exit; end; if j<>k then for i:=k to n+1 do begin r:=a[k,i]; a[k,i]:=a[j,i]; a[j,i]:=r; end; {прямой ход метода} for j:=k+1 to n+1 do a[k,j]:=a[k,j]/s; for i:=k+1 to n do begin r:=a[i,k]; for j:=k+1 to n+1 do a[i,j]:=a[i,j]-a[k,j]*r; end; end; if abs(s)>eps then begin {обратный ход} for i:=n downto 1 do begin s:=a[i,n+1]; for j:=i+1 to n do s:=s-a[i,j]*x[j]; x[i]:=s; end; Gauss:=true; end else Gauss:=false; end; var a,a1:matrix; x,b,b1:vector; n,i,j:integer; begin n:=trunc(GetNumber ('Введите размерность матрицы: ',2,size)); GetMatrix (n,n,a); writeln ('Ввод правой части:'); GetVector (n,b); for i:=1 to n do begin {делаем расширенную матрицу} for j:=1 to n do a1[i,j]:=a[i,j]; a1[i,n+1]:=b[i]; end; if Gauss (n,a1,x)=true then begin write ('Решение:'); PutVector (n,x); write ('Проверка:'); MV_Mult (n,n,a,x,b1); PutVector (n,b1); end else write ('Решения нет'); reset (input); readln; end. 2. Процедурно-ориентированная реализация задачи сортировки одномерного массива по возрастанию. program sort; const size=100; type vector=array [1..size] of real; procedure GetArray (var n:integer; var a:vector); var i:integer; begin repeat writeln ('Введите размерность массива:'); {$I-}readln (n); {$I+} if (IoResult<>0) or (n<2) or (n>size) then writeln ('Размерность должна быть от 2 до ',size); until (n>1) and (n for i:=1 to n do begin write (i,' элемент='); readln (a[i]); end; end; procedure PutArray (n:integer; var a:vector); var i:integer; begin writeln; for i:=1 to n do writeln (a[i]:10:3); end; procedure sortArray (n:integer; var a:vector); var i,j:integer; buf:real; begin for i:=1 to n do for j:=i+1 to n do if a[i]>a[j] then begin buf:=a[i]; a[i]:=a[j]; a[j]:=buf; end; end; var a:vector; n:integer; begin GetArray (n,a); sortArray (n,a); write ('Отсортированный массив:'); PutArray (n,a); end. 3. Вычисление всех миноров второго порядка в квадратной матрице. program minor2_count; const size=10; type Matrix= array [1..size,1..size] of real; function minor2 (n:integer; i,j,l,k:integer; a:matrix):real; begin minor2:=a[i,j]*a[l,k]-a[l,j]*a[i,k]; end; procedure Input2 (var n:integer; maxn:integer; var a:matrix); var i,j:integer; begin repeat writeln; write ('Введите размерность матрицы ', '(от 2 до ',size,' включительно):'); readln (n); until (n>1) and (n for i:=1 to n do begin writeln; write ('Введите ',i,' строку матрицы:'); for j:=1 to n do read (a[i,j]); end; end; var i,j,k,l,n:integer; s:real; a:matrix; begin Input2 (n,size,a); for i:=1 to n do for j:=1 to n do for l:=i+1 to n do for k:=j+1 to n do begin s:=minor2 (n,i,j,l,k,a); writeln; writeln ('Минор [',i,',',j,']'); writeln (' [',l,',',k,']=',s:8:3); end; end. 4. Учебная база данных "Студенты". type student = record {Определение записи "Студент"} name:string[20]; balls:array [1..4] of integer; end; const filename='students.dat'; {Имя базы данных} var s:student; {Текущая запись} f:file of student; {Файл базы данных} kol,current:longint; {Количество записей и текущая запись} size:integer; {Размер записи в байтах} st1,st2:string; {Буферные строки для данных} procedure Warning (msg:string); {Сообщение-предупреждение} begin writeln; writeln (msg); write ('Нажмите Enter для продолжения'); reset (input); readln; end; procedure out; {Закрытие базы и выход} begin close (f); halt; end; procedure Error (msg:string); {Сообщение об ошибке + выход из программы} begin writeln; writeln (msg); write ('Нажмите Enter для выхода'); reset (input); readln; out; end; procedure open; {открыть, при необходимости создать файл записей} begin assign (f,filename); repeat {$I-} reset (f); {$I+} if IoResult <> 0 then begin Warning ('Не могу открыть файл '+filename+ '... Будет создан новый файл'); {$I-}rewrite (f);{$I+} if IoResult <> 0 then Error ('Не могу создать файл! '+ 'Проверьте права и состояние диска'); end else break; until false; end; procedure getsize (var kol:longint; var size:integer); {Вернет текущее число записей kol и размер записи в байтах size} begin reset (f); size:=sizeof(student); if filesize(f)=0 then kol:=0 else begin seek(F, Filesize(F)); kol:=filepos (f); end; end; function getname (s:string):string; {Переводит строку в верхний регистр c учетом кириллицы DOS} var i,l,c:integer; begin l:=length(s); for i:=1 to l do begin c:=ord(s[i]); if (c>=ord('а')) and (c<=ord('п')) then c:=c-32 else if (c>=ord('р')) and (c<=ord('я')) then c:=c-80; s[i]:=Upcase(chr(c)); end; getname:=s; end; procedure prints; {Вспомогательная процедура печати - печатает текущую s} var i:integer; begin write (getname(s.name),': '); for i:=1 to 4 do begin write (s.balls[i]); if i<4 then write (','); end; writeln; end; procedure print (n:integer); {Вывести запись номер n (с переходом к ней)} begin seek (f,n-1); read (f,s); prints; end; procedure go (d:integer); {Перейти на d записей по базе} begin writeln; write ('Текущая запись: '); if current=0 then writeln ('нет') else begin writeln (current); print (current); end; current:=current+d; if current<1 then begin Warning ('Не могу перейти на запись '+ 'с номером меньше 1'); if kol>0 then current:=1 else current:=0; end else if current>kol then begin str (kol,st1); Warning ('Не могу перейти на запись '+ 'с номером больше '+st1); current:=kol; end else begin writeln ('Новая запись: ',current); print (current); end; end; procedure search; {Поиск записи в базе по фамилии} var i,found,p:integer; begin if kol<1 then Warning ('База пуста! Искать нечего') else begin writeln; write ('Введите фамилию (часть фамилии)', ' для поиска, регистр символов любой:'); reset (input); readln (st1); st1:=getname(st1); seek (f,0); found:=0; for i:=0 to kol-1 do begin read (f,s); p:=pos(st1,getname(s.name)); if p>0 then begin writeln ('Запись номер ',i+1); prints; found:=found+1; if found mod 10 = 0 then Warning ('Пауза...'); {Пауза после вывода 10 найденных} end; end; if found=0 then Warning ('Ничего не найдено...'); end; end; procedure add; {Добавить запись в конец базы} var i,b:integer; begin repeat writeln; write ('Введите фамилию студента ', 'для добавления:'); reset (input); readln (st1); if length(st1)<1 then begin Warning ('Слишком короткая строка!'+ ' Повторите ввод'); continue; end else if length(st1)>20 then begin Warning ('Слишком длинная строка! '+ 'Будет обрезана до 20 символов'); st1:=copy (st1,1,20); end; s.name:=st1; break; until false; for i:=1 to 4 do begin repeat writeln; {следовало бы предусмотреть возможность ввода не всех оценок} write ('Введите оценку ',i,' из 4:'); {$I-}readln (b);{$I+} if (IoResult<>0) or (b<2) or (b>5) then begin Warning ('Неверный ввод! Оценка - '+ 'это число от 2 до 5! Повторите.'); continue; end else begin s.balls[i]:=b; break; end; until false; end; seek (f,filesize(f)); write (f,s); kol:=kol+1; current:=kol; end; procedure delete; {Удаление текущей записи} var f2:file of student; i:integer; begin if kol<1 then Warning ('База пуста! Удалять нечего') else begin assign (f2,'students.tmp'); {$I-}rewrite(f2);{$I+} if IoResult<>0 then begin Warning ('Не могу открыть новый файл '+ 'для записи!'+#13+#10+ ' Операция невозможна. Проверьте '+ 'права доступа и текущий диск.'); Exit; end; seek (f,0); for i:=0 to kol-1 do begin if i+1<>current then begin {переписываем все записи, кроме текущей} read (f,s); write (f2,s); end; end; close (f); {закрываем исходную БД} erase (f); {Удаляем исходную БД, проверка IoResult опущена!} rename (f2,filename); {Переименовываем f2 в имя БД} close (f2); {Закрываем переименованный f2} open; {Связываем БД с прежней файловой переменной f} kol:=kol-1; if current>kol then current:=kol; end; end; procedure sort; {сортировка базы по фамилии студента} var i,j:integer; s2:student; begin if kol<2 then Warning ('В базе нет 2-х записей!'+ ' Сортировать нечего') else begin for i:=0 to kol-2 do begin {Обычная сортировка} seek (f,i); {только в учебных целях - работает неоптимально} read (f,s);{и много обращается к диску!} for j:=i+1 to kol-1 do begin seek (f,j); read (f,s2); if getname(s.name)>getname(s2.name) then begin seek (f,i); write (f,s2); seek (f,j); write (f,s); s:=s2; {После перестановки в s уже новая запись!} end; end; end; end; end; procedure edit; {редактирование записи номер current} var i,b:integer; begin if (kol<1) or (current<1) or (current>kol) then Warning ('Неверный номер '+ 'текущей записи! Не могу редактировать') else begin seek (f,current-1); read (f,s); repeat writeln ('Запись номер ',current); writeln ('Выберите действие:'); writeln ('1. Фамилия (',s.name,')'); for i:=1 to 4 do writeln (i+1,'. Оценка ',i, ' (',s.balls[i],')'); writeln ('0. Завершить редактирование'); reset (input); {$I-}readln (b);{$I+} if (IoResult<>0) or (b<0) or (b>5) then Warning ('Неверный ввод! Повторите') else begin if b=1 then begin write ('Введите новую фамилию:'); {для простоты здесь нет} {проверок корректности} reset (input); readln (s.name); end else if b=0 then break else begin write ('Введите новую оценку:'); reset (input); readln (s.balls[b-1]); end; end; until false; seek (f,current-1); {Пишем, даже если запись не менялась -} write (f,s); {в реальных проектах так не делают} end; end; procedure menu; {Управление главным меню и вызов процедур} var n:integer; begin repeat writeln; writeln ('Выберите операцию:'); writeln ('1 - вперед'); writeln ('2 - назад'); writeln ('3 - поиск по фамилии'); writeln ('4 - добавить в конец'); writeln ('5 - удалить текущую'); writeln ('6 - сортировать по фамилии'); writeln ('7 - начало базы'); writeln ('8 - конец базы'); writeln ('9 - изменить текущую'); writeln ('0 - выход'); reset (input); {$I-}read (n);{$I+} if (IoResult<>0) or (n<0) or (n>9) then begin Warning ('Неверный ввод!'); continue; end else break; until false; case n of 1: go (1); 2: go (-1); 3: search; 4: add; 5: delete; 6: sort; 7: go (-(current-1)); 8: go (kol-current); 9: edit; 0: out; end; end; begin {Главная программа} open; getsize (kol,size); str(kol,st1); str(size,st2); writeln; writeln('=============================='); writeln('Учебная база данных "Студенты"'); writeln('=============================='); Warning ('Файл '+FileName+ ' открыт'+#13+#10+ 'Число записей='+st1+#13+#10+ 'Размер записи='+st2+#13+#10); {+#13+#10 - добавить к строке символы возврата каретки и первода строки} if kol=0 then current:=0 else current:=1; repeat menu; until false; end. 5. Программа содержит коды часто используемых клавиш и печатает их названия. uses crt; const ESC=#27; ENTER=#13; F1=#59; F10=#68; TAB=#9; SPACE=#32; UP=#72; DOWN=#80; LEFT=#75; RIGHT=#77; HOME=#71; END_=#79; PAGE_UP=#73; PAGE_DN=#81; var ch:char; begin clrscr; repeat ch:=Upcase(readkey); case ch of 'A'..'z': write ('Letter'); SPACE: write ('SPACE'); ENTER: write ('ENTER'); TAB: write ('TAB'); #0: begin ch:=readkey; case ch of F1: write ('F1'); F10: write ('F10'); LEFT: write ('LEFT'); RIGHT: write ('RIGHT'); UP: write ('UP'); DOWN: write ('DOWN'); HOME: write ('HOME'); END_: write ('END'); PAGE_UP: write ('PgUp'); PAGE_DN: write ('PgDn'); end; end; else begin end; end; until ch=Esc; end. 6.1. Программа позволяет двигать по текстовому экрану "прицел" с помощью клавиш со стрелками. uses crt; {$V-} {отключили строгий контроль типов} const ESC=#27; UP=#72; DOWN=#80; LEFT=#75; RIGHT=#77; var ch:char; procedure Draw (x,y:integer;mode:boolean); {mode определяет, нарисовать или стереть} var sprite:array [1..3] of string [3]; {"прицел", заданный массивом sprite} i:integer; begin sprite[1]:='/|\'; sprite[2]:='-=-'; sprite[3]:='\|/'; if mode=true then textcolor (White) else textcolor (Black); for i:=y to y+2 do begin gotoxy (x,i); write (sprite[i-y+1]); end; gotoxy (x+1,y+1); end; procedure status (n:integer; s:string); {рисует строку статуса внизу или вверху экрана} begin textcolor (Black); textbackground (White); gotoxy (1,n); write (' ':79); gotoxy (2,n); write (s); textcolor (White); textbackground (Black); end; var x,y:integer; begin textMode (cO80); status (1,'Пример управления движением!'); status(25,'Стрелки-управление;ESC-выход'); x:=10; y:=10; repeat Draw (x,y,true); ch:=Upcase(readkey); case ch of #0: begin ch:=readkey; Draw (x,y,false); case ch of LEFT: if x>1 then x:=x-1; RIGHT: if x<77 then x:=x+1; UP: if y>2 then y:=y-1; DOWN: if y<22 then y:=y+1; end; end; end; until ch=ESC; clrscr; end. 6.2. Эта версия программы 6.1 позволяет "прицелу" продолжать движение до тех пор, пока он не натолкнется на край экрана. uses crt; {$V-} const ESC=#27; UP=#72; DOWN=#80; LEFT=#75; RIGHT=#77; const goleft=1; GoRight=2; goup=3; godown=4; gostop=0; {возможные направления движения} const myDelay=1000; {задержка для Delay} var ch:char; LastDir:integer; {последнее направление движения} procedure Draw (x,y:integer;mode:boolean); var sprite:array [1..3] of string [3]; i:integer; begin sprite[1]:='/|\'; sprite[2]:='-=-'; sprite[3]:='\|/'; if mode then textcolor (White) else textcolor (Black); for i:=y to y+2 do begin gotoxy (x,i); write (sprite[i-y+1]); end; gotoxy (x+1,y+1); end; procedure status (n:integer; s:string); begin textcolor (Black); textbackground (White); gotoxy (1,n); write (' ':79); gotoxy (2,n); write (s); textcolor (White); textbackground (Black); end; var x,y:integer; begin clrscr; status(1,'Управление движением-2'); status(25,'Стрелки-управление;ESC-выход'); x:=10; y:=10; LastDir:=goleft; repeat {бесконечный цикл работы программы} repeat {цикл до нажатия клавиши} Draw (x,y,true); Delay (myDelay); Draw (x,y,false); case LastDir of goLeft: if x>1 then Dec(x) else begin x:=1; LastDir:=gostop; end; GoRight: if x<77 then inc(x) else begin x:=77; LastDir:=gostop; end; goUp: if y>2 then Dec(y) else begin y:=2; LastDir:=gostop; end; goDown: if y<22 then inc(y) else begin y:=22; LastDir:=gostop; end; end; until keyPressed; {обработка нажатия клавиши} ch:=Upcase(readkey); case ch of #0: begin ch:=readkey; case ch of LEFT: LastDir:=goLeft; RIGHT: LastDir:=GoRight; UP: LastDir:=goUp; DOWN: LastDir:=goDown; end; end; ESC: halt; end; until false; end. 7. Демо-программа для создания несложного двухуровневого меню пользователя. Переопределив пользовательскую часть программы, на ее основе можно создать собственный консольный интерфейс. uses crt; { Глобальные данные: } const maxmenu=2; {количество меню} maxpoints=3; {макс. количество пунктов} var x1,x2,y: array [1..maxmenu] of integer; {x1,x2- начало и конец каждого меню, y- строка начала каждого меню} kolpoints, points: array [1..maxmenu] of integer;{Кол-во пунктов и текущие пункты } text: array [1..maxmenu,1..maxpoints] of string[12]; { Названия пунктов } txtcolor, textback, cursorback:integer; { Цвета текста, фона, курсора} mainhelp:string[80]; { Строка помощи } procedure DrawMain (s:string); {Очищает экран, рисует строку главного меню s } begin Window (1,1,80,25); textcolor (txtcolor); textbackground (textback); clrscr; gotoxy (1,1); write (s); end; procedure DrawHelp (s:string); { Выводит подсказку s } var i:integer; begin textcolor (txtcolor); textbackground (textback); gotoxy (1,25); for i:=1 to 79 do write (' '); gotoxy (1,25); write (s); end; procedure doubleFrame (x1,y1,x2,y2:integer; Header: string); { Процедура рисует двойной рамкой окно } var i,j: integer; begin gotoxy (x1,y1); write ('╔'); for i:=x1+1 to x2-1 do write('═'); write ('╗'); for i:=y1+1 to y2-1 do begin gotoxy (x1,i); write('║'); for j:=x1+1 to x2-1 do write (' '); write('║'); end; gotoxy (x1,y2); write('╚'); for i:=x1+1 to x2-1 do write('═'); write('╝'); gotoxy (x1+(x2-x1+1-Length(Header)) div 2,y1); write (Header); {Выводим заголовок} gotoxy (x1+1,y1+1); end; procedure clearFrame (x1,y1,x2,y2:integer); var i,j:integer; begin textbackground (textback); for i:=y1 to y2 do begin gotoxy (x1,i); for j:=x1 to x2 do write (' '); end; end; procedure cursor (Menu,Point: integer; Action: boolean);{ Подсвечивает (если Action=true) или гасит п. Point меню Menu} begin textcolor (Txtcolor); if Action=true then textbackground (cursorBack) else textbackground (textBack); gotoxy (x1[Menu]+1,y[Menu]+Point); write (text[Menu][Point]); end; procedure DrawMenu (Menu:integer; Action: boolean);{Рисует меню с номером Menu, если Action=true, иначе стирает } var i:integer; begin if Action=true then textcolor (Txtcolor) else textcolor (textBack); textbackground (textBack); doubleFrame (x1[Menu], y[Menu], x2[Menu], y[Menu]+1+KolPoints[Menu],''); for i:=1 to KolPoints[Menu] do begin gotoxy (x1[Menu]+1, y[Menu]+i); writeln (text[Menu][i]); end; end; {Часть, определяемая пользователем} procedure Init; { Установка глобальных данных и начальная отрисовка } begin txtcolor:=yELLOW; textback:=BLUE; cursorback:=LIGHTcyAN; kolpoints[1]:=2; kolpoints[2]:=1; {пунктов в каждом меню} points[1]:=1; points[2]:=1; {выбран по умолчанию в каждом меню} x1[1]:=1; x2[1]:=9; y[1]:=2; text[1,1]:='Запуск'; text[1,2]:='Выход '; x1[2]:=9; x2[2]:=22; y[2]:=2; text[2,1]:='О программе'; DrawMain ('Файл Справка'); MainHelp:='ESC - Выход из программы '+ 'ENTER - выбор пункта меню '+ 'Стрелки - перемещение'; DrawHelp(MainHelp); end; procedure Work; { Рабочая процедура } var i,kol:integer; ch:char; begin DrawHelp('Идет расчет...'); { Строка статуса } textcolor (LIGHTGRAY); textbackground (BLACK); { Выбираем цвета для работы в окне } doubleFrame (2,2,78,24,' Расчет '); Window (3,3,77,23); {Секция действий, выполняемых программой} writeln; write ('Введите число шагов: '); {$I-}read (kol);{$I+} if IoResult<>0 then writeln ('Ошибка! Вы ввели не число') else if kol>0 then begin for i:=1 to kol do writeln ('Выполняется шаг ',i); writeln ('Все сделано!'); end else writeln ('Ошибка! Число больше 0'); {Восстановление окна и выход} Window (1,1,80,25); DrawHelp('Нажмите любую клавишу...'); ch:=readkey; clearFrame (2,2,78,24); { Стираем окно } end; procedure Out; { Очистка экрана и выход} begin textcolor (LIGHTGRAY); textbackground (BLACK); clrscr; halt(0); end; procedure Help; {Окно с информацией} var ch:char; begin textcolor (Txtcolor); textbackground (textback); doubleFrame (24,10,56,13,' О программе '); DrawHelp ('Нажмите клавишу...'); gotoxy (25,11); writeln(' Демонстрация простейшего меню'); gotoxy (25,12); write ( ' Новосибирск, НГАСУ'); ch:=readkey; clearFrame (24,10,58,13); end; procedure command (Menu,Point:integer); {Вызывает процедуры после выбора в меню } begin if Menu=1 then begin if Point=1 then Work else if Point=2 then Out; end else begin if Point=1 then Help; end; end; {Конец части пользователя } procedure MainMenu (Point, HorMenu:integer); { Поддерживает систему одноуровневых меню } var ch: char; funckey:boolean; begin Points[HorMenu]:=Point; DrawMenu (HorMenu,true); repeat cursor (HorMenu,Points[HorMenu],true); ch:=readkey; cursor (HorMenu,Points[HorMenu],false); if ch=#0 then begin funckey:=true; ch:=readkey; end else funckey:=false; if funckey=true then begin ch:=Upcase (ch); if ch=#75 then begin { Стрелка влево } DrawMenu (HorMenu,false); HorMenu:=HorMenu-1; if (HorMenu<1) then HorMenu:=maxMenu; DrawMenu (HorMenu,true); end else if ch=#77 then begin { Стрелка вправо } DrawMenu (HorMenu,false); HorMenu:=HorMenu+1; if (HorMenu>maxMenu) then HorMenu:=1; DrawMenu (HorMenu,true); end else if ch=#72 then begin { Стрелка вверх } Points[HorMenu]:=Points[HorMenu]-1; if Points[HorMenu]<1 then Points[HorMenu]:=Kolpoints[HorMenu]; end else if ch=#80 then begin { Стрелка вниз } Points[HorMenu]:=Points[HorMenu]+1; if (Points[HorMenu]>KolPoints[HorMenu]) then Points[HorMenu]:=1; end; end else if ch=#13 then begin { Клавиша ENTER } DrawMenu (HorMenu,false); command (HorMenu,Points[HorMenu]); DrawMenu (HorMenu,true); DrawHelp (MainHelp); end; until (ch=#27) and (funckey=false); { Пока не нажата клавиша ESC } end; { Основная программа } begin Init; MainMenu (1,1); Out; end. 8. Простейший "генератор" программы на Паскале. Из входного файла, содержащего текст, генерируется программа для листания этого текста. program str2Pas; uses crt; label 10,20; var ch:char;str:string; I,J,Len,count:word; InFile,OutFile:text; procedure Error (ErNum:char); begin case ErNum of #1: writeln ('Запускайте с 2 параметрами -',#13,#10, 'именами входного и выходного файла.', #13,#10, 'Во входном файле содержится текст', #13,#10, 'в обычном ASCII-формате,',#13,#10, 'в выходном будет программа на Паскале'); #2: writeln (' Не могу открыть входной файл!'); #3: writeln (' Не могу открыть выходной файл!'); else writeln (' Неизвестная ошибка!'); end; halt; end; begin if Paramcount<>2 then Error (#1); assign (InFile,Paramstr(1)); reset (InFile); if (IoResult<>0) then Error (#2); assign (OutFile,Paramstr(2)); rewrite (OutFile); if (IoResult<>0) then Error (#3); { Вписать заголовок программы } writeln (OutFile,'uses crt;'); write (OutFile,'const colstr='); { Узнать число строк текста } count:=0; while not Eof (InFile) do begin readLn (InFile,str); count:=count+1; end; reset (InFile); writeln (OutFile,count,';'); { Следующий сегмент программы: } writeln (OutFile,'var ch:char;'); writeln (OutFile,' List:boolean;'); writeln (OutFile, ' I,start,endstr:word;'); writeln (OutFile, ' ptext:array [1..colstr] of string;'); writeln (OutFile,'begin'); { Строки листаемого текста: } for I:=1 to count do begin Len:=0; repeat if (Eof (InFile)=true) then goto 10; read (InFile,ch); if ch=#39 then begin Len:=Len+1; str[Len]:=#39; Len:=Len+1; str[Len]:=#39; end else if ch=#13 then begin read (InFile,ch); if (ch=#10) then goto 10 else goto 20; end else begin 20: Len:=Len+1; str[Len]:=ch; end; until false; 10: write (OutFile,' ptext[',I,']:='''); for J:=1 to Len do write (OutFile,str[J]); writeln (OutFile,''';'); end; { Сегмент программы } writeln (OutFile,' textcolor (YELLOW);'); writeln (OutFile, ' textbackground (Blue);'); writeln (OutFile, ' List:=true; start:=1;'); { Последняя строка на экране: } if (count>25) then writeln (OutFile,' endstr:=25;') else writeln (OutFile,' endstr:=colstr;'); writeln (OutFile,' repeat'); writeln (OutFile, ' if (List=true) then begin'); writeln (OutFile,' clrscr;'); writeln (OutFile, ' for I:=start to endstr-1 do ', 'write (ptext[I],#13,#10);'); writeln (OutFile, ' write (ptext[endstr]);'); writeln (OutFile,' List:=false;'); writeln (OutFile,' end;'); writeln (OutFile,' ch:=readkey;'); writeln (OutFile, ' if ch= #0 then begin'); writeln (OutFile,' ch:=readkey;'); writeln (OutFile,' case ch of'); writeln (OutFile,' #72: begin'); writeln (OutFile, ' if start>1 then begin'); writeln (OutFile,' start:=start-1;'); writeln (OutFile, ' endstr:=endstr-1;'); writeln (OutFile,' List:=true;'); writeln (OutFile,' end;'); writeln (OutFile,' end;'); writeln (OutFile,' #80: begin'); writeln (OutFile, ' if endstr writeln (OutFile,' start:=start+1;'); writeln (OutFile, ' endstr:=endstr+1;'); writeln (OutFile,' List:=true;'); writeln (OutFile,' end;'); writeln (OutFile,' end;'); { Листание PgUp и PgDn } if (count>25) then begin writeln (OutFile,' #73: begin'); writeln (OutFile, ' if start>1 then begin'); writeln (OutFile, ' start:=1; endstr:=25;'); writeln (OutFile,' List:=true;'); writeln (OutFile,' end;'); writeln (OutFile,' end;'); writeln (OutFile,' #81: begin'); writeln (OutFile, ' if endstr writeln (OutFile, ' start:=colstr-24; endstr:=colstr;'); writeln (OutFile,' List:=true;'); writeln (OutFile,' end;'); writeln (OutFile,' end;'); end; { Заключительный сегмент } writeln (OutFile,' else begin end;'); writeln (OutFile,' end;'); writeln (OutFile,' end'); writeln (OutFile,' else begin'); writeln (OutFile,' case ch of'); writeln (OutFile,' #27: begin'); writeln (OutFile, ' textcolor (LightGray);'); writeln (OutFile, ' textbackground (Black);'); writeln (OutFile,' clrscr;'); writeln (OutFile,' halt;'); writeln (OutFile,' end;'); writeln (OutFile,' else begin'); writeln (OutFile,' end;'); writeln (OutFile,' end;'); writeln (OutFile,' end;'); writeln (OutFile,' until false;'); writeln (OutFile,'end.'); close (InFile); close (OutFile); writeln ('OK.'); end. 9. Шаблон программы для работы с матрицами и текстовыми файлами. program Files;{ Программа демонстрирует работу с текстовыми файлами и матрицами } const rows=10; cols=10; type matrix=array [1..rows,1..cols] of real; var f1,f2:text; a,b:matrix; Name1,Name2:string; n,m:integer; procedure Error (msg:string); begin writeln; writeln (msg); writeln ('Нажмите Enter для выхода'); reset (Input); readln; halt; end; procedure readDim (var f:text; var n,m:integer);{ Читает из файла f размерности матрицы: n - число строк, m - число столбцов. Если n<0 или n>rows (число строк) или m<0 или m>cols (число столбцов), прервет работу. } var s:string; begin {$I-}read (f,n);{$I+} if (IoResult<>0) or (n<0) or (n>rows) then begin str (rows,s); Error ('Неверное число строк '+ 'в файле данных!'+#13+#10+ 'должно быть от 1 до '+s); end; {$I-}read (f,m);{$I+} if (IoResult<>0) or (m<0) or (m>cols) then begin str (cols,s); Error ('Неверное число столбцов '+ 'в файле данных!'+#13+#10+ 'должно быть от 1 до '+s); end; end; procedure readMatrix (var f:text; n,m:integer; var a:matrix); { Читает из файла f матрицу a размерностью n*m } var i,j:integer; er:boolean; begin er:=false; for i:=1 to n do for j:=1 to m do begin {$I-}read (f,a[i,j]);{$I+} if IoResult<>0 then begin er:=true; a[i,j]:=0; end; end; if er=true then begin writeln; writeln ('В прочитанных данных есть ошибки!'); writeln ('Неверные элементы матрицы', ' заменены нулями'); end; end; procedure writeMatrix (var f:text; n,m:integer; var a:matrix); { Пишет в файл f матрицу a[n,m] } var i,j:integer; begin for i:=1 to n do begin for j:=1 to m do write (f,a[i,j]:11:4); writeln (f); end; end; procedure Proc1 (n,m:integer; var a,b:matrix); { Матрицу a[n,m] пишет в матрицу b[n,m], меняя знаки элементов } var i,j:integer; begin for i:=1 to n do for j:=1 to m do b[i,j]:=-a[i,j] end; begin if Paramcount<1 then begin writeln ('Имя файла для чтения:'); readLn (Name1); end else Name1:=Paramstr(1); if Paramcount<2 then begin writeln ('Имя файла для записи:'); readLn (Name2); end else Name2:=Paramstr(2); assign (f1,Name1); {$I-}reset (f1);{$I+} if IoResult<>0 then Error ('Не могу открыть '+Name1+ ' для чтения'); assign (f2,Name2); {$I-}rewrite (f2);{$I+} if IoResult<>0 then Error ('Не могу открыть '+Name2+ ' для записи'); readDim (f1,n,m); readMatrix (f1,n,m,a); Proc1 (n,m,a,b); writeMatrix (f2,n,m,b); close (f1); close (f2); end. 10. Подсчет количества дней от введенной даты до сегодняшнего дня. program Days; uses Dos; const mondays: array [1..12] of integer = (31,28,31, 30,31,30, 31,31,30, 31,30,31); var d,d1,d2,m1,m2,y1,y2:word; function Leapyear (year:word):boolean; begin if (year mod 4 =0) and (year mod 100 <>0) or (year mod 400 =0) then Leapyear:=true else Leapyear:=false; end; function correctDate (day,mon,year:integer):boolean; var maxday:integer; begin if (year<0) or (mon<1) or (mon>12) or (day<1) then correctDate:=false else begin maxday:=mondays[mon]; if (Leapyear (year)=true) and (mon=2) then maxday:=29; if (day>maxday) then correctDate:=false else correctDate:=true; end; end; function KolDays (d1,m1,d2,m2,y:word):word; var i,f,s:word; begin s:=0; if m1=m2 then KolDays:=d2-d1 else for i:=m1 to m2 do begin f:=mondays[i]; if (Leapyear (y)=true) and (i=2) then f:=f+1; if i=m1 then s:=s+(f-d1+1) else if i=m2 then s:=s+d2 else s:=s+f; KolDays:=s; end; end; function countDays (day1, mon1, year1, day2, mon2, year2:word):word; var f,i:word; begin f:=0; if year1=year2 then countDays:= KolDays (day1, mon1, day2, mon2, year1) else for i:=year1 to year2 do begin if i=year1 then f:= KolDays (day1, mon1, 31, 12, year1) else if i=year2 then f:=f+ KolDays (1,1,day2,mon2,year2)-1 else f:=f+KolDays (1,1,31,12,i); countDays:=f; end; end; begin getdate (y2,m2,d2,d); writeln ('Год Вашего рождения?'); readln (y1); writeln ('Месяц Вашего рождения?'); readln (m1); writeln ('День Вашего рождения?'); readln (d1); if correctDate (d1,m1,y1)=false then begin writeln ('Недопустимая дата!'); halt; end; if (y2 ( (m2 then begin writeln ('Введенная дата', ' позднее сегодняшней!'); halt; end; d:=countDays (d1,m1,y1,d2,m2,y2); writeln ('Количество дней= ',d); end. 11.1. Исходный текст модуля для поддержки мыши. unit Mouse; {Примеры использования – см. mousetst.pas в графике, mousetxt.pas в текстовом режиме 80*25} interface var MousePresent:boolean; function MouseInit(var nb:integer):boolean; { Инициализация мыши - вызывать первой. Вернет true, если мышь обнаружена } procedure Mouseshow; {Показать курсор мыши} procedure MouseHide; {Скрыть курсор мыши} procedure Mouseread(var x,y,bMask:integer); {Прочитать позицию мыши. Вернет через x,y координаты курсора (для текстового режима см. пример), через bmask - состояние кнопок (0-отпущены,1-нажата левая,2-нажата правая, 3-нажаты обе) } procedure MousesetPos(x,y:word); {Поставить курсор в указанную позицию} procedure Mouseminxmaxx(minx,maxx:integer); {Установить границы перемещения по x} procedure Mouseminymaxy(miny,maxy:integer); {Установить границы перемещения по y} procedure setVideoPage(Page:integer); {Установить нужную видеостраницу} procedure GetVideoPage(var Page:integer); {Получить номер видеостраницы} function MouseGetb(bMask:word; var count, Lastx, Lasty:word):word; procedure MousekeyPreset (var key,sost,x,y:integer); implementation uses Dos; var r: registers; Mi:pointer; function MouseInit(var nb:integer):boolean; begin if MousePresent then begin r.Ax:=0; Intr($33,r); if r.Ax=0 then begin nb:=0; MouseInit:=false end else begin nb:=r.Ax; MouseInit:=true end end else begin nb:=0; MouseInit:=false end end; procedure Mouseshow; begin r.Ax:=1; Intr($33,r) end; procedure MouseHide; begin r.Ax:=2; Intr($33,r) end; procedure Mouseread(var x,y,bMask:integer); begin r.Ax:=3; Intr($33,r); x:=r.cx; y:=r.dx; bMask:=r.Bx end; procedure MousesetPos(x,y:word); begin r.Ax:=4; r.cx:=x; r.dx:=y; Intr($33,r) end; function MouseGetb(bMask:word; var count,Lastx,Lasty:word):word; begin r.Ax:=5; r.Bx:=bMask;Intr($33,r); count:=r.Bx; Lastx:=r.cx; Lasty:=r.dx; MouseGetb:=r.Ax end; procedure Mouseminxmaxx(minx,maxx:integer); begin r.Ax:=7; r.cx:=minx; r.dx:=maxx; Intr($33,r) end; procedure Mouseminymaxy(miny,maxy:integer); begin r.Ax:=8; r.cx:=miny; r.dx:=maxy; Intr($33,r) end; procedure setVideoPage(Page:integer); begin r.Ax:=$1D; r.Bx:=Page; Intr($33,r) end; procedure GetVideoPage(var Page:integer); begin r.Ax:=$1E; Intr($33,r); Page:=r.Bx; end; procedure MousekeyPreset (var key,sost,x,y:integer); begin r.Ax:=$6; r.Bx:=key; Intr($33,r); key:=r.Ax; sost:=r.Bx; x:=r.cx; y:=r.dx; end; begin GetIntVec($33,Mi); if Mi=nil then MousePresent:=false else if byte(Mi^)=$cE then MousePresent:=false else MousePresent:=true end. 11.2. Тест модуля mouse.pas в графическом режиме (mousetst.pas). program MouseTst; uses graph,Mouse,crt; var grDriver : integer; grMode : integer; Errcode : integer; procedure init; begin grDriver:=VGA;grMode:=VGAHi; initgraph(grDriver, grMode, ''); Errcode:=graphresult; if Errcode <> grOk then begin writeln('Ошибка инициализации графики:', grapherrormsg(Errcode)); halt; end; end; var n,x,y,x0,y0,b:integer; s1,s2:string; begin init; mouseinit(n); mouseshow; setfillstyle (solidfill,BLACK); setcolor (WHITE); settextJustify(centertext, centertext); x0:=-1; y0:=-1; repeat mouseread (x,y,b); if (x<>x0) or (y<>y0) then begin str (x,s1); str (y,s2); bar (getmaxx div 2-50, getmaxy-15,getmaxx div 2+50,getmaxy-5); outtextxy (getmaxx div 2, getmaxy-10,s1+' '+s2); x0:=x; y0:=y; end; until keypressed; mousehide; closegraph; end. 11.3. Тест модуля mouse.pas в текстовом режиме (mousetxt.pas). program MouseTxt; uses crt,mouse; var n,x,y,b:integer; n1,k,lastx,lasty:word; begin textmode(3); mouseinit (n); mouseshow; repeat mouseread (x,y,b); gotoxy (1,25); write ('x=',(x div 8 + 1):2, ' y=',(y div 8 + 1):2,' b=',b:2); until keypressed; mousehide; end. 12.1. Учебная игра, использующая собственный файл ресурсов. Первый листинг содержит утилиту для создания файла ресурсов resfile из файлов *.bmp текущей директории, список которых находится в файле filelist.txt. Файлы *.bmp должны быть сохранены в режиме 16 цветов. При необходимости следует изменить в программе константу пути к Паскалю. uses graph,crt; const VGAPath='c:\TP7\egavga.bgi'; FileList='filelist.txt'; resfile='attack.res'; const width=32; height=20; const color: array [0..15] of byte= (0,4,2,6,1,5,3,7,8,12,10,14,9,13,11,15); const maxx=639; maxy=479; cx=MAxx div 2; cy=maxy div 2; type bmpinfo=record h1,h2:char; size,reserved,offset,b,width, height: longint; plans,bpp:word; end; var Driver, Mode: integer; DriverF: file; List,res:text; DriverP: pointer; s:string; procedure Wait; var ch:char; begin reset (Input); repeat until keyPressed; ch:=readkey; if ch=#0 then readkey; end; procedure closeMe; begin if DriverP <> nil then begin FreeMem(DriverP, Filesize(DriverF)); close (DriverF); end; closegraph; end; procedure graphError; begin closeMe; writeln('graphics error:', grapherrormsg(graphresult)); writeln('Press any key to halt '); Wait; halt (graphresult); end; procedure InitMe; begin assign(DriverF, VGAPath); reset(DriverF, 1); getmem(DriverP, Filesize(DriverF)); Blockread(DriverF, DriverP^, Filesize(DriverF)); if registerBGIdriver(DriverP)<0 then graphError; Driver:=VGA; Mode:=VGAHi; initgraph(Driver, Mode,''); if graphresult < 0 then graphError; end; procedure clearscreen; begin setfillstyle (solidfill, White); bar (0,0,maxx,maxy); end; procedure Window (x1,y1,x2,y2,color,Fillcolor:integer); begin setcolor (color); setfillstyle (1,Fillcolor); bar (x1,y1,x2,y2); rectangle (x1+2,y1+2,x2-2,y2-2); rectangle (x1+4,y1+4,x2-4,y2-4); setfillstyle (1,DArKGrAy); bar (x1+8,y2+1,x2+8,y2+8); bar (x2+1,y1+8,x2+8,y2); end; procedure Error (code:integer; str:string); begin Window (cx-140,cy-100,cx+140, cy-70,Black,YELLOW); case code of 1: s:='Файл '+str+' не найден!'; 2: s:='Файл '+str+' не формата BMP-16'; 3: s:='Файл '+str+' испорчен!'; end; settextjustify (Lefttext, toptext); settextstyle(DefaultFont, HorizDir, 1); outtextxy (cx-136,cy-92,s); Wait; halt(code); end; function Draw (x0,y0:integer; fname:string; transparent:boolean):integer; var f:file of bmpinfo; bmpf:file of byte; res:integer; info:bmpinfo; x,y:integer; b,bh,bl:byte; nb,np:integer; tpcolor:byte; i,j:integer; begin assign(f,fname); {$I-} reset (f); {$I+} res:=IoResult; if res <> 0 then Error (1,fname); read (f,info); close (f); if info.bpp<>4 then Error(2,fname); x:=x0; y:=y0+info.height; nb:=(info.width div 8)*4; if (info.width mod 8) <> 0 then nb:=nb+4; assign (bmpf,fname); reset (bmpf); seek (bmpf,info.offset); if transparent then begin read (bmpf,b); tpcolor:=b shr 4; seek (bmpf,info.offset); end else tpcolor:=17; for i:=1 to info.height do begin np:=0; for j:=1 to nb do begin read (bmpf,b); if np |