Прощу помощи, горит зачет…кто может помогите плиз решить 5 задач на паскале, желательно с небольшим описанием, чтобы я мог потом восстановить ход решения, и сдать все в полном виде. Заранее благодарен.
Задача1.
Считая что введенный текст содержит только буквы русского алфавита, подсчитайте, какая буква встречается в нем чаще других. Если несколько букв встречаются одинаковое (максимальное) кол-во раз, то учитывая все эти буквы. Выдайте на экран исходную строку, букву или буквы часто встречающиеся в строке.
Задача2.
Принять экран за декартову сиситему координат с центром в середине экрана. Направление осей-стандартное. В системе заданы три точки своими координатами(Ха, Уа)
(Хв,Ув),(Хс, Ус). Полагая, что этов Ершины треугольника:
-нарисовать на экране оси координат, заданный треугольник, высоты в заданном треугольнике
-Определите значение наибольшей из высот треугольника.
Задача3.
Двумерный массив А(11,11) заполнен случайным образом целыми трехзначными числами в диапозоне от -77 дол 77, причем значения не должны повторятся. Упорядочить массив по спирали против часовой стрелки, поместив в середину самый младший элемент. Вывести исходный массив и результат на экран.
Задача4.
А. Создать файл, содержащий сведения о наличии справочной литературы в библиотеке. Каждый файл содержит: Наименование справочника, год издания, предмет дял которого может быть использован. Кол-во записей произвольное.
Б. Напечатать список л-ры, который может быть использован для доклада по заданному предмету Год издания справочника должен быть не ниже указанного года.
Задача5.
Дано N четырехзначных чисел. Напишите программу, которая находит среди них число с максимальной суммой средних цифр. Число N вводится с клавиатуры, сами числа получают случайным образом. Сумму средних цифр числа определяют в подпрограмме.

Вот, что предложила моя извращенная логика по поводу первой задачи:

Код

procedure TForm1.Button1Click(Sender: TObject); var bukv: array[1..33] of integer; i: integer; z,y: integer; bb: array[1..33] of integer; bv: array[1..33] of integer; begin z:=0; y:=1; for i:=1 to 33 do begin   bukv[i]:=0;   bb[i]:=0;   bv[i]:=0; end; for i:=1 to length(label1.Caption) do begin   case label1.Caption[i] of    'а': bukv[1]:=bukv[1]+1;    'б': bukv[2]:=bukv[2]+1;    'в': bukv[3]:=bukv[3]+1;    'г': bukv[4]:=bukv[4]+1;    'д': bukv[5]:=bukv[5]+1;    'е': bukv[6]:=bukv[6]+1;    'ё': bukv[7]:=bukv[7]+1;    'ж': bukv[8]:=bukv[8]+1;    'з': bukv[9]:=bukv[9]+1;    'и': bukv[10]:=bukv[10]+1;    'й': bukv[11]:=bukv[11]+1;    'к': bukv[12]:=bukv[12]+1;    'л': bukv[13]:=bukv[13]+1;    'м': bukv[14]:=bukv[14]+1;    'н': bukv[15]:=bukv[15]+1;    'о': bukv[16]:=bukv[16]+1;    'п': bukv[17]:=bukv[17]+1;    'р': bukv[18]:=bukv[18]+1;    'с': bukv[19]:=bukv[19]+1;    'т': bukv[20]:=bukv[20]+1;    'у': bukv[21]:=bukv[21]+1;    'ф': bukv[22]:=bukv[22]+1;    'х': bukv[23]:=bukv[23]+1;    'ц': bukv[24]:=bukv[24]+1;    'ч': bukv[25]:=bukv[25]+1;    'ш': bukv[26]:=bukv[26]+1;    'щ': bukv[27]:=bukv[27]+1;    'ъ': bukv[28]:=bukv[28]+1;    'ы': bukv[29]:=bukv[29]+1;    'ь': bukv[30]:=bukv[30]+1;    'э': bukv[31]:=bukv[31]+1;    'ю': bukv[32]:=bukv[32]+1;    'я': bukv[33]:=bukv[33]+1;   end; end; for i:=1 to 33 do begin   if bukv[i]>bb[1] then     bb[1]:=bukv[i]; end; z:=bb[1]; for i:=1 to 33 do begin   if bukv[i]=z then begin     bb[y]:=i;     bv[y]:=z;     inc(y);   end; end; for i:=1 to 33 do begin   if bb[i]<>0 then     memo1.Lines.Add(inttostr(bb[i])+' '+inttostr(bv[i])); end; end;

Правда на Delphi, но это не существенно. Единственное, что может быть нужно в CASE добавить заглавные буквы.

Вот тебе задача 3

- напомните, что есть среднее число

Код

Uses Crt; const Adim = 11; var A: array [1..Adim, 1..Adim] of integer;    RndCnt, i, Steps: integer;    Rnd, TmpRnd: array [1..Adim*Adim] of integer; {fill not repeatable values here} function GetNextRandom: integer; label _again; var k, newVal: integer; begin _again:  newVal := Random(77*2) - 77;  for k := 1 to RndCnt do    if newVal = Rnd[k] then goto _again;  inc(RndCnt);  Rnd[RndCnt] := newVal;  GetNextRandom := newVal; end; {anticlokwise (y, x: integer); clockwise (x, y:integer)} {and write it down } procedure FillChunk(y, x: integer); var newVal: integer; begin  inc(RndCnt);  A[x][y] := Rnd[RndCnt];  GotoXY(x*5,y);  Write(A[x][y]);  Delay(800); end; {fill matrix line by line} procedure FillCircle(i:integer); var k: integer;    x: integer; begin  x := Adim - i + 1;  for k := i to x do FillChunk(k, i);  for k := i + 1 to x do FillChunk(x, k);  for k := x - 1 downto i do FillChunk(k, x);  for k := x - 1 downto i + 1 do FillChunk(i, k); end; { fill and sort arrays } procedure InitArray; var r, c, tmp: integer; begin  for r := 1 to Adim*Adim do TmpRnd[r] := GetNextRandom;  for r := 1 to Adim*Adim - 1 do    for c := r to Adim*Adim do       if Rnd[c] > Rnd[r] then       begin         tmp := Rnd[c];         Rnd[c] := Rnd[r];         Rnd[r] := tmp;       end; end; BEGIN  ClrScr;  Randomize;  RndCnt := 0;  InitArray;  RndCnt := 0;  Steps := TRUNC(Adim / 2 + 0.5);  for i := 1 to Steps do FillCircle(i); END.

Это сообщение отредактировал(а) man2002ua - 31.3.2003, 21:39

№5

Код

function opr(var a:integer):integer;        //подпрограмма begin opr:=int(a/1000)+int(a/100); end;                                                        //подпрограмма begin                                   //основной блок var a,b,n,max:integer; read(n);                              // n-кол-во вводимых чисел while n<>0 do begin n:=n-1; readln(a)                           //a-собственно четырехзначное число b:=opr(a); if b>max then max:=b; end; writeln(max); end;                                     //основной блок

C Паскалем давно не работал могут быть ошибки?!

Это сообщение отредактировал(а) 78125 - 31.3.2003, 21:54

Номер 4

Код

program Project1; {$APPTYPE CONSOLE} uses Crt; type  MyRec = record   Name,   Subj: string;   Year,   ID  : integer;  end; var  MyCase :byte;  MyFileName,  MySubj :String;  MyYear :integer; Procedure CreateMyFile(FileName:string);   //&#240;&#229;&#248;&#229;&#237;&#232;&#229; &#192; var A     :Myrec; F     :File of MyRec; cont  :char; begin Assign(F,FileName); Rewrite(F); A.ID:=1; Write('&#196;&#238;&#225;&#224;&#226;&#232;&#242;&#252; &#231;&#224;&#239;&#232;&#241;&#252; +',A.ID,' (Y/N)?');ReadLn(cont); While (cont<>'y') and (cont<>'Y') do  begin   Write('&#205;&#224;&#231;&#226;&#224;&#237;&#232;&#229;: ');   ReadLn(A.Name);   Write('&#207;&#240;&#229;&#228;&#236;&#229;&#242;: ');    ReadLn(A.Subj);   Write('&#195;&#238;&#228; &#232;&#231;&#228;&#224;&#237;&#232;&#255;: ');ReadLn(A.Year);   WriteLn(F,A);   Inc(A.ID);  end; end; Procedure MyQuery(FileName,QSubj:string;QYear:integer);  //&#240;&#229;&#248;&#229;&#237;&#232;&#229; &#193; var A :MyRec; F :File of MyRec; begin Assign(F,FileName); Reset(F); While not EoF(F) do  begin   ReadLn(F,A);   if (A.Subj = QSubj)and(A.Year >= QYear)    then Writeln('&#211;&#247;.&#199;&#224;&#239;&#232;&#241;&#252; +',A.ID,' ',A.Name,' ',A.Year);  end; end; BEGIN MyCase:=0; while MyCase <> 3 do  begin   clrscr;   WriteLn('&#194;&#251;&#225;&#229;&#240;&#232;&#242;&#229; &#228;&#229;&#233;&#241;&#242;&#226;&#232;&#229;:');   Writeln(' 1 - &#241;&#238;&#231;&#228;&#224;&#242;&#252; &#244;&#224;&#233;&#235;');   Writeln(' 2 - &#239;&#238;&#232;&#241;&#234;');   Writeln(' 3 - &#226;&#251;&#245;&#238;&#228;');   Write('&#194;&#251;&#225;&#238;&#240;: '); ReadLn(MyCase);   case MyCase of    1:begin       Write('&#232;&#236;&#255; &#244;&#224;&#233;&#235;&#224;: ');       ReadLn(MyFileName);       CreateMyFile(MyFileName);      end;    2:begin       Write('&#232;&#236;&#255; &#244;&#224;&#233;&#235;&#224;: ');       ReadLn(MyFileName);       Write('&#205;&#224;&#231;&#226;&#224;&#237;&#232;&#229; &#239;&#240;&#229;&#228;&#236;&#229;&#242;&#224;: ');       ReadLn(MySubj);       Write('&#227;&#238;&#228; &#232;&#231;&#228;&#224;&#237;&#232;&#255;: ');       ReadLn(MyYear);       MyQuery(MyFileName, MySubj, MyYear);      end;   end;  end; END.

Вот вроде так....

ммдя ....
звиняй за шрифты

Модератор: Впредь придерживайтесь правил форума:
1) Название темы должно отражать суть задачи
2) Один топик - 1 вопрос, а не 5

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

Цитата(man2002ua @ 1.4.2003, 09:33)

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

Тем ни менее о приведенных решениях могут возникнуть вопросы или обсуждения и топик превратится в кашу. Дальнейшие обсуждения в разделе "Обсуждение форума"...

Огромное всем спасибо! Я действительно все благодарен)) осталась 2я задача и все...в пондельник сдаю)))

Приветствую!

Значит так, поскольку осталась только одна задача, попробую ее решить:
Для того, чтобы узнать какая высота наибольшая, их надо всех вычислить, тогда, по формуле:

S=(1/2)ah

можно вывести высоту:

h=2S/a

Но так же:

S=sqrt(p(p-a)(p-b)(p-c)), p=1/2(a+b+c)

далее:

a=sqrt((x1-x2)^2+(y1-y2)^2)
b=sqrt((x2-x3)^2+(y2-y3)^2)
c=sqrt((x3-x1)^2+(y3-y1)^2)


То:

Цитата

program Triangles; var   S, p: real;   a, b, c: real;   x1, x2, x3, y1,y2,y3: real; begin   read(x1, y1, x2, y2, x3, y3);   a:=sqrt((x1-x2)*(x1-x2)+(y1-y2)*(y1-y2));   b:=sqrt((x2-x3)*(x2-x3)+(y2-y3)*(y2-y3));   c:=sqrt((x3-x1)*(x3-x1)+(y3-y1)*(y3-y1));   p:=(1/2)*(a+b+c);   S:=sqrt(p*(p-a)*(p-b)*(p-c));   a:=2*S/a;   b:=2*S/b;   c:=2*S/c;   if b>a then a:=b else     if c>a then a:=c;   writeln(a); end.

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

Цитата(Flamberg @ 3.4.2003, 12:44)

Огромное всем спасибо! Я действительно все благодарен)) осталась 2я задача и все...в пондельник сдаю)))

Напиши потом как зачет

Цитата

for i:=1 to length(label1.Caption) do begin   case label1.Caption[i] of   'а': bukv[1]:=bukv[1]+1;   'б': bukv[2]:=bukv[2]+1;   'в': bukv[3]:=bukv[3]+1;   'г': bukv[4]:=bukv[4]+1;   'д': bukv[5]:=bukv[5]+1;   'е': bukv[6]:=bukv[6]+1;   'ё': bukv[7]:=bukv[7]+1;   'ж': bukv[8]:=bukv[8]+1;   'з': bukv[9]:=bukv[9]+1;   'и': bukv[10]:=bukv[10]+1;   'й': bukv[11]:=bukv[11]+1;   'к': bukv[12]:=bukv[12]+1;   'л': bukv[13]:=bukv[13]+1;   'м': bukv[14]:=bukv[14]+1;   'н': bukv[15]:=bukv[15]+1;   'о': bukv[16]:=bukv[16]+1;   'п': bukv[17]:=bukv[17]+1;   'р': bukv[18]:=bukv[18]+1;   'с': bukv[19]:=bukv[19]+1;   'т': bukv[20]:=bukv[20]+1;   'у': bukv[21]:=bukv[21]+1;   'ф': bukv[22]:=bukv[22]+1;   'х': bukv[23]:=bukv[23]+1;   'ц': bukv[24]:=bukv[24]+1;   'ч': bukv[25]:=bukv[25]+1;   'ш': bukv[26]:=bukv[26]+1;   'щ': bukv[27]:=bukv[27]+1;   'ъ': bukv[28]:=bukv[28]+1;   'ы': bukv[29]:=bukv[29]+1;   'ь': bukv[30]:=bukv[30]+1;   'э': bukv[31]:=bukv[31]+1;   'ю': bukv[32]:=bukv[32]+1;   'я': bukv[33]:=bukv[33]+1;   end; end;

А зачем? Ведь можно намного короче:

Цитата

for i:=1 to length(label1.Caption) do     inc(bukv[label1.Caption[i]-'a']); end;

Ой опять забыл войти. Это был я

По поводу первой, вот так, кажись быстрее будет:

Цитата

type   TCounters=array[0..33] of Word;   TPointers=array[0..33] of Word; var   A: TCounters;   P: TPointers;   C: Byte;   I: Integer;   S: string;   L: Integer;   max: Integer; begin   L:=length(S);   C:=1;   read(S);   for I:=1 to L do     inc(A[S[I]]);   max:=A[1];   for I:=2 to 33 do     if A[I]>max then begin       max:=A[I];       C:=1;       P[1]:=I;     end else       if A[I]=max then begin         C:=C+1;         P[C]:=I;       end;   while C>0 do begin     write(chr(ord('a')+P[C])); //or may be you must use here format procedure     C:=C-1;   end;

Посмотри только может нужно заменить строку с моим комментарием на:

write(format('%c', chr(ord('a')+P[C]));