Интересные задачи и их решения
   
Геометрия на плоскости: "Роза ветров"
  Программа - конструктор тестов
Определение типа треугольника (остроугольный, тупоугольный, прямоугольный) "Звездное небо"
Определение принадлежности точки к многоугольнику Новогодняя елка + снегопад
   
  Решение уравнений различных степеней
  Построение таблицы истинности логического выражения
   


Задача: На плоскости координатами своих вершин задан треугольник. Определить, к какому типу он принадлежит (остро- , тупо- или прямоугольный)

Const
  eps = 10E-5;

{
  Поскольку в стандартной библиотеке Паскаля функция вычисления арккосинуса
  отсутствует, пишем ее самостоятельно ...
}
Function ArcCos(X: Double): Double;
Begin
  If abs(X) < eps Then arccos := Pi / 2
  Else
    arccos := ArcTan(Sqrt(1 - Sqr(X)) / X) + Pi * Byte(X < 0);
End;

Type
  { Структура для хранения координат X, Y точки }
  Point = Record
    X, Y: double;
  End;

Const
  { Переменная для хранения признака того, что один из углов треугольника - прямой ... }
  is90: Boolean = False;

{
  Процедура, запрашивающая у пользователя ввод координат X и Y определенной точки,
  и возвращающая эту точку через Var-параметр...
}
Procedure GetCoord(Const s: string; Var P: Point);
Begin
  WriteLn('Point ' + s);
  Write('X = '); ReadLn(P.X);
  Write('Y = '); ReadLn(P.Y);
End;

{
  Функция для определения расстояния между двумя точками ...
  (Зачем нужен Var-параметр dist - см. комментарии после программы)
}
Function GetDist(Var dist: Double; pA, pB: Point): Double;
Begin
  dist := Sqrt(Sqr(pA.X - pB.X) + Sqr(pA.Y - pB.Y));
  GetDist := dist;
End;

{
  Функция, возвращающая угол (в градусах !!!) между двумя сторонами
  треугольника, вычисленный из формулы теоремы косинусов
}
Function Angle(A, B, C: Double): Double;
Var value: Double;
begin
  Value := ArcCos((Sqr(A) + Sqr(B) - Sqr(C)) / (2 * A * B)) * (180 / Pi);
  If Abs(value - 90) < eps Then is90 := True;

  Angle := value;
End;

Var
  {
    Переменные для хранения вершин треугольника
  }
  pA, pB, pC: Point;
  
  {
    Длины сторон треугольника:
    A - длина стороны AB;
    B - длина стороны BC;
    C - длина стороны AC;
  }
  A, B, C: double;
  
  {
    Углы треугольника:
    alpha - угол между AC и BC (противолежит AB)
    beta  - угол между AB и AC (противолежит BC)
    gamma - угол между AB и BC (противолежит AC)
  }
  alpha, beta, gamma: double;
begin
  {
    Получаем координаты вершин треугольника
  }
  GetCoord('A', pA);
  GetCoord('B', pB);
  GetCoord('C', pC);

  {
    Вычисляем все углы в заданном треугольнике
  }
  alpha := Angle(
             GetDist(B, pB, pC),
             GetDist(C, pA, pC),
             GetDist(A, pA, pB)
           );
  beta := Angle(A, C, B);
  gamma := Angle(A, B, C);

  {
    И по вычисленным углам делаем вывод о том,
    является ли данный треугольник остро- , тупо- или прямоугольным
  }
  If is90 Then WriteLn('Прямоугольный')
  Else
    If (alpha < 90) and (beta < 90) and (gamma < 90) then WriteLn('Остроугольный')
    Else
      If (alpha > 90) or (beta > 90) or (gamma > 90) then WriteLn('Тупоугольный')
end.
А теперь немного о том, зачем в функции GetDist понадобился еще один параметр...

Можно было бы, конечно, обойтись и без него, но тогда пришлось бы сначала вычислять длины всех сторон, и только потом подставлять эти значения в функцию вычисления углов:
  ...
  A := GetDist(pA, pB);
  B := GetDist(pB, pC);
  C := GetDist(pA, pC);
  
  alpha := Angle(B, C, A);
  beta := Angle(A, C, B);
  gamma := Angle(A, B, C);
  ...
Введением же одного дополнительного параметра я добился того, что одновременно с вычислением всех длин сторон найденные значения подставляются в первый вызов функции Angle (получилось нечто вроде C-шного:
  alpha = Angle(
            (B = GetDist(pB, pC)),
            (C = GetDist(pA, pC)),
            (A = GetDist(pA, pB))
          );
, только средствами Паскаля. Иногда это действительно удобно)



Задача: Определение принадлежности точки к многоугольнику

Ниже приведено простое решение проблемы, часто встречающейся в компьютерной графике, определение, лежит ли точка (x,y) внутри или снаружи двумерного многоугольника. В частности, это может быть необходимо в задачах определяющих пересечение нескольких полигонов.

Будем считать, что многоугольник состоит из N вершин (xi, yi) где i изменяется от 0 до N-1. Последняя вершина (xN,yN) считается равной первой вершине (x0,y0), то есть, многоугольник замкнут. Для того, чтобы определить положение точки (xp,yp), представим горизонтельный луч, выходящий из (xp,yp), и уходящий вправо. Если количество пересечений этого луча с отрезками, формирующими многоугольник, является четным, то точка лежит вне многоугольника. Если же число пересечений нечетно, то точка (xp,yp) лежит внутри многоугольника. См. рисунок:

Рис. 1

Подобная техника работает также для "дырявых" многоугольников, таких как на нижеприведенном рисунке:

Рис. 2

Внимание: на границе многоугольника значение функции не определено!
Uses Crt;

Function min(a, b: Double): Double;
Begin
  min := a;
  If b < a Then min := b;
End;

Function max(a, b: Double): Double;
Begin
  max := a;
  If b > a Then max := b;
End;

{
  Структура, описываюшая тип точки
}
Type
  Point = Record
    x, y: Double;
  End;


Function InsidePolygon(Var polygon: Array Of Point;
         Const n: Integer; p: Point): Boolean;
Var
  i, counter: Integer;
  xinters   : Double;
  p1, p2    : Point;
Begin
  counter := 0;

  p1 := polygon[0];
  For i := 1 To n Do Begin

    p2 := polygon[i mod n];
    If p.y > min(p1.y, p2.y) Then Begin

      If p.y <= max(p1.y, p2.y) Then Begin
        If p.x <= max(p1.x, p2.x) Then Begin
          If p1.y <> p2.y Then Begin

            xInters := (p.y - p1.y)*(p2.x - p1.x) / (p2.y-p1.y) + p1.x;
            If (p1.x = p2.x) or (p.x <= xInters) Then Inc(counter);

          End;
        End;
      End;

    End;
    p1 := p2;
  End;

  If (counter mod 2) = 0 Then InsidePolygon := False
  Else InsidePolygon := True;
End;

Const
  { Максимально возможное количество вершин полигона }
  maxPoints = 24;
  
Var
  P   : Point;                    { Проверяемая точка }
  Poly: Array[0 .. 24] of Point;  { Массив вершин многоугольника }

{
  Функция ввода данных (возвращает количество точек, образующих полигон)
  Внимание !!! Порядок ввода точек, образующих многоугольник - против часовой стрелки...
}
Function EnterData: Integer;
Var
  i, count: integer;
Begin
  Write('Enter poly`s vertex number: '); ReadLn(count);
  For i := 0 To Pred(count) Do Begin

    Write('X[',i,']: '); ReadLn(Poly[i].x);
    Write('Y[',i,']: '); ReadLn(Poly[i].y);

  End;
  WriteLn;

  Write('Point X: '); ReadLn(P.x);
  Write('Point Y: '); ReadLn(P.y);
End;


Var
  count: Integer;  { Количество точек в многоугольнике }

Begin
  ClrScr;

  count := EnterData;
  WriteLn;

  If InsidePolygon(Poly, count, P) Then
    WriteLn('Точка внутри многоугольника')
  Else
    WriteLn('Точка ВНЕ многоугольника');

  ReadLn;
End.


Задача: В строке данных записаны 30 чисел от 1 до 8, показывающих, в каком направлении дул ветер в соответствующий день месяца (1-северный, 2-северо-восточный, 3-восточный, 4-юго-воточный, 5 южный, 6-юго-западный, 7-западный, 8-северо-западный).

Вывести на экран “розу ветров” - многоугольник, вершинами которого лежат на 8-лучах, выходящих из общего центра с равным углами, расстояния от вершины до этого центра пропорционально дней месяца, в который дул соответствующий ветер.


Для отображения результата данной задачи идеально подходит полярная система координат: лучи выходят из общего центра, на них нужно откладывать расстояние, пропорциональное количеству... неважно чего, главное - что на них...

Вот как решается данная задача (есть вопросы по решению - задаем сюда: Форум "Интересные задачи для программистов"):

uses graph;

type
  Dir = (
    E, NE, N, NW, W, SW, S, SE
  );
  arrType = array[Dir] of integer;
const
  titles: array[Dir] of string = (
    'E', 'NE', 'N', 'NW', 'W', 'SW', 'S', 'SE'
  );

  start  = ord(low(Dir));
  finish = ord(high(dir));
  amount = finish - start + 1;

  sector = (360 div amount) * (Pi / 180);


function read_data(var arr: arrType): integer;
var
  i, X, max: integer;
  ix: Dir;
begin
  for ix := low(Dir) to
      high(Dir) do arr[ix] := 0;

  for i := 1 to 30 do begin
    read(X);

    if X <= 3 then X := 4 - X else X := 12 - X;
    inc(arr[Dir(pred(X))]);
  end;

  max := 0;
  for ix := low(Dir) to high(Dir) do
    if arr[ix] > max then max := arr[ix];

  read_data := max;
  readln;
end;

var
  center_x, center_y: integer;
const
  mult = 20;

function get_x(r, phi: real): integer;
begin
  get_x := center_x + trunc(mult * r * cos(phi));
end;
function get_y(r, phi: real): integer;
begin
  get_y := center_y - trunc(mult * r * sin(phi));
end;

procedure line_polar(phi_st, r_st, phi_fn, r_fn: real);
begin
  line(
    get_x(r_st, phi_st), get_y(r_st, phi_st),
    get_x(r_fn, phi_fn), get_y(r_fn, phi_fn)
  );
end;
procedure text_polar(phi, r: real; const T: string);
begin
  outtextxy(
    get_x(r, phi), get_y(r, phi), T
  );
end;
procedure circle_polar(phi, r: real; radius: integer);
begin
  circle(
    get_x(r, phi), get_y(r, phi), mult * radius
  );
end;



var
  arr: arrType;
  i, j,
  max_val: integer;

  {
    Это - только для того, чтобы программа запускалась как на Турбо, так и на Free-Паскале...
  }
  gDriver, gMode, errCode:
    {$ifdef FPC}
      smallint
    {$else}
      integer
    {$endif}
  ;

begin
  max_val := read_data(arr);

  initgraph(gDriver, gMode, '');
  errCode := graphresult;
  if errCode <> grOk then begin
    writeln('error: ', grapherrormsg(errCode));
    readln; halt(100);
  end;

  center_x := getmaxx div 2;
  center_y := getmaxy div 2;

  for i := start to finish do begin
    setcolor(white);
    line_polar(0, 0, i * sector, 10);
    text_polar(i * sector, 11, titles[Dir(i)]);

    if i = finish then j := start else j := i + 1;
    setcolor(red);
    line_polar(i * sector, arr[Dir(i)], j * sector, arr[Dir(j)])
  end;

  setcolor(darkgray);
  for i := 1 to max_val do
    circle_polar(0, 0, i);

  readln;
  closegraph;
end.
После компиляции и запуска этой программы вводим массив чисел (я вводил такой:
1 2 3 4 5 6 7 8 1 2 2 2 2 3 4 5 5 4 2 6 5 5 3 4 7 1 1 2 3 4
), получаем вот такую "Розу ветров" (нажмите на картинку для ее увеличения):




Задача: Написание программы для создания и проведения тестов.

Программа должна уметь работать с вопросами нескольких типов:

  1. Непосредственный ввод.
    Пример вопроса: Автор произведения "Война и мир"
    Варианты ответов:
    Толстой.
    Л.Н. Толстой
    Толстой Л.Н.

    (Все 3 ответа верны)

  2. Один правильный из нескольких.
    Пример вопроса: Автор произведения "Война и мир"
    Варианты ответов:
    1) Пушкин
    2) Лермонтов
    3) Толстой
    4) Карамзин

    Правильный ответ: 3) Толстой

  3. Несколько правильных ответов из нескольких вариантов
    Пример вопроса: Столицей какого государства является Лондон?
    Варианты ответов:
    1) Англия
    2) Великобритания
    3) Польша
    4) Россия

    Правильные ответы: 1) и 2)

  4. Вопрос на соответствие.
    Пример вопроса: Составить соответствие (Cтрана - Cтолица):
    1) Англия - 1) Москва
    2) Украина - 2) Киев
    3) Россия - 3) Лондон

    Правильный ответ: 1-3, 2-2, 3-1

  5. Вопросы на сортировку
    Пример задания: Расположите события в хронологической последовательности (от самого раннего к более позднему):
    1) Война с Наполеоном
    2) Великая Отечественная Война
    3) "Ледовое побоище"

    Правильный ответ: 3, 1, 2

Для решения этой задачи я ввел тип - запись с вариантами (для хранения данных о каждом вопросе):
{ максимально возможное количество ответов на вопрос ... }
const
  max_answers = 10;

type
  { здесь описываем 5 типов ответов, каждый из них будет обрабатываться по-своему }
  QuestType = (ans1, ans2, ans3, ans4, ans5);
  { промежуточная структура, для хранения соответствий между двумя вариантами - для 4-го типа }
  TS = record
    first, second: integer;
  end;

  { это - сама запись с вариантами... }
  TTest = record
    quest: string[50];
    ans_count: 0 .. max_answers;
    answers: array[1 .. max_answers] of string[50];

    case qType: QuestType of
      ans1: (
        good_ans1: string[50];
            );
      ans2: (
        good_ans2: integer;
            );
      ans3: (
        good_count3: 1 .. max_answers;
        good_ans3: array[1 .. max_answers] of integer;
            );
      ans4: (
        good_count4: 0 .. max_answers;
        good_ans4: array[1 .. max_answers] of TS;
            );
      ans5: (
        good_ans5: array[1 .. max_answers] of integer;
            );
  end;
Основная сложность возникает при обработке первого типа вопросов: как заставить программу понимать, что и "Л. Н. Толстой" и "Лев Толстой", и даже "Толстой Л. Н." являются правильными ответами.

Мной был предложен следующий способ:

Будем задавать список слов, которые должны быть в ответе (назовем это шаблоном ответа), и потом каждое слово из введенного пользователем ответа проверять на присутствие в шаблоне... Например, для приведенного выше варианта:

Шаблонный ответ: "Толстой Лев Л. Н."

тогда, если отвечающий введет, например, "Лев Толстой" - то проверяем: отдельно Лев присутствует в строке-шаблоне. Отдельно Толстой тоже присутствует. Следовательно, ответ признается правильным... Точно такой же результат будет, если введут "Л. Толстой" и если "Л. Н. Толстой" - все эти варианты будут признаны правильными, поскольку из 2-х или 3-х слов ответа нет ни одного НЕсовпадения с шаблоном...

Теперь приведу программу, решающую поставленную задачу...

(все вопросы по программе можно задать вот на этом форуме: Форум "Интересные задачи для программистов")
{
	Тип данных для разбиения строки на слова
}
type
	TWordStr = string[100];
	TDelimiter = set of Char;

	PTItem = ^TItem;
	TItem = record
		Data: TWordStr;
		next: PTItem;
	end;
	TWordList = record
		first, last: PTItem;
	end;

{
	Процедура, помещающее очередное найденное слово в список
}
procedure InsertWord(var L: TWordList; s: string);
var p: PTItem;
begin
	New(p);
	p^.Data := s;
	p^.next := nil;

	if L.first = nil then L.first := p
	else L.last^.next := p;
	L.last := p
end;

{
	Собственно процедура разбиения на слова
}
function GetWords(s: string; var L: TWordList; delimiters: TDelimiter): Byte;
var i, p: Byte;
begin
	for i := 1 to Length(s) do
		if s[i] In delimiters then s[i] := #32;

	repeat
		p := Pos('  ', s);
		if p > 0 then Delete(s, p, 1)
	until p = 0;
	if s[1] = ' ' then Delete(s, 1, 1);
	if s[Length(s)] = ' ' then Delete(s, Length(s), 1);

	i := 0;
	repeat
		p := Pos(' ', s); Inc(i);
		if p > 0 then begin
			InsertWord(L, Copy(s, 1, Pred(p)));
			Delete(s, 1, p)
		end
		else InsertWord(L, s)
	until p = 0;
	GetWords := i
end;


const
	{ Максимально допустимое число ответов на вопрос }
	max_answers = 10;
		
type
	{ Типы вопросов - выделены в отдельное перечисление для структуризации программы }
	QuestType = (ans1, ans2, ans3, ans4, ans5);
	{ Тип - "пара значений", для вопросов 4-ой группы }
	TS = record
		first, second: integer;
	end;

	{ Запись с вариантами - основная структура, используемая в программе }
	TTest = record
		{ Сам вопрос, на который предстоит ответить тестируемому }
		quest: string[50];
		{ Количество вариантов ответа на вопрос }
		ans_count: 0 .. max_answers;
		{ Собственно, варианты ответа на вопрос }
		answers: array[1 .. max_answers] of string[50];

		case qType: QuestType of
			{ тип №1: непосредственный ввод - Храним шаблонную строку ответа }
			ans1: (
				good_ans1: string[50];
			);
			{
				тип №2: один правильный из нескольких.
				Храним индекс правильного ответа
			}
			ans2: (
				good_ans2: integer;
			);
			{
				тип №3: несколько правильных из нескольких.
				Храним массив индексов правильных ответов и их число
			}
			ans3: (
				good_count3: 0 .. max_answers;
				good_ans3: array[1 .. max_answers] of integer;
			);
			{
				тип №4: вопросы на соответствие.
				Храним массив правильных соответствий индексов
			}
			ans4: (
				good_count4: 1 .. max_answers;
				good_ans4: array[1 .. max_answers] of TS;
			);
			{
				тип №5: вопросы на сортировку.
				Храним индексы в правильно отсортированном виде
			}
			ans5: (
				good_ans5: array[1 .. max_answers] of integer;
			);
	end;
	
	{ Заодно описываем и тип файла для хранения подобных записей }
	TestFile = file of TTest;
	
const
	{ сообщения для пользователя - для разгрузки текста программы выделены в отдельный массив }
	msg: array[QuestType] of string = (
		'type #1 - enter the answer: ',
		'type #2 - enter the good answer index: ',
		'type #3 - enter the good answer index: ',
		'type #4 - enter the pairs (first - second): ',
		'type #5 - enter the good-sorted indexes: '
	);
	
{
	Процедура, запрашивающая у составителя теста вопрос, и заполняющая запись R
	всеми данными, необходимыми для правильной обработки ответа на него
}
procedure get_quest(var R: TTest);

	{
		Вспомогательная функция - получение от пользователя целого числа в заданном интервале
	}
	function get_integer(const title: string;
		range_start, range_finish: integer): integer;
	var X: integer;
	begin
		write(title + '[', range_start, ' .. ', range_finish, '] ');
		repeat
			readln(X);
		until (X >= range_start) and (X <= range_finish);
		get_integer := X;
	end;
	
var
	i, X: integer;
	
begin
	{ Для любого типа вопросов небоходимо ввести сам вопрос }
	write('question: '); readln(R.quest);
	{ Теперь запросим у составителя, какой тип у этого вопроса и приведем его к QuestType }
	R.qType := QuestType(get_integer('test', 1, 5) - 1);
	
	{ В зависимости от того, к какому типу относится вопрос, его обработка осуществляется по-разному }
	case R.qType of
		{ тип №1 - количество правильных ответов не нужно, вводится только шаблонный ответ }
		ans1:
		begin
			R.ans_count := 0;
			write(msg[ans1]); readln(R.good_ans1);
		end;
		
		{ Все остальные типы: запрашивается количество вариантов ответа, и затем - сами варианты }
		ans2 .. ans5:
		begin
			R.ans_count := get_integer('answers count', 1, max_answers);
	
			for i := 1 to R.ans_count do begin
				write('answer #', i:2, '':2); readln(R.answers[i]);
			end;
			
			{
				Запрос правильных ответов необходим только для этих типов вопросов,
				но не для первого, поэтому информационная строка печатается здесь,
				а не в основном теле процедуры
			}
			writeln('good answers:');
		end;
	end; { Case }
			
	{
		Теперь переходим ко вводу правильных ответов.
		Также в зависимости от выбранного типа вопроса
	}
	case R.qType of
		{ Тип №2: вводим один индекс правильного ответа }
		ans2:
		begin
			R.good_ans2 := get_integer(msg[ans2], 1, R.ans_count);
		end;
	
		{ Тип №3: вводим несколько (пока не будет введен 0) индексов правильных ответов }
		ans3:
		begin
			R.good_count3 := 0;
			i := 1;
			repeat
				X := get_integer(msg[ans3] + ' (0 to finish) ', 0, R.ans_count);
				{ Что-то было введено, кроме 0 - дописать это в массив ответов }
				if X <> 0 then begin
					R.good_ans3[i] := X;
					inc(R.good_count3);
					inc(i);
				end;
			until X = 0; { Ввели 0 - надо выходить из цикла }
		end;
				
		{ Тип №4: ввод пар соответствий }
		ans4:
		begin
			write(msg[ans4]);
			for i := 1 to R.ans_count do begin
				R.good_ans4[i].first := get_integer('first', 1, R.ans_count);
				R.good_ans4[i].second := get_integer('second', 1, R.ans_count);
			end;
		end;
			
		{ Тип №5: ввод правильно отсортированной последовательности индексов }
		ans5:
		begin
			write(msg[ans5]);
			for i := 1 to R.ans_count do begin
				write('will be #', i);
				R.good_ans5[i] := get_integer('', 1, R.ans_count);
			end;
		end;
	end; { Case }
end;

{
	Функция получает из основной программы структуру R с вопросом, прочитанную из файла,
	задает пользователю записанный в структуре вопрос, в соответствии с типом вопроса
	запрашивает ответ.

	Возвращает True в случае, если ответ совпадает с записанным в R; иначе возвращает False
}
function get_answer(const R: TTest): boolean;

	{
		Дополнительная процедура: вывод на экран всех вариантов ответа на вопрос
	}
	procedure print_options;
	var i: integer;
	begin
		for i := 1 to R.ans_count do begin
			write(i:2, ') ', R.answers[i] + ' ');
		end;
	end;
		
var
	{ Для типа №1 }
	s: string;
	L: TWordList;
	p: ptitem;
	count, positive, negative: integer;
		
	{ Для типа №2 }
	i, choice: integer;
		
	{ Для типа №4 }
	pair: TS;
	j: integer;

begin
	{ Вывод сообщения о типе вопроса, и самого текста вопроса }
	writeln(msg[R.qType]);
	writeln(R.quest);
	
	{ Обработка будет различной в зависимости от типа }
	case R.qType of
		{
			Тип №1: запрашваем у отвечающего строку, разбиваем ее на слова,
			и проверяем наличие каждого слова в шаблонной строке, хранящейся в R...
			Если число совпадений больше числа НЕсовпадений, то считаем ответ правильным
		}
		ans1:
		begin
			readln(s);
			L.first := nil;
			count := GetWords(s, L, [#32]);
			
			{ Начинаем проход по списку слов }
			p := L.first;
			positive := 0; negative := 0;
			while p <> nil do begin
				if pos(p^.Data, R.good_ans1) > 0 then inc(positive)
				else inc(negative);
				p := p^.next;
			end;
			get_answer := (positive > negative);
		end;
				
		{
			Тип №2: выводим варианты ответов, и запрашиваем ввод
			одного индекса. Если он совпадает с тем, что хранится в R
			как правильный, то ответ засчитывается, иначе - нет
		}
		ans2:
		begin
			print_options;
			writeln;
			write('your choice: '); readln(choice);
				
			get_answer := (choice = R.good_ans2);
		end;
				
		{
			Тип №3: Выводим варианты ответов, и запрашиваем ввод одного индекса.
			После чего проверяем, содержится ли он в массиве индексов, помеченных
			как правильные (R.good_ans3). Если да - ответ засчитывается
		}
		ans3:
		begin
			print_options;
			writeln;
			write('your choice: '); readln(choice);
			
			get_answer := false;
			for i := 1 to R.good_count3 do
				if choice = R.good_ans3[i] then get_answer := true;
		end;
				
		{
			Тип №4: Вывод вариантов ответов и запрос пользователю:
			"введи правильные соответствия между элементами первого
			и второго столбцов". Если в массиве правильных ответов содержатся
			ВСЕ такие же соответствия (причем в любой последовательности,
			порядок не важен) - то ответ засчитывается.
		}
		ans4:
		begin
			print_options;
			writeln;
			writeln('answer:');
				
			count := 0;
			for i := 1 to R.ans_count do begin
				write('C1) '); readln(pair.first);
				write('C2) '); readln(pair.second);
			
				for j := 1 to R.ans_count do begin
					if
					(R.good_ans4[j].first = pair.first) and
					(R.good_ans4[j].second = pair.second)
					then inc(count);
				end;
			end;
					
			get_answer := (count = R.ans_count);
		end;
					
		{
			Тип №5: выводим варианты ответа, и запрашиваем ввод индексов
			в правильном порядке. Если ВСЕ введенные индексы совпадают с
			соответствующими элементами массива правильных индексов,
			то ответ засчитывается
		}
		ans5:
		begin
			print_options;
			writeln;
			writeln('answer (sorted index array)');
			
			get_answer := true;
			for i := 1 to R.ans_count do begin
				write('-> '); readln(choice);
				if choice <> R.good_ans5[i] then get_answer := false;
			end;
		end;
	end; { Case }
end;

var
  Rec: TTest;
  F: TestFile;
  i, n: integer;
  b: boolean;

begin
  assign(F, 'quest.dat');
  {$i-}
    reset(F);
  {$i+}
  if ioResult <> 0 then begin

    rewrite(F);
    write('questions to enter: '); readln(n);
    for i := 1 to n do begin
      get_quest(Rec);
      write(F, Rec);
    end;
    reset(F);

  end
  else begin

    while not eof(F) do begin
      read(F, Rec);
      b := get_answer(Rec);
      writeln('result = ', b);
    end;

  end;
  close(F);

end.

"Звездное небо" (ООП-реализация):

Скачать программу можно отсюда: starf.rar


Новогодняя елка + снегопад (версия для FPC начиная с 2.2.0):



Скачать программу можно отсюда: elka_fpc.zip


Решение уравнений различных степеней:

Очень часто при решении задач необходимо находить корни уравнений различных порядков (квадратных, кубических и т.д.) Вместо того, чтобы писать свое решение этой задачи, можно воспользоваться функциями, которые содержатся в присоединенном модуле Equation:

Function solveQuadratic(Var x, y: Array Of Double): Byte;
Решение квадратного уравнения вида: x[0] * x[sup]2[/sup] + x[1] * x + x[2] = 0
Результат, возвращаемый функцией - количество действительных корней (cами корни возвращаются в y[0], y[1]).

Пример использования:
{$n+}
Uses Equation;
Const
  ax: Array[0 .. 2] Of Double =
		(24, -50, 25 );
Var
  ay: array[0 .. 2] Of Float;
  roots, i: Integer;

Begin
  roots := solveQuadratic(ax, ay);
  Writeln( 'number of roots = ', roots );
  For i := 0 To Pred(roots) Do
    WriteLn( 'root #', i + 1, ' = ', ay[ i ] :10 :5 );
End.


Function solveCubic(Var x, y: Array Of Double): Byte;
Решение кубического уравнения: x[0] * x[sup]3[/sup] + x[1] * x[sup]2[/sup] + x[2] * x + x[3] = 0
Результат, возвращаемый функцией - количество действительных корней (сами корни возвращаются в y[0], y[1], y[2]).

Пример использования:
{$n+}
Uses Equation;
Const
  ax: Array[0 .. 3] Of Float =
		(1, 0, -9, 4 );
Var
  ay: array[0 .. 3] Of Float;
  roots, i: Integer;

Begin
  roots := solveCubic(ax, ay);
  Writeln( 'number of roots = ', roots );
  For i := 0 To Pred(roots) Do
    WriteLn( 'root #', i + 1, ' = ', ay[ i ] :10 :5 );
End.


Для решения уравнений 4-ой степени применяются 2 функции
  1. Решение алгебраическим методом (метод Феррари)
    Function solveQuarticAlgebra(Var x, results: Array Of Double): Byte;
  2. Решение по методу Виета (предпочтительно)
    Function solveQuarticVieta(Var x, results: Array Of Double): Byte;
Также в модуль включена функция:
Function PolySolve(Const order: Integer;
         Var coeffs, roots: Array Of Double): Integer;
, позволяющая решать алгебраические уравнения практически любого порядка (порядок задается константой maxOrder, и изначально установлен равным 12) при помощи последовательности Штурма.

Пример использования (решение уравнения 4-ой степени сначала методом Vieta, а затем - методом Штурма):
{$n+}
Uses Equation;
Const
  Order = 4;
  coeffs: Array[0 .. Order] Of Double = (
	1, 0, -25, 60, -36
  );

Var
  roots: array[0 .. maxOrder] Of Double;
  nroots, i: Integer;

begin

  WriteLn('Vieta method :');
  nroots := solveQuarticVieta(coeffs, roots);
  { nroots := solveQuarticAlgebra(coeffs, roots); }
  Writeln( 'number of roots = ', nroots );
  For i := 0 To Pred(nroots) Do
	WriteLn( 'root #', i + 1, ' = ', roots[ i ] :7 :4 );

  WriteLn;

  WriteLn('Sturm sequence method :');
  nroots := PolySolve(Order, coeffs, roots);

  If nroots = 0 Then Begin
	WriteLn('solve: no real roots'); Halt(0)
  End
  Else Begin
	WriteLn(nroots, ' distinct real root(s) for x: ');
	For i := 0 To Pred(nroots) Do
	  WriteLn('root #', i + 1, ' = ', roots[ i ] :7 :4);
  End;

end.
Сам модуль можно взять здесь: equation.pas


Задача: Построить таблицу истинности логического выражения.

{
	Функция, переводящая десятичное число в другую систему счисления
}
function fromdec(n, radix: longint): string;
var s: string;
const
	digit: string[16] = '0123456789ABCDEF';
begin
	s := '';
	repeat
		s := digit[(n mod radix) + 1] + s;
		n := n div radix;
	until n = 0;
	while length(s) < 2 do s := '0' + s;
	fromdec := s;
end;

{
	Функция, дополняющая строку до длины N нулями спереди
}
function wide_to(s: string; n: integer): string;
begin
	while length(s) < n do s := '0' + s;
	wide_to := s;
end;

{
	Тестовые функции
}	
const
	{
		s: string = 'A*/B+/A*/C*/D+B*/C*D';
	}
	s: string = 'A*/B+/A*C';

var
	i, j, p, pp, vars_count: integer;
	ch: char;
	log_val, st, sub_s, params: string;
	b_sum, b_mult: boolean;
	
begin
	{ считаем количество переменных (vars_count) и заполняем список параметров (params) }
	vars_count := 0; params := '';
	for ch := 'A' to 'Z' do begin
		if pos(ch, s) > 0 then begin
			inc(vars_count);
			params := params + ch;
		end;
	end;
		
	{
		Для построения таблицы истинности нужно перебрать все возможные значения
		для всех параметров. Сделаем это простейшим способом: просто в цикле пройдем
		от  0 до (2^vars_count) - 1, эти числа в двоичной системе счисления  (дополненные
		нулями до vars_count цифр) как раз и будут представлять собой комбинации True/False
		на данной итерации цикла. Например:
		0 = 000 (все параметры = False )
		1 = 001 (gthdst 2 = False, третий = True)
		...
		7 = 111 (все параметры = True)
	}
	for i := 0 to pred(1 shl vars_count) do begin
		log_val := wide_to(fromdec(i, 2), vars_count); { <--- текущая комбинация }

		st := s + '+'; { Чтобы не портить исходную строку - работаем с копией }
		b_sum := false; { эта переменная предназначена для хранения СУММЫ логических произведений }
	
		repeat
			p := pos('+', st); { <--- Есть ли еще знак суммы, другими словами - есть ли группа конъюнкций? }
			if p > 0 then begin
				sub_s := copy(st, 1, pred(p)); { <--- Да... Выделяем ее в переменную sub_s }
				
				{
				переменная предназначена для вычисления значения текущего произведения,
				поэтому изначально равна True
				}
				b_mult := true;
			
				{ Перебираем все параметры, смотрим, есть ли какой-то из них в текущей группе }
				for j := 1 to length(params) do begin
					pp := pos(params[j], sub_s);
					if pp > 0 then begin { <--- Есть, pp хранит его позицию в строке }
						{
						далее возможны 2 варианта развития событий:
						1. параметр присутствует с отрицанием (для этого позиция должна быть
						БОЛЬШЕ 1, и предыдущим символом должен быть '/');
						2. Параметр присутствует без отрицания...
						}
						if (pp > 1) and (sub_s[pp - 1] = '/') then begin { <--- Есть отрицание? }
							{
							Да, текущее логическое значение устанавливается в ОТРИЦАНИЕ
							соответствующего	значения из текущей комбинации параметров
							}
							b_mult := b_mult and not(log_val[j] = '1');
						end
						else begin
							{ Нет, текущее значение берется без отрицания }
							b_mult := b_mult and (log_val[j] = '1');
						end;
					end;
				end;
				delete(st, 1, p); { <--- удаляем обработанную группу конъюнкций из строки }
				b_sum := b_sum or b_mult; { <--- дизъюнкция конъюнкций :) }
			end
		until p = 0; { повторять до тех пор, пока есть еще "+" в строке }
		
		{ выводим результат: для (такой-то комбинации) значение функции равно (тому-то) }
		writeln(log_val, ' = ', b_sum:5);
	end;

end.