Рекурсивная функцию letter(s), которая подсчитывает количество букв в строке s.

program abc;
uses crt;
const bk=['A'..'Z','a'..'z','А'..'я','ё','Ё'];
function letters(s:string;i:integer):integer;
var k:integer;
begin
if s[i] in bk then inc(k);
if i<length(s) then k:=k+letters(s,i+1);
letters:=k;
end;
var s:string;
begin
writeln('Введите строку:');
readln(s);
write('Количество букв=',letters(s,1))
end.

Другая реализация функции:

Function num_lett(s : string) : integer;
Var l : integer;
Begin
      l:=length(s);
      if l=0 then
         num_lett:=0
      else
         if s[1] in bk then
            num_lett:=1+num_lett(copy(s,2,l))
         else
            num_lett:=num_lett(copy(s,2,l));
End;

Дан одномерный массив целых чисел. Отсортировать его в порядке возрастания произведения цифр методом Шелла.

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66

uses crt; const nmax=100; type mas=array[0..nmax] of integer; procedure Vvod(var a:mas;var n:integer); var i:integer; begin repeat write('Размер массива от 5 до ',nmax,' n='); readln(n); until (n>4)and(n<=nmax); for i:=1 to n do a[i]:=random(1000); end; procedure Vyvod(a:mas;n:integer); var i:integer; begin for i:=1 to n do write(a[i]:4); writeln; end; function Prz(n:integer):integer; var m,p:integer; begin m:=n; p:=1; while m>0 do begin p:=p*(m mod 10); m:=m div 10; end; Prz:=p end; procedure Shell(var a:mas; n:integer); const b:array[1..5] of byte = (9,5,3,2,1); var i,j,k,x,t:integer; begin for k:=1 to 5 do begin x:=b[k]; for i:=x to n do begin t:=a[i]; j:=i-x; while (Prz(t)<Prz(a[j])) and (j>=x) do begin a[j+x]:=a[j]; j:=j-x; end; a[j+x]:=t; end; end; end; var a:mas; n:integer; w:char; begin randomize; clrscr; Vvod(a,n); writeln('Исходный массив:'); Vyvod(a,n); Shell(a,n); writeln('Отсортированный массив:'); Vyvod(a,n); readln end.

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

http://www.cyberforum.ru/post3913127.html 

program _array;
 
const
 
  N=20;
  
type
 
 TArray=Array [1..N] of integer;
 
var
 
 
  Mas:TArray;
  count,i:integer;
  
  
  
Procedure fillArray(var aMas:TArray;Maxval:integer);
 var
  i:integer;
begin
 for i:=1 to N           do begin
                            aMas[i]:=random(Maxval);
                            write(aMas[i],' ');
                            end;
end;
 
function FindMatch(var aMas:Tarray;index:integer):integer;
 var
  i,count:integer;
begin
 count:=0;
 for i:=1 to N do
 if mas[i]=mas[index] then inc(count);
 FindMatch:=count;
end;
 
Begin
{ fill array }
 Writeln('Сформирован массив: ');
 randomize;
 FillArray(Mas,100);
 
{ process. & output  }
 count:=0;
 for i:=1 to N do
 if findmatch(mas,i)>count 
 then count:=findmatch(mas,i);
 writeln();
 Writeln('максимальное количество одинаковых элементов: ',count);
End.

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

Дан двумерный массив A(n×m) . Найти среднее арифметическое отрицательных элементов в последней строке матрицы.

uses crt;
const n=15;
m=10;
var
  a: array [1..n,1..m] of integer;
  i,j,k: integer;
  s:real;
begin
write ('Сам массив А');
writeln;
for i:=1 to n do
for j:=1 to m do
a[i,j]:=random(100)-40;
for i:=1 to n do
begin
for j:=1 to m do
begin
write (a[i,j]:4);
end;
writeln;
end;
for i:=n to n do
for j:=1 to m do
if a[i,j]<0 then begin
s:=s+a[i,j];
k:=K+1;
end;
s:=s/k;
writeln('Среднее арифметическое отрицательных элементов в последней строке матрицы = ',s:0:1);
end.

Источник

Структура STUDENT. Pascal

Структура STUDENT содержит следующие поля:
- фамилия и инициалы;
- номер группы;
- успеваемость (массив из пяти элементов).
Выполнить следующие действия:
- вывод на дисплей фамилий и номеров групп тех студен-тов, средний балл успеваемости которых больше 4.0;
- если таких студентов нет, вывести соответствующее сообщение.

uses crt;
 
const 
  nmax = 10;
 
type Student = record
  Name : string[25];
  Number : integer;
  Marks : array [1..5] of integer;
  end;
 
var
  S : array [1..nmax] of Student;
  i, j, n : integer;
  sum : real;
  flag : boolean;
  
begin
repeat
Write('Количество студентов: ');
Readln(n);
until n in [1..nmax];
for i := 1 to n do
  begin
  Writeln('Информация о ', i, ' студенте');
  Write('Фамилия и инициалы: '); Readln(S[i].Name);
  Write('Номер группы: '); Readln(S[i].Number);
  for j := 1 to 5 do
    begin
    Write('Успеваемость по ', j, ' предмету: ');
    Readln(S[i].Marks[j]);
    end;
  end;
flag := false;  
for i := 1 to n do
  begin
  sum := 0;
  for j := 1 to 5 do
    sum := sum + S[i].Marks[j];
  Sum := Sum/5;
  if Sum > 4.0 then 
    begin
    Writeln(' Фамилия студента: ', S[i].Name, '. Номер группы: ', S[i].Number);
    flag := true;
    end;
  end;
if flag = false then Writeln('Таких студентов нет!');  
end.

Источник

Программа нахождения следующего за данным совершенного числа

Программа нахождения следующего за данным совершенного числа. Совершенным называется число, сумма делителей которого, не считая самого числа равна этому числу. Первое совершенное число 6 (6=1+2+3).

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60

function is_perfect(n : longint) : boolean; var s : longint; divider : Integer; begin s := 1; for divider := 2 to trunc(sqrt(n)) do if n mod divider = 0 then s := s + divider + (n div divider); is_perfect := (n = s); end; function get_candidate(len : integer) : longint; var s : string; i : integer; value : longint; begin s := ''; for i := 1 to len do s := '1' + s + '0'; s := '1' + s; value := 0; for i := 1 to length(s) do value := 2 * value + (ord(s[i]) - ord('0')); get_candidate := value; end; function to_bin(n : longint) : string; var s : string; const digit: string[2]='01'; begin s := ''; repeat s := digit[(n mod 2) + 1] + s; n := n div 2; until n = 0; to_bin := s; end; var found : boolean; bin : integer; bin_s : string; check : LongInt; n : longint; begin { n := 496; } write('perfect number: '); readln(n); bin_s := to_bin(n); bin := (length(bin_s) - 1) div 2; repeat inc(bin); check := get_candidate(bin); found := is_perfect(check); until found; writeln('next perfect number = ', check); end.

Источник

Напечатать все четырехзначные натуральные числа,в десятичной записи которых нет двух одинаковых цифр

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16

Var i,j,n:longint; mn:set of byte; Begin For i:=1000 to 9999 do Begin j:=0;n:=i;mn:=[]; While n>0 do Begin if n mod 10 in mn then j:=1; mn:=mn+[n mod 10 ]; n:=n div 10; End; if j=0 then writeln(i); End; readln; End.

Сформировать матрицу

Написать программу, которая формирует матрицу в следующем виде:

1 1 1 1
1 2 2 2
1 2 n-1 n-1
1 2 n-1 n

Принцип построения матрицы - в ячейку ставится число, равное наименьшему индексу ячейки.
т.е. если ячейка [1,2] - ставится 1, ячейка [2,3] ставится 2, [3,1] ставится 1 и т.д.

{Написать программу, которая формирует матрицу в следующем виде:

1 1 1   1
1 2 2   2
1 2 n-1 n-1
1 2 n-1 n

Принцип построения матрицы - в ячейку ставится число, равное наименьшему индексу ячейки.
т.е. если ячейка [1,2] - ставится 1, ячейка [2,3]  ставится 2, [3,1] ставится 1 и т.д.
}

program p6;

var a: array[1..100,1..100] of integer; {раздел описания переменных, регистрация массива a}
       i, j, k, n: integer; {регистрация переменных i, j, k, n}

begin
writeln('Программа формирует матрицу определенного вида размерностью n x n') ;
  write('n='); {вывод на экран: n= }
  readln(n); {чтение введенного значения в переменную n}

  {формирование матрицы}
  for i:=1 to n do
   for j:=1 to n do
    begin
     if i<j then a[i,j]:=i else a[i,j]:=j;
    end;
    
    {вывод результата}
    
      for i:=1 to n do {цикл по строчкам}
        begin {цикл по столбикам}
              for j:=1 to n do {цикл по столбикам}
               write(a[i,j]:4); {форматный вывод элемента массива на экран}
        writeln; {перевод курсора в начало следующей строки}
       end; {конец составного оператора}

    


end.

http://pastie.org/1654606