Форум программистов [Powered by Invision Power Board]

Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате

Форум программистов > Delphi: Общие вопросы > Прощу помощи!!!

Автор: Flamberg 31.3.2003, 19:50

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

Автор: Dexter 31.3.2003, 21:21

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

Код



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 добавить заглавные буквы.

Автор: man2002ua 31.3.2003, 21:37

Вот тебе задача 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.

Автор: 78125 31.3.2003, 21:50

№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 Паскалем давно не работал могут быть ошибки?!

Автор: DonPager 1.4.2003, 03:08

Номер 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.

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

Автор: DonPager 1.4.2003, 03:24

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

Автор: Vit 1.4.2003, 04:11

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

Автор: man2002ua 1.4.2003, 18:33

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

Автор: Vit 2.4.2003, 17:29

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

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

Автор: Flamberg 3.4.2003, 12:44

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

Автор: neutrino 3.4.2003, 15:58

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

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

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.

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

Автор: 78125 3.4.2003, 16:39

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

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

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

Автор: Unregistered 3.4.2003, 18:08

Цитата

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;

Автор: neutrino 3.4.2003, 18:10

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

Автор: neutrino 3.4.2003, 18:34

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

Цитата

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]));

Автор: Dexter 5.4.2003, 15:56

Цитата

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

Я же сказал, что это предложила моя извращенная логика