Основные приемы работы в среде ТР

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:=(B-A)/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('4islo 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 lab4;

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 ('4islo 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 ('4islo 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,'4asche 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); {t.k. 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.Описание: Зеленый перевернутый лист папоротника, заполняющийся точками.

program Fract;

uses Graph,Crt;

var Dt,M : integer; R,A,B,C,D,E,F, NewY,NewX,X,Y : real;

begin Dt := Detect;

InitGraph(Dt, M,'');

Randomize;

X := 0; Y := 0;

repeat R := Random;

if R>0.93 then begin A := -0.15; B := 0.28; C := 0.26; D := 0.24; E := 0; F := 0.44;

end else if R>0.86 then begin A := 0.2; B := -0.26; C := 0.23; D := 0.23; E := 0; F := 1.6;

end else if R>0.01 then begin A := 0.85; B := 0.02; C := -0.02; D := 0.85; E := 0; F := 1.6;

end else begin A := 0; B := 0; C := 0; D := 0.16; E := 0; F := 0; end;

NewX := A*X + B*Y + E; NewY := C*X + D*Y + F; X := NewX; Y := NewY;

PutPixel(Round(X*50)+100,Round(Y*50)+50, Green);

until(Keypressed);

CloseGraph;

end.

2.Описание: Стрелочные часы с быстроидущей секундной стрелкой и показом реального времени.

Program 4as;

uses graph, crt, dos;

type TPoint = record

x, y: Real; end;

var H, M, S, Hund : Word; Xc, Yc, i : Integer; P, P2, P3, P4, P5, P6 : TPoint;

procedure Dec2Polar(Ang, Len: Real; var P: TPoint);

begin Ang := Ang - 90; { Correlation for our coord system }

P.x := Xc + Len * cos(Ang * Pi / 180);

P.y := Yc + Len * sin(Ang * Pi / 180);end;

begin i := 0;

InitGraph(i, i, '');

Xc := GetMaxX div 2; Yc := GetMaxY div 2; SetColor(10);

Circle(Xc, Yc, Yc - 30); SetColor(2); Circle(Xc, Yc, 3); SetColor(14);

for i := 0 to 23 do begin Dec2Polar(i * 15, Yc - 40, P);

Circle(Round(P.x), Round(P.y), 2 + 3*Byte(i mod 2 = 0)); end;{ SetLineStyle(0, 0, 3);}

while not keypressed do begin { Erase } SetColor(0); Line(Round(P2.x), Round(P2.y), Round(P.x), Round(P.y));

Line(Round(P4.x), Round(P4.y), Round(P3.x), Round(P3.y));

Line(Round(P6.x), Round(P6.y), Round(P5.x), Round(P5.y));

GetTime(H, M, S, Hund); { Second arrow }

Dec2Polar((S + Hund/100) * 6, Yc - 50, P);

Dec2Polar((S + Hund/100) * 6, 5, P2); { Minute arrow }

Dec2Polar((M + S/60) * 6, Yc - 100, P3);

Dec2Polar((M + S/60) * 6, 5, P4); Dec2Polar((H + M/60) * 30, Yc - 150, P5);

Dec2Polar((H + M/60) * 30, 5, P6); { Redraw } SetColor(15);

Line(Round(P2.x), Round(P2.y), Round(P.x), Round(P.y)); SetColor(9);

Line(Round(P4.x), Round(P4.y), Round(P3.x), Round(P3.y)); SetColor(7);

Line(Round(P6.x), Round(P6.y), Round(P5.x), Round(P5.y)); delay(1000); end; CloseGraph;

end.

3.Описание: Скачущий мяч с постепенным снижением амплитуды.

program ufo;

uses crt,graph; const r=20;h=5; var gd,gm,i,n,t,x,y,p:integer;

begin clrscr;

gd:=Detect;

initgraph(gd,gm,'c:\bp\bgi '); setcolor(4); setlinestyle(0,1,1);

line(0,479,639,479);

x:=r;y:=r; t:=479-2*r; n:=t div h; p:=h;

while n<>0 do begin for i:=1 to n do begin setcolor(2); circle(x,y,r); setfillstyle(1,2);

floodfill(x,y,2); delay(10);

setcolor(0); circle(x,y,r);

setfillstyle(1,0); floodfill(x,y,0);

y:=y+p; x:=x+1; end;

if p>0 then begin t:=round(3*t/4);n:=t div h end;

p:=-p end; setcolor(12); circle(x,y,r);

setfillstyle(1,2);

floodfill(x,y,12);

repeat until keypressed;closegraph

end.

4.Описание: Нло в замкнутом пространстве на фоне звездного неба.

program ufo;

uses graph,crt;

const r=20; pause=50; var d,m,e,xm,ym,x,y,lx,ly,rx,ry, size,i,dx,dy,width,height:integer; saucer:pointer;

label loop;

begin d:=detect;

initgraph(d,m,'');

e:=graphresult;

if e<> grok then writeln(grapherrormsg(e)) else begin x:=r*5; y:=r*2;

xm:=getmaxx div 4; ym:=getmaxy div 4;

ellipse(x,y,0,360,r,r div 3+2); ellipse(x,y-4,190,357,r,r div 3);

line(x+7,y-6,x+10,y-12); line(x-7,y-6,x-10,y-12);

circle(x+10,y-12,2); circle(x-10,y-12,2);

floodfill(x+1,y+4,white);

lx:=x-r-1; ly:=y-14;

rx:=x+r+1; ry:=y+r div 3+3;

width:=rx-lx+1; height:=ry-ly+1;

size:=imagesize(lx,ly,rx,ry);

getmem(saucer,size); getimage(lx,ly,rx,ry,saucer^);

putimage(lx,ly,saucer^,xorput);

rectangle(xm,ym,3*xm,3*ym);

setviewport(xm+1,ym+1,3*xm-1,3*ym-1,clipon); xm:=2*xm; ym:=2*ym;

for i:=1 to 200 do

putpixel(random(xm),random(ym),white);

x:=xm div 2;

y:=ym div 2;

dx:=10; dy:=10; repeat putimage(x,y,saucer^,xorput); delay(999);

putimage(x,y,saucer^,xorput);

loop: x:=x+dx; y:=y+dy;

if (x<0) or (x+width+1>xm) or (y<0) or (y+height+1>ym) then begin x:=x-dx; y:=y-dy;

dx:=getmaxx div 10-random(getmaxx div 5); dy:=getmaxy div 30-random(getmaxy div 15); goto loop end until keypressed;

if readkey=#0 then x:=ord(readkey);

closegraph end

end.

5.Описание: Заполнение квадрата случайными линиями разных цветов.

program graphik;

uses graph,crt;

var d,r,e:integer; x1,y1,x2,y2:integer;

begin clrscr;

d:=detect;

initgraph(d,r,'');

e:=graphresult;

if e <> grok then writeln(grapherrormsg(e)) else begin x1:=getmaxx div 3;

y1:=getmaxy div 3;

x2:=4*x1;y2:=4*y1;

rectangle(x1,y1,x2,y2);

setviewport(x1+1,y1+1,x2-1,y2-1,clipon);

repeat setcolor(succ(random(16)));

line(random(x2-x1),random(y2-y1),random(x2-x1),random(y2-y1))

until keypressed;

if readkey=#0 then d:=ord(readkey);

closegraph

end end.

6.Описание: Медленно выезжающий кусок пирога или пиццы.

program pie;

uses crt,graph;

var graphdriver,graphmode,errorcode:integer; j,v,l,m,k,i:integer;

begin graphdriver:=detect;

initgraph(graphdriver,graphmode,'');

errorcode:=graphresult;

if errorcode<>grOk then begin writeln('ЋиЁЎЄ Ја дЁЄЁ: ',graphErrorMsg(errorcode));

writeln('Џа®Ја ¬¬ ў аЁ©-® § ўҐаиЁ« а Ў®вг...');

halt(1); end;

setcolor(yellow);

circle(200,200,50);

floodfill(199,199,yellow);

delay(30000);

setcolor(black);

pieslice(200,200,30,60,50);

for i:=1 to 20 do begin setcolor(yellow);

pieslice(200+i,200-i,30,60,50);

setcolor(black);

pieslice(200+i,200-i,30,60,50);

delay(30000);

i:=i+1; end;

readkey;

closegraph;

end.

7.Описание: Статичное изображение двухколесного велосипеда.

program gr;

uses graph;

var grDriver:integer;

grMobe:integer;

Begin grDriver:=Detect;

InitGraph(grDriver,grMobe,'');

SetColor(12);

circle(200,150,30);circle(200,150,23);circle(330,150,30);circle(330,150,23);line(200,150,280,150);line(280,150,320,110);line(320,110,210,110);line(210,110,250,150);line(200,150,210,110);circle(200,150,5);circle(270,150,10);line(270,150,270,170);line(265,170,275,170);line(200,145,270,140);line(200,155,270,160);line(330,150,320,110);line(320,110,320,98);line(320,98,310,98);line(210,110,210,100);circle(210,100,5);line(210,100,220,100);line(270,150,270,130);line(265,130,275,130);readln;

End.

8.Описание: Приближающийся на смотрящего квадрат. Увеличение размеров по времени.

program gr;

uses graph,crt;

VAR x,y,i:integer;

PROCEDURE grafika_on;

Var drv,mode:integer;

BEGIN drv:=9; {VGA }mode:=2; {VGAHi}

initgraph(drv,mode,'');END;

BEGIN grafika_on;

x:=300; y:=200;

for i:=1 to 100 do begin setcolor(9);

rectangle(x-i,y-i,x+i,y+i);

delay(100); setcolor(0); rectangle(x-i,y-i,x+i,y+i);

end; readkey; closegraph;

END.

9. Описание:Строительство башни по блокам.

program gr;

Uses crt, Graph;Var P:pointer;Size:Word; X1,Y1:Word; gd,gm: integer;

Begin gd:=detect;

InitGraph(gd,gm,'');

IF GraphResult<>0 THEN Halt(1);

SetViewPort(0,0,640,80,TRUE);

ClearViewPort;

SetBkColor(black);SetColor(yellow);

SetLineStyle(0,1,Thickwidth);Rectangle(120,400,200,440);

Size:=ImageSize(120,400,200,440);

GetMem(p,Size);

GetImage(120,400,200,440,P^);

Y1:=440;

WHILE Y1>=40 DO begin X1:= 120;

begin PutImage(X1,Y1,p^,CopyPut); Delay(59000);

X1:=X1+80 end;

Y1:=Y1-40 end; x1:=x1-160;WHILE X1<=280 DO Begin PutImage(X1,Y1,p^,CopyPut);

X1:=X1 +160 end;

setfillstyle(8,red);

Bar(200,40,280,500); Bar(40,40,120,500);

SetColor(11);SETTEXTSTYLE(6,7,6);

outtextxy(350,100,'BASHNYA!');Readln;

CloseGraph End.

10. Описание:Пульсирующее сердце (анимация).

program gr;

uses crt,graph;var driver,mode,error:integer; l,n,m,x,y,r:integer;

begin driver:=detect;

initgraph(driver,mode,'');

error:=graphresult;

if error<>grOk then begin writeln('ЋиЁЎЄ Ја дЁЄЁ: ',graphErrorMsg(error));

writeln('Џа®Ја ¬¬ ў аЁ©-® § ўҐаиЁ« а Ў®вг...'); halt(1); end;

m:=1;l:=1;x:=1;y:=1;r:=1;n:=1;

repeat x:=1;y:=1;r:=1;l:=1;

repeat begin setcolor(cyan);

arc(170-x,150,0,180,20+r); arc(210+x,150,0,180,20+r);

line(150-2*x,150,190,200+y); line(230+2*x,150,190,200+y);

floodfill(149,150,cyan);

x:=x+1;y:=y+1;r:=r+1;

delay(20); clearviewport;

l:=l+1; end; until l=20;

x:=1;y:=1;r:=1;m:=1;

repeat setcolor(cyan);

arc(150+x,150,0,180,40-r); arc(230-x,150,0,180,40-r);

line(110+2*x,150,190,220-y); line(270-2*x,150,190,220-y);

floodfill(149,150,cyan);

x:=x+1;y:=y+1;r:=r+1;m:=m+1; delay(20);

clearviewport; until m=20; n:=n+1; until n=20; closegraph;

end.

11. Описание: Динамическое изображение планеты сатурн с помощью эллипсов.

program graphik;

uses graph,crt;

var a,b,e:integer;

begin a:=detect;

initgraph(a,b,'');

e:=graphresult;

if e<>grok then writeln(grapherrormsg(e))

else begin repeat setlinestyle(2,5,2*2+5);

setcolor(random(3));

ellipse(300,250,128,52,random(300),random(100));

setcolor(random(8));

ellipse(300,250,0,360,random(200),200);

until keypressed;

closegraph;end

end.

12.Описание: Медленно поднимающийся вверх воздушный шар.

Program one;

uses crt,graph;

var gd,gm,y,size:integer; p:pointer;

begin initgraph(gd,gm,'');size:=imagesize(50,200,150,400);getmem(p,size);setcolor(14);

setfillstyle(1,14);arc(100,250,0,180,50);line(50,250,150,250);

floodfill(120,240,14);setcolor(1);line(50,250,75,350);

line(150,250,125,350);setcolor(4);setfillstyle(1,4);

bar(75,350,125,400);

getimage(50,200,150,400,p^);setfillstyle(1,0);

for y:=480 downto 0 do begin putimage(50,y,p^,1);delay(1000);cleardevice;

bar(50,y,150,y+100);

end; readln; closegraph;

end.

13.Описание: Снеговики стоят в несколько рядов один за другим.

program snegovik;

uses graph;

var i,j,x,y:integer;grdriver:integer;grmode:integer;begin grdriver:=detect;initgraph(grdriver,grmode,'c');

x:=50;y:=30;

for i:=1 to 10 do begin for j:=1 to 10 do begin setcolor(blue);

circle(x,y,10);circle(x,y+30,20);

circle(x,y+80,30);circle(x-30,y+30,10);

circle(x+30,y+30,10);setcolor(5);

line(x,y-5,x+15,y);line(x,y+5,x+15,y);setcolor(white);

line(x-5,y+5,x+5,y+5);

putpixel(x-5,y-5,white);putpixel(x+5,y-5,white);

putpixel(x,y+20,white);putpixel(x,y+30,white);

putpixel(x,y+40,white);putpixel(x,y+60,white);

putpixel(x,y+70,white);putpixel(x,y+80,white);

putpixel(x,y+90,white);putpixel(x,y+100,white);setcolor(3);

line(x-5,y-10,x+5,y-10);line(x+5,y-10,x,y-20);line(x,y-20,x-5,y-10);

x:=x+90;end;

y:=y+160;x:=50;

end;readln

end.

14.Описание: Снежика, рисуемая в зависимости от длины и количества лучей и глубины рекурсии.

Program Snezhinka;

Uses crt, graph;

const k = 150; n = 8; g = 4;

var gd, gm: integer; procedure Snezhinka_v_zh (x, y: word; r, c: byte); var alpha: real; i: byte; xd, yd: integer;

begin if c < 1 then exit;

for i := 1 to n do

begin alpha := 2 * Pi * i / n;

xd := round(x + r * cos(alpha));

yd := round(y + r * sin(alpha));

moveto(x, y); lineto(xd, yd);

Snezhinka_v_zh(xd, yd, r div 3, c - 1); end; end;

BEGIN initgraph(gd, gm, 'h:\tp\bgi'); setcolor(11);

snezhinka_v_zh(320, 240, k, g); readkey;

closegraph;

END.

15.Описание: Нарисовать радугу, используя элипсные дуги разных цветов.

Program Raduga;

Uses Graph;

var D,M,y,i : Integer;

begin D := Detect;

InitGraph(D,M,'');

if GraphResult <> grOk then WriteLn(GraphErrorMsg(GraphResult)) else begin y:=200;

for i:=1 to 30 do begin if i<5 then SetColor(4); if (i>5)and(i<10) then SetColor(14); if (i>10)and(i<15) then SetColor(2); if (i>20)and(i<25) then SetColor(1); if i>25 then SetColor(13);

Ellipse(325,y,10,170,240,150); inc(y); end;

Readln; CloseGraph; end;

end.

Страницы: 1, 2, 3