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

[Merlin Cori]

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

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

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

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

[Ghost]

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]

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

[Ghost]

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.

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

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

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

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]

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

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

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

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

[Ghost]

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


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

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.

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

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

большое спасибо!!! как появится свободная минутка сяду разберусь...
и тут же появляется задача номер 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]

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.

СПАСИБО

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

насчет 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
)
респект!

[Ghost]

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

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.

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

[Ghost]

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.

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

[Merlin Cori]

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

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

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