количество счастливых билетов

Кто возьмет билетов пачку, тот получит водокачку!

Нужно посчитать и вывести на экран количество "счастливых билетов"(к примеру: 111201, 333009 и так далее)

Примечание :

Счастливый билетик имеет вид XXXXXX.

var
    a,b,c,d,e,f: integer;
    g: double;
begin
    g:=0;
    for a:=0 to 9 do
    for b:=0 to 9 do
    for c:=0 to 9 do
    for d:=0 to 9 do
    for e:=0 to 9 do
    for f:=0 to 9 do
    if a+b+c=d+e+f then g:=g+1;
    writeln(g);
end.

PS: обычно я решаю сам, а этот пример подсмотрел - уж очень мне понравилась простота решения, единственное что я добавил - это g - переменная типа double, т.к. результат получается больше чем может представлять пременная типа int, ну и в оригинале было inc - пришлось сдеать g=g+1, ибо inc только для целочисленной математики, еще бы полагалось выводить знаки только до запятой (число то все равно целое), но это уже сами кому надо...

найти сумму цифр в числе используя рекурсивную подпрограмму

для простоты будем считать что числа только натуральные

function fun(x:integer; summa: integer) : integer;
var
   d, m: integer;
begin
   m := x mod 10;
   d := x div 10;
   if x > 0
   then fun := fun(d, summa + m)
   else fun := summa + m;
end;

begin
   writeln('cумма цифр = ', fun(1234, 0));
end.

Нахождение корня функции.

Здесь описан метод половинного деления (дитохомии?). Суть проста. Есть функция f(x), есть интервал [a,b], есть условие, что на концах промежутка функция имеет разный знак: f(a)*f(b)<0. Требуется найти с заданной точностью eps корень этой функции. Поступаем так: выбираем середину отрезка [a,b]. Если в середине функция имеет тот же знак что и слева, то принимаем середину за новую левую границу, в противном случае - за правую. Повторяем до тех пор, пока отрезок не станет меньше eps. В данном примере в качестве функции берем синус, а отрезок - [3,4]. Таким образом мы должны найти число пи.

function f(x:real):real;
  begin
  f:=sin(x);
  end;
const MaxSteps=200;
var a0,b0,a,b,eps,fa,fb,t,ft:real;
    step,sa,sb:integer;
begin
writeln('Нахождение корней функции методом половинного деления:');
a0:=3; {writeln(' Input a0: ');readln(a0);}
b0:=4; {writeln(' Input b0: ');readln(b0);}
eps:=0.0000001; {writeln(' Input eps: ');readln(eps);}
fa:=f(a0); fb:=f(b0);
if (fa*fb>0) then
  begin
  writeln(' На заданном промежутке корней нет.');
  halt;
  end;
a:=a0; b:=b0;
step:=0; t:=a; ft:=fa;
while (abs(b-a)>eps) and (step<MaxSteps) do
  begin
  inc(step);
  t:=(a+b)/2;
  ft:=f(t);
  if (fa*ft>0) then
    begin
    fa:=ft;
    a:=t;
    end
  else
    b:=t;
  writeln('step:',step:4,' t=',t,' f(t)=',ft);
  end;
if (step>MaxSteps)
  then writeln('Отсутствие сходимости. Уточните промежуток.')
  else writeln('Найден корень с заданной точностью.');
end.

нахождения корней уравнения методом половинного деления

PROGRAM KORNI;
VAR A,B,PREC:REAL;
FUNCTION F(X:REAL):REAL;
BEGIN
 F:=X*X-3*X+2
END;
FUNCTION KORENJ(A,B,PREC:REAL):REAL;
VAR X,Y,Z:REAL;
BEGIN
 IF ABS(A-B)<PREC THEN KORENJ:=(A+B)/2
   ELSE BEGIN
   X:=F(A);
   Y:=F((A+B)/2);
   Z:=F(B);
   IF X*Y<0 THEN KORENJ:=KORENJ(A,(A+B)/2,PREC)
            ELSE KORENJ:=KORENJ((A+B)/2,B,PREC)
   END
END;
BEGIN
 READLN (A,B,PREC);
 WRITELN ('X=',KORENJ(A,B,PREC))
END.

вывести квадраты и кубы 10 чисел следущей последовательности: 1, 2, 4, 7, 11, 16...

{вывести квадраты и кубы 10 чисел следущей последовательности: 1, 2, 4, 7, 11, 16...}
const
   N = 10;
var
   i: integer;
   m: integer;
begin
   m:=1;
   for i:=1 to N do begin
      writeln(m:3, '=> ^2=', m*m, ', ^3=', m*m*m);
      m:=m+i;
   end;
   writeln;
end.

вывод

1=> ^2=1, ^3=1
  2=> ^2=4, ^3=8
  4=> ^2=16, ^3=64
  7=> ^2=49, ^3=343
 11=> ^2=121, ^3=1331
 16=> ^2=256, ^3=4096
 22=> ^2=484, ^3=10648
 29=> ^2=841, ^3=24389
 37=> ^2=1369, ^3=50653
 46=> ^2=2116, ^3=97336

выделить множество чисел кратных заданому

{Из множества целых чисел 1..20 выделить множество чисел, делящихся на 2 или на 3 без остатка}
const
   N = 20;
var
   a: array [1..N] of integer;
   i: integer;
begin
   writeln('инициализация массива случайными числами');
   for i:=1 to N do a[i]:=random(9)+1;

   writeln('вывод начальных данных');
   for i:=1 to N do write(a[i]:2);
   writeln;
   
   writeln('числа кратные 2: ');
   for i:=1 to N do if (a[i] mod 2) = 0 then write(a[i]:2);
   writeln;
   
   writeln('числа кратные 3: ');
   for i:=1 to N do if (a[i] mod 3) = 0 then write(a[i]:2);
   writeln;

   writeln('числа кратные 2 и 3: ');
   for i:=1 to N do if ((a[i] mod 2) = 0) and ((a[i] mod 3 = 0)) then write(a[i]:3);
   writeln;
end.

вывод:

инициализация массива случайными числами
вывод начальных данных
80 90 85 12 95 45 66 39  3 80 66 91 94 42 27 95 25 25 78 26
числа кратные 2:
80 90 12 66 80 66 94 42 78 26
числа кратные 3:
90 12 45 66 39  3 66 42 27 78
числа кратные 2 и 3: 
90 12 66 66 42 78

посчитать суммы индексов отрицательных элементов массива

дан массив g1, ..g10 .
Построить новый массив, содержащий номера отрицательных g[ i ] . Вычислить сумму этих номеров.

const
    N = 10;
var
    i: integer;
    g: array [1..N] of integer;
    b: array [1..N] of integer;
    count: integer;
    summa: integer;
begin
    writeln('инициализируем массив случайными числами от -50 до 50');
    for i:=1 to N do g[i]:=random(100)-50;

    writeln('начальный массив');
    for i:=1 to N do write(g[i]:4);
    writeln;

    count:=0;
    for i:=1 to N do if g[i] < 0 then begin
        inc(count);
        b[count]:=i;
    end;

    writeln('массив индексов элементов с отрицательными значениями');
    for i:=1 to count do write(b[i]:3);
    writeln;

    summa:=0;
    for i:=1 to count do summa:=summa+b[i];

    writeln('сумма индексов отрицательных элеметов = ', summa);
end.

вывод:

инициализируем массив случайными числами от -50 до 50
начальный массив
 -16 -19  -1  12  -3  40  49 -37 -12  10
массив индексов элементов с отрицательными значениями
  1  2  3  5  8  9
сумма индексов отрицательных элеметов = 28

количество делителей

Вот задание: Количество Делителей. Будем называть количество делителей числа т его красотой. Например, карсота числа 12=6.
Требуется написать программу, которая по числу k(1<=k<=10^9) найдётчисло с максимальной красотой, не превышающее k. Вот напишите код на паскале если не сложно

function krasota(n: integer): integer;
var
   i: integer;
   k: integer;
begin
   k:=0;
   for i:=1 to n do begin
      if (n mod i) = 0 then begin
         inc(k);
      end;
   end;
   krasota:=k;
end;

var
   m: integer;
   n: integer;
   max_n: integer;
   max_krasota: integer;
   k: integer;
begin
   write('считать до: ');
   read(m);

   max_n:=-1;
   max_krasota:=0;

   for n:=1 to m do begin
      k:=krasota(n);
      if k > max_krasota then begin
          max_krasota:=k;
          max_n:=n;
      end;
   end;

   writeln('число с максимальной красотой ', max_n, ' = ', max_krasota);
end.

умышленно не написал от 1 до 10^9 - это будет очень долго считать, но просто чтобы можно было проверить правильность работы - вводим 10000

вывод

искать до: 10000
число с максимальной красотой 7560 = 64

перевод десятичного целого положительного числа в сиситему счисления с основанием 7

Вот сама задача, ее нада сделать)))...
Написать программу перевода десятичного целого положительного числа в сиситему счисления с основанием 7.
СПАСИБО ЗАРАНЕЕ!!!!

const
   N = 7; {поменяйте на нужное число}
var
   x: integer;
   ostatok: integer;
   s: string;
   c: string;
begin
   s:='';
   write('введите десятичное число: ');
   read(x);
   while x >= N do
   begin
      ostatok:=x mod N;
      Str(ostatok, c);
      s:=c+s;
      x:=x div N;
   end;
   
   if x > 0 then begin
      str(x, c);
      s:=c+s;
   end;
   writeln('в системе счисления по основанию ', N, ' это число = ', s);
end.

вывод:

введите десятичное число: 14
в системе счисления по основанию 7 это число = 20

найти первый и второй положительный элемент массива

как с помощью цикла while найти первый и второй положительный элемент массива

const
   N = 10;

var
   a: array [1..N] of integer;
   i: integer;
   i1, i2: integer;

begin
   {init random}
   for i:=1 to N do a[i]:=random(100)-50;
   
   write('array: ');
   for i:=1 to N do write(a[i]:4);
   writeln;
   

   i1 := 0;
   i2 := 0;

   i := 1;
   while (i1 = 0) or (i2 = 0) do begin
      if a[i] > 0 then begin
         if i1 = 0 then begin
            i1 := i;
         end else begin
            if i2 = 0 then begin
               i2 := i;
            end;
         end
      end;
      inc(i);
      if (i > N) then begin
         break;
      end
   end;
   
   if i1 > 0 then begin
      writeln('first positive element: a[', i1, '] = ', a[i1]);
      if i2 > 0 then begin
          writeln('second positive element: a[', i2, '] = ', a[i2]);
      end else begin
          writeln('no second positive element');
      end;
   end else begin
      writeln('no positive element at all!');
   end;
   
end.

вывод

array:   45 -22 -15  32  -9   9  29   3 -26 -49
first positive element: a[1] = 45
second positive element: a[4] = 32

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

Написать программу, которая упорядочивает по убыванию ту часть последовательности, которая находиться до минимального элемента этой последовательности

const
   N = 10;

var
   a: array [1..N] of integer;
   i, j: integer;
   imin: integer;
   temp: integer;
   
begin
   {init random}
   for i:=1 to N do a[i]:=random(100);
   
   write('before: ');
   for i:=1 to N do write(a[i]:3);
   writeln;
   
   imin := 1;

   for i:=2 to N do begin
      if a[i] < a[imin] then imin := i;
   end;
   
   writeln('min is a[', imin, '] = ', a[imin]);
   
   for i:=1 to imin-2 do begin
      for j:=i+1 to imin-1 do begin
         if a[i] < a[j] then begin
            temp:=a[i];
            a[i]:=a[j];
            a[j]:=temp;
         end;
      end;
   end;

   write('after: ');
   for i:=1 to N do begin
      if i = imin then write('[');
      write(a[i]:3);
      if i = imin then write(']');
   end;
   writeln;

   
end.

вывод

before:  48 63  9 75  2 98 28 13  5 10
min is a[5] = 2
after:  75 63 48  9[  2] 98 28 13  5 10

функция рисования треугольника

функция рисования треугольника

program triangle;

Uses GraphABC;

procedure drawTriangle(x1, y1, x2, y2, x3, y3: integer);
begin
     moveto(x1, y1);
     lineto(x2, y2);
     lineto(x3, y3);
     lineto(x1, y1);
end;

begin
     drawTriangle(10, 10, 20, 100, 100, 40);
end.

сумма и произведение элементов в массиве

Дано N вещественных чисел. a1,a2....an. Вывести сумму и произведение чисел из данного набора. Использовать структуру цикл с постусловием.

program one;

const
     N = 5;

var
   A: array [1..N] of integer;
   i: integer;
   sum: integer;
   mul: integer;

begin
   writeln('инициализация массива случайными числами');
   for i:=1 to N do begin
       A[i]:=random(9)+1; {числа от 1 до 9, т.е. неравные 0, иначе произведение будет равно 0}
       writeln(A[i]);
   end;
   
   {начальное значение суммы}
   sum:=0;
   {начальное значение произведения}
   mul:=1;
   {начальный номер элемента}
   i:=1;
   
   repeat
       sum:=sum+A[i];
       mul:=mul*A[i];
       i:=i+1;
   until i > N;
   
   writeln('sum=', sum);
   writeln('mul=', mul);

end.

число из Двоичной системы счисления в десятичную

Помогите написать программы на паскале которые переводит число из Двоичной системы счисления в десятичную

FUNCTION BIN2DEC(BIN: STRING): LONGINT;

VAR
J    : LONGINT;
Error: BOOLEAN;
DEC  : LONGINT;

BEGIN
DEC := 0;
Error := False;
FOR J := 1 TO Length(BIN) DO
BEGIN
IF (BIN[J] <>'0') AND (BIN[J] <>'1') THEN Error := True;
IF BIN[J] = '1' THEN DEC := DEC + (1 SHL (Length(BIN) - J));
{ (1 SHL (Length(BIN) - J)) = 2^(Length(BIN)- J) }
END;
IF Error THEN BIN2DEC := 0
ELSE BIN2DEC := DEC;
END;

Функции перевода из одной системы счисления в другую

Тут собвственно и добавлять нечего. Качественный материал.

Функции перевода из одной системы счисления в другую

найти номера строк, элементы в каждой из которых одинаковы между собой

дан двумерный квадратный массив. найти номера строк, элементы в каждой из которых одинаковы между собой.

основная заковырка тут в том что такие

1 2 3

3 1 2

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

1 1 2

2 1 1

это тоже одинаковые строки...

для этого я ввожу в программу вспомогательный массив флагов, в котором отмечаю уже найденые элементы....

смотрим и разбираемся....

const
   N = 4;

var
   a: array [1..N, 1..N] of integer;
   b: array [1..N] of boolean; {вспомогательный массив флагов}
   i, j, k, m: integer;
   f1, f2: boolean;

begin
   {инициализация массива случайными числами}
   for i:=1 to N do begin
      for j:=1 to N do begin
         a[i,j]:=random(3);
      end;
   end;
   
   {печать массива на экран}
   for i:=1 to N do begin
      for j:=1 to N do begin
         write(a[i, j]:2);
      end;
      writeln;
   end;
   writeln;
   
   {ищем совпадения по строчно}
   for i:=1 to N do begin
      write('строка ', i, ': ');

      for j:=1 to N do begin
         {саму с собой не проверяем}
         if i = j then continue;
         
         {сбросим вспомогательный массив флагов}
         for k:=1 to N do begin
            b[k]:=false;
         end;

         f1:=true; {предположим i-я строка равна j-й}
         for k:=1 to N do begin
            f2:=false; {предположим k-й элемент i-той строки есть в j-й строке }
            for m:=1 to N do begin
               if (a[i, k] = a[j, m]) and (b[m] = false) then begin
                  b[m]:=true; {таки есть, отметим это флагом}
                  f2:=true; {и переходим к след. символу}
                  break;
               end;
            end;
            
            if not f2 then begin {символ не найден!}
               f1:=false; {строки не равны!}
               break;
            end;
         end;

         if f1 = true then begin {строки равны}
            write(j:2); {отметим этот факт выводом на экран}
         end;
      end;
      writeln;
   end;
   writeln;
end.

исходники скачиваем тут

найти для каждой строки число элементов,кратных 5

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

const
   N = 10;
   M = 20;

var
   a: array [1..N, 1..M] of integer;
   b: array [1..N] of integer;
   
   i: integer;
   j: integer;
   sum: integer;
   max: integer;

begin
   {инициализируем массив случайными числами}
   for i:=1 to N do begin
      for j:=1 to M do begin
         a[i, j]:=random(100);
      end;
   end;
   
   {выведем его на экран}
   for i:=1 to N do begin
      for j:=1 to M do begin
         write(a[i, j]:3);
      end;
      writeln;
   end;
   writeln;
   
   sum:=0; {начальная инициализация суммы}
   write('кол-во элементов кратных пяти: ');
   for i:=1 to N do begin
      {находим кол-во элементов кратных 5}
      b[i]:=0;
      for j:=1 to M do begin
         if a[i, j] mod 5 = 0 then begin
             b[i]:=b[i]+1;
         end;
      end;
      write(b[i]:3); {вывод на экран}
   end;
   writeln;
   
   max:=b[1];
   for i:=2 to N do begin
      if b[i] > max then begin
         max:=b[i];
      end;
   end;
   
   writeln('максимальное из них = ', max);
end.

тут можно скачать оригинал

найдите сумму наибольших значений элементов

дан двумерный массив. найдите сумму наибольших значений элементов его строк

const
   N = 10;
   M = 20;

var
   a: array [1..N, 1..M] of integer;
   i: integer;
   j: integer;
   sum: integer;
   max: integer;
begin
   {инициализируем массив случайными числами}
   for i:=1 to N do begin
      for j:=1 to M do begin
         a[i, j]:=random(100);
      end;
   end;
   
   {выведем его на экран}
   for i:=1 to N do begin
      for j:=1 to M do begin
         write(a[i, j]:3);
      end;
      writeln;
   end;
   writeln;
   
   sum:=0; {начальная инициализация суммы}
   write('max: ');
   for i:=1 to N do begin
      {находим максимальное значение в строке}
      max:=a[i, 1];
      for j:=2 to M do begin
         if a[i, j] > max then begin
            max:=a[i, j];
         end;
      end;
      write(max:3); {вывод на экран}
      sum:=sum+max; {накапливаем сумму}
   end;
   writeln;
   
   writeln('сумма максимальных элементов строк = ', sum);
end.

тут можно скачать отформатированную версию исходников

задача 13

В последовательности А из N элементов каждую группу из рядом стоящих нулей заменить одним нулем . Среди отрезков последовательности , заключенных между парами оставшихся нулей , найти два: с минимальным и максимальным числом элементов. Если оба искомых отрезка существуют, то преобразовать массив так, чтобы между нулями, ограничивающими первый отрезок, оказались элементы второго отрезка , а между нулями, ограничивающими второй отрезок - элементы первого, сохранив порядок следования .
В противном случае в массиве А изменить порядок следования элементов на обратный. Преобразованный массив А выдать на дисплей в строку.

последовательность A из N элементов это

const
    N = 50;

var
    A: array [1..N] of integer;

отмечу лишь некоторые ключевые моменты, как-то замена рядомстоящих нулей на один

   m:=1; {новый размер массива}
   f:=false; {признак повторяющихся нулей}
   for i:=1 to N do begin
      if A[i] = 0 then begin {если это ноль}
         if f then begin {и до этого был ноль}
            {ничего не делаем - идём дальше}
         end else begin {до этого был НЕ ноль}
            f:=true; {выставляем признак начала нулей}
            A[m]:=A[i]; {один из них оставляем}
            m:=m+1;
         end;
      end else begin {это НЕ ноль}
         f:=false; {сбрасываем признак нуля}
         A[m]:=A[i]; {заполняем массив}
         m:=m+1;
      end;
   end;

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

      for i:=1 to m do begin
         temp:=A[1];
         for j:=1 to m-i do begin
            A[j]:=A[j+1];
         end;
         A[m-i+1]:=temp;
      end;

полный вариант программы тут

основные операции с файлами

Составить программу для обработки текстового файла:
1)считывание текста из текстового файла,
2)добавление в него текста,
3)переименование файла,
4) копирование файла,
5) удаление файла


вот тело программы

   {прочитаем построчно}
   assign(f, 'file');  { associate it }
   reset(f);         { open it      }
   while not eof(f) do  { read it until it's done }
   begin
     readln(f, s);
     writeln(s);
   end;
   close(f);
   
   {допишем}
   append(f);
   writeln(f, 'new stroka');
   close(f);
   
   {переименуем}
   rename(f, 'new_file');
   
   {удалим}
   erase(f);

тут можно скачать полную версию