Хостинг портала RFpro.ru:
Московский хостер
Профессиональный платный хостинг на базе Windows 2008

РАССЫЛКИ ПОРТАЛА RFPRO.RU

Чемпионы рейтинга экспертов в этой рассылке

_Ayl_ Статус: Студент Рейтинг: 853 ∙ повысить рейтинг >>

Пупорев Юрий Борисович Статус: Специалист Рейтинг: 683 ∙ повысить рейтинг >>

Сарумян Статус: Практикант Рейтинг: 526 ∙ повысить рейтинг >>

∙ / КОМПЬЮТЕРЫ И ПО / Языки программирования / Pascal

Нам очень важно Ваше мнение об этом выпуске рассылки. Вы можете оценить этот выпуск по пятибалльной шкале, пройдя по ссылке:
оценить выпуск >>

Вопрос № 170508: Здраствуйте уважаемые эксперты, пожалуйста помогите!!! Задание:Используя технологию процедурного программирования, разработать программу обработки типизированных файлов с числом записей не менее 5. Программа должна обеспечить возможность сортировк...

Здраствуйте уважаемые эксперты, пожалуйста помогите!!!
Задание:Используя технологию процедурного программирования, разработать программу обработки типизированных файлов с числом записей не менее 5. Программа должна обеспечить возможность сортировки файла и поиска в файле. Типизированные файлы создавать и хранить только в личных папках групповых каталогов на сетевом диске X.

Само задание:Музеи
наименование/ назначение/ адрес/ время работы/ стоимость билета/

примечание: Сформулировать условие сортировки записей файла и организовать сортировку по одному из полей. Вспомогательные файлы и массивы не использовать!

Сформулировать условие поиска данных в файле и организовать поиск по условию с сохранением найденных записей в новом файле.

Описать и использовать подпрограммы: проверки существования, создания, просмотра, сортировки файла, выборки данных из файла (входным параметром любой из подпрограмм обязательно является имя (имена) физического файла.

Предусмотреть в программе возможность выбора варианта выполнения программы с помощью меню в окне диалога с пользователем.

При демонстрации выполнения программы обеспечить одновременный показ в окнах на экране исходного и результирующего файла.

Отправлен: 17.07.2009, 13:19
Вопрос задал: Mihenze, Посетитель
Всего ответов: 2
Страница вопроса >>

Приложение:
uses crt,dos; const n=5; fn=\'f:\bp7\pas\museums.rec\';{Zdes` nado propisat` svoy put`: x:\...} fnOut=\'f:\bp7\pas\museums.out\';{Zdes` nado propisat` svoy put`: x:\...} type museum=record Name:string[20]; Purpose:string[10]; Addr: string[30]; start,stop:byte; cost: word; end; var Mus: array[1..n] of museum; function upper(s: string): string; var i: byte; begin for i:=1 to length(s) do s[i]:=upCase(s[i]); upper:=s end; procedure VyborPrice(p:word); var f: file of museum; i: byte; flag: boolean; begin assign(f,fnOut); rewrite(f); flag:=false; window(41,1,80,25); writeln(\'Za \',p,\' rublei vam dostupny:\'); for i:=1 to n do if mus[i].cost<=p then begin flag:=true; writeln(mus[i].name); write(f,mus[i]); end; if not flag then writeln(\'Da ni4ego ne dostupno\'); close(f); end; procedure VyborTime(t:word); var f: file of museum; i: byte; flag: boolean; begin assign(f,fnOut); rewrite(f); flag:=false; window(41,1,80,25); writeln(\'V \',t,\' 4asov rabotaiut muzei:\'); for i:=1 to n do if (mus[i].start<=t) and (mus[i].stop>=t) then begin flag:=true; writeln(mus[i].name); write(f,mus[i]); end; if not flag then writeln(\'Da nikto uzhe ne rabotaet\'); close(f); end; procedure Vybor(Item: byte;s: string); var f: file of museum; i: byte; flag: boolean; begin assign(f,fnOut); rewrite(f); flag:=false; window(41,1,80,25); if Item=1 then writeln(\'Nazvaniya muzeev, pohozhie na \',s) else writeln(\'Muzei, s pohozhim nazna4eniem \',s); for i:=1 to n do begin if Item=1 then if pos(upper(s),upper(mus[i].name))>0 then begin flag:=true; writeln(mus[i].name); write(f,mus[i]); end; if Item=2 then if pos(upper(s),upper(mus[i].purpose))>0 then begin flag:=true; writeln(mus[i].name); writeln(mus[i].purpose); write(f,mus[i]); end; end; if (Item=1) and not flag then writeln(\'Ne znaiu takogo muzeya\'); if (Item=2) and not flag then writeln(\'Ne znaiu takogo nazna4eniya\'); close(f); end; function getKey: word; var c: byte; begin c:=ord(readKey); if c=0 then getKey:=300+ord(readKey) else getKey:=c end; procedure sort(item:byte); {Sortirovka vstavkami} var i,j,min: word; tmp: museum; begin for i:=1 to n-1 do begin min:=i; for j:=i+1 to n do begin if item=1 then if mus[j].name<mus[min].name then min:=j; if item=2 then if mus[j].cost<mus[min].cost then min:=j; end; tmp:=mus[min]; mus[min]:=mus[i]; mus[i]:=tmp; end; end; Procedure Cursor(n: byte); var Regs: Registers; begin Regs.Ah:=1; if n=0 then Regs.Cx:=$2020 else Regs.Cx:=$0607; Intr($10,Regs) end; function fileExists(fn: string): boolean; var f: file of museum; begin {$i-} assign(f,fn); reset(f); if ioResult<>0 then fileExists:=false else fileExists:=true; {$i+} close(f); end; procedure readData(fn:string); var i: byte; f: file of museum; begin if not fileExists(fn) then begin writeln(\'Ne udalos` otkryt` \',fn); readKey; exit; end; assign(f,fn); reset(f); for i:=1 to n do read(f,mus[i]); close(f); end; procedure vyvodUnsorted; var i:byte; begin window(1,1,40,25); textcolor(white); textbackground(black); clrscr; writeln(\'Nesortirovanny:\');writeln; for i:=1 to n do begin writeln(mus[i].name,\' - Nazna4enie: \',mus[i].purpose); writeln(\'Adres: \',mus[i].addr); writeln(\'4asy raboty: \',mus[i].start,\' - \',mus[i].stop); writeln(\'Cena bileta: \',mus[i].cost); end end; procedure vyvodSorted; var i:byte; begin window(41,1,80,25); textcolor(white); textbackground(black); clrscr; writeln(\'Sortirovanny:\');writeln; for i:=1 to n do begin writeln(mus[i].name,\' - Nazna4enie: \',mus[i].purpose); writeln(\'Adres: \',mus[i].addr); writeln(\'4asy raboty: \',mus[i].start,\' - \',mus[i].stop); writeln(\'Cena bileta: \',mus[i].cost); end end; procedure menu; const menuLen1=4; menuLen2=2; menu1:array[0..menuLen1] of string= (\' Find:\',\' Name\',\' Purpose\',\' Time\',\' Cost\'); menu2:array[0..menuLen2] of string= (\' Sort by:\',\' Name\',\' Cost\'); Help=\'Left, Right, Up, Down - to navigate. Enter - to select. Esc - to exit.\'; var act1,act2,i,time:byte; act:boolean; key,price:word; s:string; begin window(1,1,80,25); textcolor(white); textbackground(black); clrscr; gotoxy(3,25); write(Help); act1:=1; act2:=1; act:=true; Cursor(0); repeat window(25,1,39,menuLen1+1);{Risuem menu} textbackground(blue); clrscr; textcolor(green); writeln(menu1[0]); for i:=1 to menuLen1 do begin if act and (act1=i) then begin textcolor(blue); textbackground(yellow) end else begin textcolor(white); textbackground(blue) end; if i=menuLen1 then write(menu1[i]) else writeln(menu1[i]); end; window(41,1,55,menuLen2+1); textbackground(blue); clrscr; textcolor(green); writeln(menu2[0]); for i:=1 to menuLen2 do begin if not act and (act2=i) then begin textcolor(blue); textbackground(yellow) end else begin textcolor(white); textbackground(blue) end; if i=menuLen2 then write(menu2[i]) else writeln(menu2[i]); end; {Narisovali} key:=getKey; case key of 375,377: {Left, Right} act:=not act; {Smena menu} 372: {Up} if act then if act1=1 then act1:=menuLen1 else dec(act1) else if act2=1 then act2:=menuLen2 else dec(act2); 380: {Down} if act then if act1=menuLen1 then act1:=1 else inc(act1) else if act2=menuLen2 then act2:=1 else inc(act2); 13: {Enter} if act then begin readData(fn); window(1,1,80,25); textcolor(white); textbackground(black); clrscr; case act1 of 1:Begin; cursor(1); writeln(\'Vvedite naimenovanie:\'); readln(s); cursor(0); Vybor(act1,s); vyvodUnsorted; window(1,1,80,25); textcolor(white+blink); gotoxy(5,25); write(\'Nazhmite liubuiu klavishu dlia prodolzheniya\'); getKey; clrscr; end; 2:begin cursor(1); writeln(\'Vvedite nazna4enie:\'); readln(s); cursor(0); Vybor(act1,s); vyvodUnsorted; window(1,1,80,25); textcolor(white+blink); gotoxy(5,25); write(\'Nazhmite liubuiu klavishu dlia prodolzheniya\'); getKey; clrscr; end; 3:begin cursor(1); writeln(\'Vvedite vremia:\'); readln(Time); cursor(0); VyborTime(Time); vyvodUnsorted; window(1,1,80,25); textcolor(white+blink); gotoxy(5,25); write(\'Nazhmite liubuiu klavishu dlia prodolzheniya\'); getKey; clrscr; end; 4:begin cursor(1); writeln(\'Vvedite cenu:\'); cursor(0); readln(Price); VyborPrice(Price); vyvodUnsorted; window(1,1,80,25); textcolor(white+blink); gotoxy(5,25); write(\'Nazhmite liubuiu klavishu dlia prodolzheniya\'); getKey; clrscr; end end end else begin readData(fn); vyvodUnsorted; sort(act2); vyvodSorted; window(1,1,80,25); textcolor(white+blink); gotoxy(5,25); write(\'Nazhmite liubuiu klavishu dlia prodolzheniya\'); getKey; clrscr; end end; until key=27; Cursor(1); end; begin menu end.

Ответ отправил: Максим Юрьевич, 2-й класс
Ответ отправлен: 17.07.2009, 21:02

Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 252278 на номер 1151 (Россия) | Еще номера >>

Отправить WebMoney: Неплохо (25 руб.) Хорошо (35 руб.) Отлично (50 руб.) БЛЕСТЯЩЕ! (75 руб.)

Вам помогли? Пожалуйста, поблагодарите эксперта за это!

Отвечает leonid59, 5-й класс :
Здравствуйте, Mihenze. Код в приложении.
Недоработки:
1. На сети не проверялось.
2. В окна нет выгрузки.
3. Тупой интерфейс
4. Структура не музеи, а 2 поля (id, name).
5. .......

Приложение:
program p01a; uses crt; type TRec = record id: integer; name: string[10]; end; type TFileName = string[30]; TFunc = function(rec1,rec2: TRec):boolean; TFilterFunc = function(rec, etalon: TRec): boolean; TTable = file of TRec; var i : integer; iChoice : integer; IsFiltered : boolean; f, f2 : TTable; flt : TFilterFunc; fname, fname2 : TFileName; lt : TFunc; rec, etalon : TRec; sortfield : integer; symbol : char; procedure append(var f: TTable; rec: TRec); forward; procedure create(fname: TFileName); forward; procedure display(var f: TTable); forward; function exists(fname: TFileName): boolean; forward; procedure first(var f: TTable); forward; {$F+} function flt1(rec, etalon: TRec): boolean; forward; {$F-} {$F+} function flt2(rec, etalon: TRec): boolean; forward; {$F-} procedure GetNewRec(var rec: TRec); forward; procedure init(fName: TFileName); forward; procedure last(var f: TTable); forward; {$F+} function less1(rec1,rec2: TRec): boolean; forward; {$F-} {$F+} function less2(rec1,rec2: TRec): boolean; forward; {$F-} procedure menu; forward; procedure next(var f: TTable); forward; procedure open(fName: TFileName; var f: TTable); forward; procedure SetFilter(var f: TTable); forward; procedure Show(fName: TFileName); forward; procedure sort(fName: TFileName; SortExpr: TFunc); forward; procedure UnLoad(ffrom, fto: TFileName; FilterExpr: TFilterFunc); forward; procedure append(var f: TTable; rec: TRec); begin last(f); write(f, rec); end; { append } procedure create(fname: TFileName); var f: TTable; begin assign(f, fname); rewrite(f); close(f); end; { create } procedure display(var f: TTable); var rec: TRec; begin read(f, rec); clrscr; writeln(\'id = \',rec.id); writeln(\'name = \',rec.name); readln; end; { display } function exists(fname: TFileName): boolean; var f: TTable; begin {$I-} assign(f, fname); reset(f); {$I+} if IOResult <> 0 then exists := false else begin close(f); exists := true; end; end; { exists } procedure first(var f: TTable); begin seek(f,0); end; { first } {$F+} function flt1(rec, etalon: TRec): boolean; begin flt1 := rec.id < etalon.id; end; { flt1 } {$F-} {$F+} function flt2(rec, etalon: TRec): boolean; begin flt2 := rec.name = etalon.name; end; { flt1 } {$F-} procedure GetNewRec(var rec: TRec); begin clrscr; write(\'id = \'); readln(rec.id); write(\'name = \'); readln(rec.name); end; { GetNewRec } procedure init(fname: TFileName); const asize = 5; var i: integer; f: TTable; recs: array[1..asize] of TRec; begin recs[1].id := 6; recs[1].name := \'aa\'; recs[2].id := 1; recs[2].name := \'ff\'; recs[3].id := 8; recs[3].name := \'cc\'; recs[4].id := 9; recs[4].name := \'dd\'; recs[5].id := 10; recs[5].name := \'ee\'; open(fName, f); for i:= 1 to asize do append(f, recs[i]); close(f); end; { init } procedure last(var f: TTable); begin seek(f, filesize(f)); end; { last } {$F+} function less1(rec1,rec2: TRec): boolean; begin less1 := rec1.id < rec2.id; end; { less1 } {$F-} {$F+} function less2(rec1,rec2: TRec): boolean; begin less2 := rec1.name < rec2.name; end; { less2 } {$F-} procedure menu; begin clrscr; Writeln( \' 0.Vyhod\' ); Writeln( \' 1.Proverka suschestvovaniya\' ); { проверка существования } Writeln( \' 2.Sozdanie\' ); { создание } Writeln( \' 3.Dobavlenie\' ); { добавление записи } if IsFiltered then Writeln( \' 4.Ubrat6 filtr\' ) { снятие фильтра } else Writeln( \' 4.Filtr\' ); { установка фильтра } Writeln( \' 5.Vygruzka\' ); { выгрузка данных } Writeln( \' 6.Sortirovka\' ); { сортировка } Writeln( \' 7.Pokaz\' ); { показ } Write( \' Vybran punkt:\'); end; { Menu } procedure next(var f: TTable); begin seek(f,filepos(f)); end; { next } procedure open(fName: TFileName; var f: TTable); begin assign(f, fName); reset(f); end; { open } procedure SetFilter(var f: TTable); begin end; { SetFilter } procedure Show(fName: TFileName); begin open( fname, f ); first(f); for i:= 0 to filesize(f)-1 do begin display(f); next(f); end; close(f); end; { show } procedure sort(fName: TFileName; SortExpr: TFunc); var f: TTable; i,j,n : integer; curr: integer; rec1, rec2: TRec; begin open(fname, f); n:= filesize(f); seek(f,0); for i:= 0 to n-2 do for j:= n-1 downto i+1 do begin seek(f,j-1); read(f,rec1); read(f,rec2); if SortExpr(rec2,rec1) then begin seek(f,j-1); write(f,rec2); write(f,rec1); end; end; close(f); end; { sort } procedure UnLoad(ffrom, fto: TFileName; FilterExpr: TFilterFunc); var i: integer; rec: TRec; begin create(fto); open(ffrom, f); open(fto, f2); first(f); for i:= 0 to filesize(f)-1 do begin read(f,rec); if not IsFiltered or FilterExpr(rec, etalon) then append(f2,rec) end; close(f2); close(f); end; { UnLoad } begin { main } iChoice := 0; IsFiltered := false; fName := \'\'; fname2 := \'\'; while true do begin menu; readln( iChoice ); case iChoice of 0: { выход } begin readln; exit; end; 1: { проверка существования } begin write(\'polny put k failu = \'); readln(fName); if exists(fname) then writeln(\'suschestvuet\') else writeln(\'ne suschestvuet\'); readln; end; 2: { создание } begin write(\'polny put k failu = \'); readln(fName); create(fName); init(fName); end; 3: { добавление записи } begin GetNewRec(rec); open(fname, f); append(f,rec); close(f); end; 4: { ввод / снятие фильтра } begin if IsFiltered then IsFiltered := false else begin IsFiltered := true; clrscr; writeln(\'vybor polya\'); writeln(\'1.id\'); writeln(\'2.name\'); readln(sortfield); write(\'znak \'); readln(symbol); write(\'etalon.id \'); readln(etalon.id); write(\'etalon.name\'); readln(etalon.name); if not (sortfield in [1..2]) or not (symbol in [\'>\', \'<\', \'=\']) then begin write(\'oshibka\'); readln; end else begin if (sortfield = 1) and (symbol = \'<\') then flt := flt1 else if (sortfield = 2) and (symbol = \'=\') then flt := flt2; end; end; readln; end; 5: { выгрузка данных } begin clrscr; write(\'otkuda \'); readln(fName); write(\'kuda \'); readln(fName2); flt := flt1; UnLoad(fname, fname2, flt); readln; end; 6: { сортировка } begin clrscr; writeln(\'vybor polya\'); writeln(\'1.id\'); writeln(\'2.name\'); readln(sortfield); if not sortfield in [1..2] then begin write(\'net takogo polya\'); readln; end else begin case sortfield of 1: lt := less1; (*\'id\'*) 2: lt := less2; (*\'name\'*) end; { case } sort(fname,lt); end; end; 7: { показ } begin if fname = \'\' then begin write(\'polny put k dannomu failu = \'); readln(fName); end; show(fname); if fname2 = \'\' then begin write(\'polny put k vygrugennomu failu = \'); readln(fName2); end; show(fname2); readln; end; end; { case } end; end.

Ответ отправил: leonid59, 5-й класс
Ответ отправлен: 22.07.2009, 12:34

Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 252473 на номер 1151 (Россия) | Еще номера >>

Отправить WebMoney: Неплохо (25 руб.) Хорошо (35 руб.) Отлично (50 руб.) БЛЕСТЯЩЕ! (75 руб.)

Вам помогли? Пожалуйста, поблагодарите эксперта за это!

подать вопрос экспертам этой рассылки >>