Автомат получат на вход четырехзначное число, в котором есть четные и нечетные цифры. строиться новое десятичное число по правилам: 1. вычисляются два числа- сумма четных цифр и сумма нечетных цифр заданного числа. 2. полученные два числа записываются друг за другом в порядке неубывания 217, 1913, 1021, 1218, 1812 105, 421, 291, 112

Последнее проверяемое число 7FF, поскольку большее число при удвоении будет четырехзначным, нарушая условие задания.

procedure Analyze(n: integer; var sd: integer; var has2: boolean);
{Для заданного целого n возвращает:
  sd - сумму цифр в шестнадцатиричном представлении;
  has2 - true, если среди шестнадцитиричных цифр имеется хотя бы одна двойка.}
const
  mask = $00F;

var
  i, r: integer;

begin
  has2 := false;
  sd := 0;
  for i := 1 to 3 do
  begin
    r := (n and mask);
    has2 := (has2 or (r = 2));
    sd := sd + r;
    n := (n shr 4);
  end
end;

function IsSuitable(n: integer): Boolean;
{Проверяет, удовлетворяет ли число n набору условий}

var
  s1, s2: integer;
  has2, stub: boolean;

begin
  Analyze(n, s1, has2);
  Analyze(2 * n, s2, stub);
  IsSuitable := ((s1 = s2) and has2)
end;

var
  i, n: integer;

begin
  n := 0;
  for i := $100 to $7FF do
    if IsSuitable(i) then n := n + 1;
  Writeln('Найдено чисел- ', n)
end.

Результат выполнения программы:
Найдено чисел- 23

Procedure SqRoot(a, b, c: real; var x1, x2: real; var nroots: integer);
{Корни квадратного уравнения с коэффициентами a,b,c.
 nroots - количество найденных действительных корней
 n=0: корни мнимые, х1 - вещественная часть, х2 - мнимая;
 n=1: корни действительные и равные, х1=х2;
 n=2: корни действительные и разные, х1, х2}
var
  d: real;
begin
  d := sqr(b) - 4 * a * c;
  if d < 0 then
  begin
    nroots := 0;
    x1 := -b / (2 * a);
    x2 := sqrt(-d) / (2 * a);
  end
  else if d = 0 then
  begin
    nroots := 1;
    x1 := -b / (2 * a);
    x2 := x1
  end
  else
  begin
    nroots := 2;
    d := sqrt(d);
    x1 := (-b - d) / (2 * a);
    x2 := (-b + d) / (2 * a)
  end
end;

{тестирование}
var
  a2, a1, a0, x1, x2: real;
  n: integer;

begin
  repeat
    write('Введите коэффициенты уравнения: ');
    readln(a2, a1, a0);
    if abs(a2) + abs(a1) > 0 then
    begin
      SqRoot(a2, a1, a0, x1, x2, n);
      case n of
        0: writeln('Корни мнимые: ', x1:0:6, '-I*', x2:0:6, ', ',x1:0:6, '+I*', x2:0:6);
        1: writeln('Корни действительные и равные: ', x1:0:6);
        2: writeln('Корни действительные и разные: ', x1:0:6, ', ', x2:0:6)
      end
    end
  until abs(a2) + abs(a1) = 0
end.

Тестовое решение:

Введите коэффициенты уравнения: 3 -2.5 1
Корни мнимые: 0.416667-I*0.399653, 0.416667+I*0.399653
Введите коэффициенты уравнения: -3 5 2
Корни действительные и разные: 2.000000, -0.333333
Введите коэффициенты уравнения: 4 -6 2.25
Корни действительные и равные: 0.750000
Введите коэффициенты уравнения: 0 0 0