Вот на форуме нашел программку, которая проверяет, является ли заданное число числом Смита:

 function GetOneDigits(n: LongInt): Integer;
var s: Integer;
begin
	s := 0;
	while n <> 0 do begin
		Inc(s, n mod 10);
		n := n div 10;
	end;
	GetOneDigits := s
end;

function GetSimpleDigits(n: LongInt; var amount: Integer): Integer;
var
	s, factor: Integer;
begin
	s := 0; factor := 2;
	amount := 0;
	repeat
		if n mod factor = 0 then begin
			s := s + GetOneDigits(factor); Inc(amount);
			n := n div factor
		end
		else Inc(factor)
	until n = 1;
	GetSimpleDigits := s
end;

function GetSmith(n: Integer): LongInt;
var
	i, amount: Integer; od, sd: Integer;
	count: LongInt;
	Found: Boolean;
begin
	i := 0; count := 2;
	while i <> n do begin
		repeat
			Inc(count);
			Found :=
				(GetOneDigits(count) = GetSimpleDigits(count, amount))
				and
				(amount > 1)
		until Found;
		Inc(i)
	end;
	GetSmith := Count
end;

function IsSmith(n: LongInt): Boolean;
var
	i: Integer;
	next: LongInt;
begin
	i := 0;
	repeat
		Inc(i); next := GetSmith(i)
	until next >= n;
	IsSmith := (next = n)
end;

var
	X: Integer;
		f:text;
begin
  readln(x);  
   if IsSmith(X) then write('TRUE') else write('FALSE');
  end.

У меня вопрос: есть ли программы, которые работают быстрее???

Это вряд ли... В любом случае придется раскладывать число на простые сомножители, а это достаточно длительный процесс... А в чем, собственно, проблема? Надо проверять много чисел, или большие числа?

Нужно найти все числа Смита до 30000.

Попробуй, может быть вот так побыстрее будет?

function SumDigits(n: longint): integer;
var s: integer;
begin
  s := 0;
  while n <> 0 do begin
    Inc(s, n mod 10);
    n := n div 10;
  end;
  SumDigits := s
end;

function Factorization(X: longint): longint;
var
  i, s: word;

  procedure DivX;
  begin
    while (x > 1) and (x mod i = 0) do begin
      inc(s, SumDigits(i));
      x := x div i;
    end;
 end;

begin
  s := 0;

  i := 2;
  DivX;
  i := 3;
  while (i < x div 2) do begin
    DivX;
    inc(i,2);
  end;
  if x > 1 then inc(s, SumDigits(x));

  Factorization := s;
end;


function isPrime(X: word): boolean;
var i: integer;
begin
  isPrime:=false;
  if not odd(x) and (x <> 2) then exit;
  i := 3;

  while i <= sqrt(x) do begin
    if x mod i = 0 then exit;
    inc(i,2);
  end;
  isPrime := true;
end;


var
  i: integer;

begin
  for i := 1 to 30000 do begin
    if not isprime(i) and
       (SumDigits(i) = Factorization(i)) then write(i:6);
  end
end.

Спасибо. Всё работает)