IMHO.WS - Нужно написать маленькую прогу на Pascal

IMHO.WS (http://www.imho.ws/index.php)

- Программирование (http://www.imho.ws/forumdisplay.php?f=40)

- - Нужно написать маленькую прогу на Pascal (http://www.imho.ws/showthread.php?t=75130)

Merlin Cori

06.12.2004 14:02

Нужно написать маленькую прогу на Pascal

Племяннику сестры жены надо..... :)

Вводится натуральное число М и цифра А. Требуется получить новое число N, вычеркивая из числа М цифру А и одновременно меняя порядок числа М на обратный....

Например число М=1215 и цифра А=1. N получаем 52

А то я из Паскаля, кроме его названия, уже ничего не помню :)

Ghost

06.12.2004 14:20

Код:

uses

  crt;



var

  m: string;

  a: char;

  n: string;

  i: integer;



begin

  clrscr;

  write('vvedite chislo: ');

  readln(m);

  write('vvedite zifru: ');

  readln(a);

  n := '';

  for i := length(m) downto 1 do

    if m[i] <> a then

      n := n + m[i];

  writeln('resultat: ', n);

  readkey;

end.

Merlin Cori

06.12.2004 14:39

Ghost
надо было дописать, что строки использовать нельзя.... моя ошибка....
Так было б слишком просто :)

Ghost

06.12.2004 15:01

Код:

uses

  crt;



var

  m, a, n, k: word;



begin

  clrscr;

  repeat

    write('vvedite chislo: ');

    readln(m);

    if m = 0 then writeln('error: chislo dolzhno byt naturalnym');

  until m > 0;

  repeat

    write('vvedite zifru: ');

    readln(a);

    if a > 9 then writeln('error: eto ne zifra - eto chislo');

  until a < 10;

  n := 0;

  while m <> 0 do begin

    k := m mod 10;

    m := m div 10;

    if k <> a then n := n * 10 + k;

  end;

  writeln('resultat: ', n);

  readkey;

end.

bad3p

11.12.2004 18:27

У меня похожая проблема=)
даны 2 целых числа. известно, что одно из них является делителем другого. Найти результат деления без использования стандартных операций.
желательно хитрый способ (но не алгоритм деления столбиком и не перебор умножением)
спасибО!

bad3p

12.12.2004 14:06

впринципе перебором тоже можно, но тогда с уменьшением дипазона. т.е. сначала проверили умножением делителя на 100,200,300...потом по 10,20,30...и по единице.

yunus

16.12.2004 08:09

хитрый способ

если уж очень хитро то так -

Код:

program Task1;



uses

  SysUtils;



function HDiv(A, B: Integer): Integer;

{Делит a на b возвращая результат или 0 в случае невозможности}

function Recurse(Min, Max: Integer): Integer;

var

  Res: Integer;

begin

    if Min = Max then

    begin

      if B * Min = A then

        Recurse := Min

      else

      begin

        Recurse := 0;

      end;

    end else

    begin

      Res := (Max + Min) div 2;

      if B * Res = A then

        Recurse := Res

      else

      if B * Res > A then

      begin

        if Res = Max then

          Recurse := 0

        else

          Recurse := Recurse(Min, Res)

      end else

      begin

        if Res = Min then

          Recurse := 0

        else

          Recurse := Recurse(Res, Max);

      end;

    end;

end;



begin

  if B > A div 2 then {совсем без деления -  Max := A shr 1}

  begin

    if A = B then

      HDiv := 1

    else

      HDiv := 0;

  end else

    HDiv := Recurse(2, A div 2);

end;



var

  c: Integer;

begin

  c :=  HDiv(120, 6);  {сюда вставляются числа}



  if c = 0 then

    Writeln('Inaccessible result')

  else

    Writeln('Result - ', c);

  Readln;

end.

- хотя нормальный человек просто отнимал бы в цикле b от a до получения результата :)

Merlin Cori

16.12.2004 09:34

Всем спасибо :)
Вопрос закрыт :)

bad3p

22.12.2004 13:42

у меня еще вопросик. вернее два))
1. Получить упорядоченный по убыванию массив C[n] путем слияния упорядоченных по убыванию массивов A[20] и B[n-20]. Массив С формировать непосредственно при слиянии А и В.
В массив ввести типизованную константу массив.

2. Дана матрица Х размерности N x N. Две строки матрицы называются похожими если совпадают совокупности чисел, встречающихся в этих строках. Найти количество попарно похожих и непохожих строк матрицы Х. вывести спивок этих строк.

если кто хорошо шарит и кому не сложно напишите плз эти проги сюда.

Ghost

22.12.2004 15:00

bad3p
Могем и написать, только объясни мне дубу, что означает:
1. ...в массив ввести типизованную константу массив...
2. ...совпадают совокупности чисел...
:idontnow:

Вот тебе первая задачка (кажись работает):

Код:

const

  n = 30;  a: array [1..20] of byte =

    (29, 27, 25, 23, 21, 19, 17, 16, 15, 14, 13, 12, 11, 9, 7, 6, 5, 4, 2, 1);

  b: array [1..(n - 20)] of byte =

    (30, 28, 26, 24, 22, 20, 18, 10, 8, 3);

var

  c: array [1..n] of byte;

  i, j, k: integer;

begin

  i := 1;

  j := 1;

  k := 1;

  while (j <= 20) and (k <= (n - 20)) do begin

    if a[j] > b[k] then begin

      c[i] := a[j];

      inc (j);

    end else begin

      c[i] := b[k];

      inc (k);

    end;

    inc (i);

  end;

  if j > 20 then begin

    while (k <= (n - 20)) do begin

      c[i] := b[k];

      inc (k);

      inc (i);

    end;

  end else begin

    while (j <= 20) do begin

      c[i] := a[j];

      inc (j);

      inc (i);

    end;

  end;

  for i := 1 to n do write (c[i] : 3);

end.

Я так понимаю, "совподают совокупности" означает, что в строках расположены одни и те же числа, причем не важно в каком порядке... Ща попробуем...

Ага. Вот: (в проге для простоты массив Х генерируется случайным образом, состоит только из 0, 1 и 2 (чтобы точно были похожие строки) и имеет размерность 4; все это, есессно, можно легко изменить: поменять константу N и параметр вызова функции Random())

Код:

uses

  crt;



const

  n = 4;



var

  x: array [1..n, 1..n] of byte;

  i, j, k: integer;



function like(n1, n2: integer): boolean;

var

  s: set of byte;

  i, j: integer;

begin

  s := [1..n];

  for i := 1 to n do begin

    j := 0;

    repeat inc(j)

    until (j > n) or ((x[n1, i] = x[n2, j]) and (j in s));

    if j > n then break else exclude(s, j);

  end;

  like := (s = []);

end;



begin

  clrscr;

  randomize;

  writeln ('X:');

  for i := 1 to n do begin

    for j := 1 to n do begin

      x[i, j] := random(3);

      write (x[i, j]:4);

    end;

    writeln;

  end;

  writeln;

  writeln ('pohozhie:');

  k := 0;

  for i := 1 to pred(n) do for j := succ(i) to n do if like(i, j) then begin

    writeln ('x[', i:2, ']  ~ x[', j:2, ']');

    inc (k);

  end;

  writeln ('ih kolichestvo: ', k);

  writeln;

  writeln ('nepohozhie:');

  k := 0;

  for i := 1 to pred(n) do for j := succ(i) to n do if not like(i, j) then begin

    writeln ('x[', i:2, '] !~ x[', j:2, ']');

    inc (k);

  end;

  writeln ('ih kolichestvo: ', k);

  readkey;

end.

bad3p

22.12.2004 15:53

если честно, то и сам не понял)) ну с типизованной константой думаю разберусь как время будет...надо конспект поковырять...

а на счет этого "2. ...совпадают совокупности чисел..." думаю чтобы в начале вводили сколько элементов подряд должно повторяться. тогда если столько или больше то похожие.
впринципе можещь изменить немного, если это будет в сторону усложнения задания и упрощуния алгоритма, то это только хорошо.
правда в таком случае надо будет уже мне дубу прокомментировать что да как в проге.
все спасибо!

bad3p

23.12.2004 00:01

большое спасибо!!! :yees: как появится свободная минутка сяду разберусь...
и тут же появляется задача номер 3.

задание:
по введённой дате программа должна сказать какой день недели.

требования:
type
"число" = 1..31 (тип диапазон)
"месяц" = 1..12
"год" = 1..2100
"день_недели" = (PN,VT,SRE,CHE,PIA,SUB,VOS);
var ch: "число"
mes: "месяц"
god: "год"
D_N: "день_недели"

вот такие вот переменные должны быть в проге. сам плохо шарю в этих вещах, так что ничего более объяснить не могу...увы((
пользоваться "sudc" и "pred"

Высокосный год - который делится на 4, за исключением тех, которые делятся на 100 и не делятся на 400.

Ghost

23.12.2004 12:03

bad3p
Пришлось малехо помучиться :)

Код:

uses

  crt;



type

  years  = 0..2100;

  months = 1..12;

  days   = 1..31;



const

  day_months: array [months] of days =

    (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);

  day_weeks:  array [0..6] of string =

    ('VOS', 'PN', 'VT', 'SRE', 'CHE', 'PIA', 'SUB');



var

  year:  years;

  month: months;

  day:   days;

  feb29: boolean;

  alld:  longint;

  i:     integer;



begin

  clrscr;

  write ('year  (0-2100): '); readln(year);

  write ('month (1-12):   '); readln(month);

  feb29 := ((year mod 4) = 0);

  if ((year mod 100) = 0) then feb29 := ((year mod 400) <> 0);

  if feb29 then day_months[2] := 29 else day_months[2] := 28;

  repeat

    write ('day   (1-', day_months[month], '):   '); readln(day);

  until (day > 0) and (day <= day_months[month]);

  alld := year + (year div 4) - 3;

  for i := 1 to pred(month) do inc (alld, day_months[i]);

  alld := (alld + day) mod 7;

  writeln('day of week:    ', day_weeks[alld]);

  readkey;

end.

bad3p

24.12.2004 20:55

СПАСИБО

bad3p

25.12.2004 21:44

взялся вобщем я за эти проги. хотелось бы по-больше комментариев, что где считает и для чего какая переменная (т к преподше надо отчитываться по полной программе, если почует халяву :rolleyes: - мне хана=)

насчет 3 задачки. она считает сегодняшнюю дату 2004 12 25 правильно, но вот например 2000 12 25 уже не правильно.
вот нащел ту которая считает правильно, но она сделана не по тем требованиям. если не сложно, то или подправь свою или переделай эту...

Код:

program caiendar;

var d,m,y,c,g:integer;

begin

writeln ('‚ўҐ¤ЁвҐ Ј®¤, *®¬Ґа ¬Ґбпж* Ё зЁб«®');

readln (g,m,d);

y:=g mod 100;

c:=g div 100;

if m>=3 then m:=m-2 else m:=m+10;

g:=(d+trunc(0.2*(13*m-1))+y+trunc(y/4)+trunc(c/4)-2*c) mod 7;

write ('¤Ґ*м *Ґ¤Ґ«Ё-');

if g=1 then writeln ('Ї®*Ґ¤Ґ«м*ЁЄ'); {poned}

if g=2 then writeln ('ўв®а*ЁЄ');

if g=3 then writeln ('баҐ¤*');

if g=4 then writeln ('зҐвўҐаЈ');

if g=5 then writeln ('Їпв*Ёж*');

if g=6 then writeln ('бгЎЎ®в*');

if g=0 then writeln ('ў®бЄаҐбҐ*мҐ');{vos}

end.

еще раз прошу. чем больше коммнетариев тем лучше!(идеальный вариант каждая строка коммент
просто я например даже не знаю что такое inc
:contract: )
респект! :yees: :beer:

Ghost

27.12.2004 11:45

bad3p
Проще переделать твою прогу, поскольку у меня нет ни времени, ни желания искать ошибку в своей. Собственно, с самого начала я и хотел написать именно так, но не мог вспомнить формулу. Как работает эта формула и кто ее вывел - ума не дам :idontnow: Держи свой вариант с моими добавлениями:

Код:

uses

  crt;



const

  day_weeks:  array [0..6] of string = { массив с днями недели }

    ('VOS', 'PN', 'VT', 'SRE', 'CHE', 'PIA', 'SUB');



type

  years  = 0..2100; { тип-диапазон: годы }

  months = 1..12;   { тип-диапазон: месяцы }

  days   = 1..31;   { тип-диапазон: дни }



var

  year:  years;   { год }

  month: months;  { месяц }

  day:   days;    { день }

  r,              { результат }

  p:     integer; { дополнительная переменная }



begin

  clrscr;

  repeat { вводим номер года }

    write ('year  (0-2100): '); readln(year);

  until (year >= 0) and (year < 2101);

  year := year mod 100; { вычисляем номер года в столетии }

  p    := year div 100; { вычисляем столетие }

  repeat { вводим номер месяца }

    write ('month (1-12):   '); readln(month);

  until (month > 0) or (month < 13);

  { делаем март - первым месяцем, а январь и февраль перемещаем в конец года }

  if month >= 3 then month := month - 2 else month := month + 10;

  repeat { вводим день }

    write ('day   (1-31):   '); readln(day);

  until (day > 0) and (day < 32);

  { вычисляем номер дня недели по формуле }

  r := (day + trunc(0.2 * (13 * month - 1)) + year + trunc(year / 4) +

       trunc(p / 4) - 2 * p) mod 7;

  { выводим название дня недели из массива }

  writeln('day of week:    ', day_weeks[r]);

  readkey;

end.

bad3p

27.12.2004 19:35

просто супер! =))
вот если бы еще коммнентарии к задаче номер 2 (про похожие строки)
СПАСИБО!

Ghost

27.12.2004 19:50

bad3p
no problem ;):

Код:

uses

  crt;



const

  n = 4; { размерность массива }



var

  x: array [1..n, 1..n] of byte;

  i, j, k: integer;



{ функция сравнения строк массива }

function like(n1, n2: integer): boolean;

var

  s: set of byte;

  i, j: integer;

begin

{ множество S содержит номера элементов строки n2, которые еще не проверялись }

  s := [1..n];

{ каждый элемент строки n1... }

  for i := 1 to n do begin

{ ...сравниваем с каждым элементов строки n2... }

    j := 0;

    repeat inc(j)

{ ...кроме тех, номера которых содержаться в множестве S }

    until (j > n) or ((x[n1, i] = x[n2, j]) and (j in s));

{ если в строке n2 найден элемент, равный текущему элементу строки n1, }

{ то удаляем его номер из множества - чтобы не проверять его еще раз }

    if j > n then break else exclude(s, j);

  end;

{ множество становится пустым только в том случае, когда для каждого элемента }

{ из строки n1 найден равный элемент из строки n2, причем пары равных элементов }

{ не содержат элементов из строки n2 с одинаковыми номерами - т.е. строки "похожи" }

  like := (s = []);

end;



begin

  clrscr;

{ заполняем случайным образом массив и выводим его на экран }

  randomize;

  writeln ('X:');

  for i := 1 to n do begin

    for j := 1 to n do begin

      x[i, j] := random(3);

      write (x[i, j]:4);

    end;

    writeln;

  end;

  writeln;

{ ищем "похожие" строки и выводим их и их количество }

  writeln ('pohozhie:');

  k := 0;

  for i := 1 to pred(n) do for j := succ(i) to n do if like(i, j) then begin

    writeln ('x[', i:2, '] = x[', j:2, ']');

{ увеличиваем счетчик найденных пар строк на 1, т.е. k := k + 1; }

    inc (k);

  end;

  writeln ('ih kolichestvo: ', k);

  writeln;

{ ищем "непохожие" строки и выводим их и их количество }

  writeln ('nepohozhie:');

  k := 0;

  for i := 1 to pred(n) do for j := succ(i) to n do if not like(i, j) then begin

    writeln ('x[', i:2, '] <> x[', j:2, ']');

{ увеличиваем счетчик найденных пар строк на 1, т.е. k := k + 1; }

    inc (k);

  end;

  writeln ('ih kolichestvo: ', k);

  readkey;

end.

bad3p

27.12.2004 20:30

просто нет слов=))
все вопросов больше не имею! =)

Merlin Cori

10.02.2005 18:00

Тут подплыли еще 2 задачки...

1. Найти наибольший общий делитель 3 натуральных чисел, имея ввиду, что NOD(a,b,c)=NOD(NOD(a,b),c). Вычисление NOD(a,b) оформить в виде подпрограммы.

2. Дан массив целых чисел. Поверить, является ли массив полиндромом

Ghost

10.02.2005 19:42

Merlin Cori
Вырвался с пары по прологу, держи первую прогу :)

Код:

uses

  crt;



function nod (a, b: word): word;

begin

  while a <> b do if a > b then dec (a, b) else dec (b, a);

  nod := a;

end;



var

  x, y, z: word;



begin

  clrscr;

  write ('x = '); readln (x);

  write ('y = '); readln (y);

  write ('z = '); readln (z);

  writeln ('nod = ', nod (nod (x, y), z));

  readkey;

end.

Ща чучка попозжа вторую положу

Держи вторую :)

Код:

uses

  crt;



const

  n = 4;



var

  a: array [1..n] of integer;

  i: integer;

  p: boolean;



begin

  clrscr;

  randomize;

  write ('array [');

  for i := 1 to n do begin

    a[i] := random(4);

    write (a[i]:3);

  end;

  writeln ('] is palindrom? ');

  p := true;

  for i := 1 to (n div 2) do begin

    p := p and (a[i] = a[n - i + 1]);

    if p then break;

  end;

  if p then writeln ('yes! :)') else writeln ('no... :(');

  readkey;

end.

Усё... Побегу дальше пролог мучить (или студентов?)

Ghost

11.02.2005 07:24

Мляяя. Вчера выложил прогу, ушел на пару, с пары помчался домой, только в маршрутке вспомнил про ошибку... :( Во второй программе вместо "if p then break;" - "if not p then break;". Сорри. :молись:

TATIANAF495

10.10.2010 18:15

Помогоите пожулуйста написать 2 программки)
1.Вывести на экран цифру,с которой начинается число N.
2.Дан ман массив целых чилел.Проверить,является ли массив палиндромом.

Часовой пояс GMT +4, время: 05:22.