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('-----------------------------------------------------------');