Форум программистов, компьютерный форум, киберфорум
Pascal (Паскаль)
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.75/4: Рейтинг темы: голосов - 4, средняя оценка - 4.75
0 / 0 / 1
Регистрация: 12.10.2013
Сообщений: 7
1

Составить блок-схемы

14.01.2014, 01:26. Показов 642. Ответов 3
Метки нет (Все метки)

Составьте, пожалуйста, кто сколько может блок-схемы к следующим программам. Понимаю, что это очень нагло с моей стороны, но все-таки. Это мой последний шанс. Если кто-то сможет хоть сколько-нибудь сделать. Нужно сегодня к 13:00 (МСК) или чуть позже, готов заплатить деньги, если что.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
program create_file; {Создание файла данных о группе студентов}
        uses CRT;
        type stud =record num:byte;name:string[16];average:real end;
                 gr_st=file of stud;{типизированный файл записей}
        var gr:gr_st{файл группы студентов}; st:stud{запись о студенте};
              nm:string{имя исходного файла}; s:char{признак Y/N};
              numb:integer{число записей в файле nm};
 BEGIN    clrscr;  repeat write('Имя файла: ');readln(nm);
                if nm='' then halt;assign(gr,nm);s:='Y';
               {$I-}reset(gr);{$I+} if IOResult<>0 then
                     begin write('Открыть новый файл ', nm, '?(Y/N)');
                readln(s); if upcase(s)='Y' then
                begin {$I-}rewrite(gr);{$I+} if IOResult<>0 then
                       begin writeln('Диск недоступен!');nm:= '' end;
                end                                   else nm:='';
                     end until nm<>'';numb:=0;if upcase(s)='Y' then
                         begin seek(gr,filesize(gr));numb:=filesize(gr) end;
            writeln('Всего записей в файле:',numb, '. Введите очередную запись:');
            with st do repeat repeat writeln('Фамилия,инициалы ','Cредний балл');
               readln(name,average);if(average<2)or(average>5) then
               writeln('Ошибка! Повторите ввод последней записи');
                  until(average>=2)and(average<=5);inc(numb);num:=numb; write(gr,st);write('Ввод следующей записи?(y/n)');readln(s);
                     until upcase(s)<>'Y';close(gr);if numb=0 then erase(gr);
         {Конец цикла записи}writeln('Всего записей в файле ',nm,' ',numb);
END {create_file}.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
program volume; { Расчет объема файла, где цепочки пробелов учитываются как один символ}
        uses CRT, DOS;
        const pg=#12;
        var total:pathstr;str:dirstr;fn:namestr;fr:extstr;
            ft:text;alfa,beta:Boolean;
            j,page:byte;a,symb:longint;author:real;
     procedure setdisc;
     var c:string;
     begin writeln(' Установите дискету с файлом ', fn,' и нажмите enter');
           readln(c);{$I-}reset(ft);{$I+}
           if IOResult<>0 then  begin writeln(' Файл ',fn,' не найден!');readln;halt end;  end{setdisc};
     procedure checknm;
     var i:byte;digit:set of '0'..'9';
     begin if str <>'' then
        begin for i:=1 to length(str) do if not (str[i] <>' ') then
              if (str[i]='-') and (str[i+1] in digit) then str:='';
              alfa:=false; end; end{checknm};
     BEGIN page:=1;symb:=0;a:=0;alfa:=false;beta:=false;
           writeln(' Введите полное имя анализируемого файла:');
           readln(total);assign(ft,total);fsplit(total,str,fn,fr);
           {$I-}reset(ft);{$I+}  if IOResult<>0 then
           begin for j:=(length(total)-length(fn)-length(fr)) downto 1 do
                      if total[j] in ['A'..'Z','a'..'z'] then
                        if not (total[j] in ['a','A','b','B']) then
                   begin writeln(' Файл ',fn,' не найден');readln;halt end
                     else begin setdisc;break end;  end;
                   repeat readln(ft,str);if str<>'' then
              begin symb:=symb+length(str);for j:=1 to length(str) do
                     begin if alfa then checknm;
               if str[j]=pg then begin page:=page+1;alfa:=true end;
               if not (str[j] in [pg,' ']) and (not alfa) then inc(a);
               if str[j]=' ' then beta:=true;
               if beta and not (str[j] in [pg,' ']) then
              begin inc(a);beta:=false end; end;  end;
                   until eof(ft);
              author:=a/40000; clrscr;gotoXY(10,10);
                 write(' ОБЪЕМ ТЕКСТА ',fn);gotoXY(10,11);
                 write(' Страниц: ',page);gotoXY(10,12);
                 write(' Всего символов в тексте: ',symb);gotoXY(10,13);
                 write(' Объем в авторских листах: ',author:2:3);
                 gotoXY(10,14);for j:=20 to 80 do write('_');writeln; readln;
     END {volume}.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
program search;{ Выборка из файла данных о группе студентов}
uses CRT;
type stud =record num:byte;name:string[20];average:real end;
       gr_st=file of stud{данные о группе студентов};
var gr:gr_st{группа студентов}; 
      st:stud{запись о студенте};
      nm:string{имя исходного файла};
      avr:string{условие для average};
      sgn:string[1]{знак в условии};ball:real{запрошенный балл};
      pr:boolean{признак выбранной записи};k:integer{кол-во выборок};
       er:integer{ошибка преобразования в число};
BEGIN clrscr;repeat {открытие файла на чтение}
   write('Введите имя файла:'); readln(nm);
     if nm='' then halt;assign(gr,nm);
    {$I-} reset(gr);{$I+} if IOResult<>0 then nm:='';
     until nm<>''; {анализ запроса }
     repeat write('Введите запрос для среднего балла: ');readln(avr);
sgn:=copy(avr,1,1);avr:=copy(avr,2,length(avr)-1);
val(avr,ball,er); if er<>0 then ball:=0;
      until (ball>=2)and(ball<=5); k:=0; writeln('Запрошенные данные:');
  repeat {реализация запроса к файлу nm} read(gr,st);with st do
begin if sgn='>' then pr:=average>ball else pr:=average<=ball;
if pr then begin writeln(name,average:1:2);inc(k);delay(1000) end
end until eof(gr);if k<>0 then writeln('Всего студентов: ',k)
else writeln('Пустая выборка');readkey END {search}.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
program print_text; {Печать текстового файла}
        uses Printer;
        var f:text; {Исходный файл}
              c:char;s,nm:string;  j,p:word;
        const bel=#7;FF=#12;
BEGIN writeln('ПЕЧАТЬ ТЕКСТА ');writeln;write('Имя файла:');readln(nm);
if nm<>'' then   begin {открытие f с контролем существования файла}
          assign(f,nm);{$I-} reset(f);{$I+}
if IOResult<>0 then begin writeln('Ошибка');halt end {конец открытия f} ;
                 j:=1;p:=1;repeat  {цикл печати}if j mod 50=0 then
begin writeln(LST,FF);writeln(bel,'Конец страницы ',p:3);
                      writeln('Печатать следующую страницу(Y/N)?',bel);
                      readln(c);if upcase(c)<>'Y' then
  begin close(f);halt end;p:=p+1;
for j:=1 to 35 do  write(LST,' ');writeln(LST,'-',p,'-');j:=1  end;
readln(f,s);writeln(LST,s);inc(j); until eof(f) {конец цикла печати};
writeln(LST,FF);close(f) end END{print_text}.
    program print_text2;{ с выводом LST на экран}
        var f,LST:text;c:char;s,nm:string;j,p:word;
        const bel=#7;FF=#12;
  BEGIN writeln('ПЕЧАТЬ ТЕКСТА ');writeln;
   write('Имя файла:');readln(nm);if nm<>'' then
 begin assign(f,nm);{$I-} reset(f);{$I+}
  if IOResult<>0 then begin writeln('Ошибка');halt end;
         assign(LST,'con');rewrite(LST);j:=1;p:=1;
                    repeat if j mod 50=0 then
                begin writeln(LST,FF);writeln(bel,'Конец страницы ',p:3);
                      writeln('Печатать следующую страницу(Y/N)?',bel);
                      readln(c);if upcase(c)<>'Y' then
                      begin close(f);halt end;p:=p+1;for j:=1 to 35 do
                            write(LST,' ');writeln(LST,'-',p,'-');j:=1
                end;readln(f,s);writeln(LST,s);inc(j);
            until eof(f);writeln(LST,FF);close(f) end  END{print_text2}.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
program list_tel;{создание списка телефонов}
        uses CRT;
        type refer=^info; {тип - Указатель на запись}
                 info= record name,adr,tel:string; next:refer  end;
        var first,p,pp:refer; {указатели на начало списка и текущие}
               s:string;  
        procedure write_list(start:refer);{вывод всех элементов списка}
        begin repeat with start^ do
                 begin writeln(name); writeln(adr); writeln(tel);
                 end; start:=start^.next
                   until start=nil;  end{write_list};
        BEGIN TextBackground(cyan);TextColor(white);ClrScr;
                      window(10,5,40,20);TextBackground(green); ClrScr;
                          new(first);p:=first;pp:=nil;
              repeat if pp<>nil then {образование очередного элемента}
                          begin new(p);pp^.next:=p end;
                          with p^ do { заполнение элемента списка}
                   begin write('Ф.И.О.:'); readln(name);
                         write('Адрес:');  readln(adr); write('Телефон:');readln(tel);
                         next:=nil  end;  pp:=p;readln(s) until (s=' ');
              writeln('Список телефонов создан'); write_list(first);
              writeln('Вывод списка завершен');  END{list_tel}.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
program stack_tel;{создание стека телефонов}
        uses CRT;
        type ref=^inf; {тип - Указатель на запись }
                 inf= record name,adr,tel:string;
                                     pred:ref end;
        var head,p:ref; {указатель на начало стека и текущий}
              s:string;
             procedure write_stack(start:ref); {вывод всех элементов стека}
         begin repeat with start^ do
                 begin writeln(name); writeln(adr); writeln(tel);
                 end; start:=start^.pred
                   until start=nil  end{write_stack};
         BEGIN TextBackground(cyan);TextColor(white);ClrScr;
                     window(10,5,40,20);TextBackground(green); ClrScr;head:=nil;
              repeat  new(p); with p^ do {заполнение полей записи}
        begin write('Ф.И.О.:'); readln(name); write('Адрес:'); readln(adr);
                  write('Телефон:');readln(tel);pred:=head; end;  head:=p;readln(s)
         until (s=' '); writeln('Стек телефонов создан');
          write_list(head);  writeln('Конец вывода стека'); END{list_tel}.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
program RING_METRO; {Кольцевая линия Московского метро}
        type link=^nest;nest=record forw,back:link;inf:string end;
        var r,r1,start:link;f:text;c,c1,c2:string;dir:Boolean;L:byte;
        procedure insert(el1,el2:link);{вставка el2 после el1}
            begin el2^.forw:=el1^.forw;el2^.back:=el1;el1^.forw^.back:=el2;el1^.forw:=el2;
            end{insert};
        procedure dir_path(var d:Boolean;s1,s2:string);{направление}
        var g:link;j1,j2:byte;er1,er2:Boolean;
            begin j1:=0;j2:=0;g:=start;er1:=false;er2:=false;
             repeat g:=g^.forw;  if g^.inf=s1   then
               repeat g:=g^.forw;j1:=j1+1;er1:=(g^.inf=s1);d:=(2*j1<L);
               until (g^.inf=s2) or (g^.inf=s1)  else  if g^.inf=s2   then
               repeat g:=g^.forw;j2:=j2+1;er2:=(g^.inf=s2);d:=(2*j2>L);
               until (g^.inf=s1) or (g^.inf=s2);
             until (g=start) or (g^.inf=s1) or (g^.inf=s2);if er1 or er2 then
    begin write('Ошибка в названии ');
            if er1  then write('конечной') else write('начальной');writeln(' станции');halt
    end; if j1+j2=0 then begin writeln('Ошибка в названиях станций');halt end
            end {dir_path};
        procedure write_path(d:Boolean;s1,s2:string);{кратчайший путь}
        var p:link;
            begin p:=start; while not(p^.inf=s1) do p:=p^.forw;
              repeat writeln(p^.inf);if d then  p:=p^.forw else p:=p^.back;
              until (p^.inf=s2) ; writeln(p^.inf);
            end {write_path};
        BEGIN writeln('КОЛЬЦЕВАЯ  ЛИНИЯ  МОСКОВСКОГО МЕТРО');
              new(start);r:=start;r^.forw:=r;r^.back:=r;assign(f,'names_st');{$I-}reset(f);{$I+};
             if IOResult<>0 then begin writeln('Не найден файл names_st');halt end;
              L:=1;readln(f,r^.inf);while not eof(f) do{создание кольца }
              begin readln(f,c);new(r1);insert(r,r1);r1^.inf:=c;r:=r1;L:=L+1 end;
              writeln('Задайте начальную и конечную станции:');    readln(c1);readln(c2);              dir_path(dir,c1,c2); writeln('Кратчайший путь:');write_path(dir,c1,c2);
        END{ring_metro}.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
program frequency_letters; {Частота вхождения  латинских букв в строку}
        type link=^node; {тип - Указатель на запись}
                node=record c:char;count:word;left,right:link end;
       var root:link; {Корень дерева поиска} symb:char;j:word;
              L:set of  char; {множество символов}
              s:string; { вводимая строка }
        procedure insert_tree(var r:link;ch:char);{Вставка ch в дерево}
             begin if r=nil then
                   begin new(r);with r^ do begin c:=ch;count:=1;left:=nil;right:=nil end end
                                   else with r^ do
                 if ch<c then insert_tree(left,ch)   else
                 if ch>c then insert_tree(right,ch) else count:=count+1;
             end{insert_tree};
       procedure print_tree(r:link); {Печать количества вхождений букв }
             begin if r<>nil then with r^ do
                   begin print_tree(left);writeln(c,':',count); print_tree(right) end
             end{print_tree};
        procedure search_tree(r:link;ch:char); {Поиск ch и печать}
             begin if r=nil then writeln(ch,':0') else with r^ do
                begin if ch<c then search_tree(left,ch)   else
                          if ch>c then search_tree(right,ch) else writeln(ch,':',count)
                end
             end{search_tree};
   BEGIN L:=['A'..'Z']; root:=nil;writeln(' Введите текст:');while not eof do
          begin readln(s);for j:=1 to length(s) do
      begin if upcase(s[j]) in L then insert_tree(root,s[j]) end;
          end; writeln('СПРАВКА ПО ЧАСТОТАМ ЛАТИНСКИХ БУКВ:');
                  while not eof do begin readln(symb);search_tree(root,symb) end;
                    write('Печатать по всем буквам?(Y/N)');readln(symb);
                    if symb<>'N' then print_tree(root);
   END{frequency_letters}.
0

Помощь в написании контрольных, курсовых и дипломных работ здесь.

Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
14.01.2014, 01:26
Ответы с готовыми решениями:

Составить блок-схемы:
1 программа: разработать квадратную матрицу, вычислить сумму членов матрицы вышеглавной диагонали....

составить блок-схемы
составить блок-схемы program str4; uses crt; var s:string; i,c,max:integer; begin ...

Составить блок схемы!
1)Даны объёмы и массы двух тел из разных материалов. Материал, какого из тел имеет большую...

Нужно составить блок-схемы.
1.Рассматрива строку как массив символов, выполнить следующее. в тексте длины не более 255 знаков,...

3
Модератор
8417 / 4166 / 2878
Регистрация: 17.08.2012
Сообщений: 13,282
14.01.2014, 09:55 2
dollar619, читайте правила форума. Один вопрос - одна тема.
0
0 / 0 / 1
Регистрация: 12.10.2013
Сообщений: 7
14.01.2014, 12:04  [ТС] 3
Неужели никто не хочет подзаработать? Блок-схемы нужны сегодня к 14:00 или к 15:00 (МСК)
0
Модератор
8417 / 4166 / 2878
Регистрация: 17.08.2012
Сообщений: 13,282
14.01.2014, 12:58 4
Цитата Сообщение от dollar619 Посмотреть сообщение
никто не хочет подзаработать?
В этом разделе как-то не принято зарабатывать. Ваши вопросы расположены в разделе форума "Pascal (Паскаль)", а не в разделе "Фриланс". Получается, что Вы сами виноваты в том, что не получите решение в срок.

Добавлено через 10 минут
Полагаю, что Вы можете написать личное сообщение с просьбой о переносе темы в раздел платных услуг кому-либо из модераторов, находящимся на форуме. Однако, я несколько сомневаюсь, что работу для Вас успеют сделать в срок.
0
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
14.01.2014, 12:58

Заказываю контрольные, курсовые, дипломные работы и диссертации здесь.

Составить блок-схемы к двум задачам
program LAB6; const glasn=; soglas=; var st: string; g,s,i:integer; begin ...

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

Составить блок-схемы по готовой программе
program zad; uses crt; type m=array of integer; procedure vvod; var mas:array of...

Написать программу и составить блок схемы
Даны внешние и внутренние радиусы двух колец, центры которых находятся в начале координат. Даны...

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

Нужно составить блок-схемы для 4 программ
Добрый вечер. Помоги пожалуйста составить блок-схемы для следующих программ: №1 program dsf;...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
4
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.