program asd;
function IntToStr(number : integer) : string;
var
result : string;
begin
Str(number, result);
IntToStr := result;
end;
function HasIdenticalFigures(number : integer) : boolean;
var
sNumber : string;
letter : char;
begin
sNumber := IntToStr(number);
repeat
letter := sNumber[1];
Delete(sNumber, 1, 1);
if (Pos(letter, sNumber) <> 0)
then
begin
HasIdenticalFigures := true;
Exit;
end;
until (Length(sNumber) = 0);
HasIdenticalFigures := false;
end;
var
position : word;
currentPosition : word;
currentNumber : word;
begin
Write('position = ');
Readln(position);
currentPosition := 1;
currentNumber := 0;
while (currentPosition <= position) do
begin
Inc(currentNumber);
if not(HasIdenticalFigures(currentNumber))
then
Inc(currentPosition);
end;
Write(currentNumber);
Readln;
end.
Вариант 2
uses crt;
function OstChs(a:integer):boolean;{функция определяет, какие числа остаются}
var m:set of byte;
k:byte;
b:integer;
begin
b:=a;
m:=[];
OstChs:=true;
while b<>0 do{пока число не ноль}
begin
k:=b mod 10;{отделяем цифру}
if k in m then{если она уже есть в множестве}
begin
OstChs:=false;{это число вычеркиваем}
break;{выходим из цикла}
end
else include(m,k);{если еще нет этой цифры, включаем в множество}
b:=b div 10;{берем следующее число без этой цифры}
end;
end;
var i,n,k:integer;
begin
clrscr;
repeat
write('Введите число от 1 до 10000 n=');
readln(n);
until(n>0)and(n<=10000);
i:=1;k:=0;
while k<n do{пока не дошли до заданного номера}
begin
if OstChs(i) then{если в числе нет одинаковых цифр}
begin
inc(k);{увеличиваем искомое число}
inc(i);{переходим к следующему по порядку}
end
else inc(i);{если удаляем, то просто переходим к следующему}
end;
write('Число N=',i-1);{результат=предпоследнее число}
readln
end.