Program Coins2;
Uses CRT;
Const
      Nums: Array[1..9] of Integer = (3, 9, 27, 81, 243, 729, 2187, 6561, 19683);
      N = 4;
Var a: Array[1..20000] of Byte;
    Max, i: Integer;
    c: Char;
    Count: Byte;

Procedure Rules;
Begin
Writeln(#13#10,'[0] - Если чаши весов остались в равновесии');
Writeln('[1] - Если левая чаша весов перевесила правую');
Writeln('[2] - Если правая чаша весов перевесила левую');
Writeln('!!! Учтите, что ФАЛЬШИВАЯ монета ТЯЖЕЛЕЕ остальных !!!');
End;

Procedure Find(min, max: Integer);
Var leng, part: Integer;
Begin
leng := max - min; {Длина ряда}
If (Leng < 3) then
   Begin
   Writeln('Последнее взвешивание!');
   Writeln('Слева монета ',min,', Справа монета ',max);
   Repeat
   Writeln('Какая чаша тяжелее? Введите число 0|1|2');
   Readln(c);
   Until (c='1') or (c='2') or (c='0');
   Write('Ну тут очевидно, что фальшивка - ');
   Case c of
   '1': Writeln(min);
   '0': Writeln(min+1);
   '2': Writeln(max);
   End;
   Writeln('Вот и сказочке конец. Кто не понял - F1');
   ReadKey;
   Halt;
   End;

part := leng div 3; {Одна третья часть}
Inc(Count);
ClrScr;
Writeln('Взвешивание номер ',Count);
Writeln('На левой чаше весов лежат монеты от ',min,' до ',min + part);
Writeln('На правой чаше весов лежат монеты от ',min+part+1,' до ',max - part-1);
Repeat
Writeln(#13#10,'Какая чаша тяжелее? Введите число 0|1|2');
Rules;
Readln(c);
Until (c='1') or (c='2') or (c='0');
Case c of
'0': Begin
     Writeln('Ага! Равновесие. Значит фальшивая монета где-то среди ',max-part+1,' - ',max,' монет');
     ReadKey;
     Find(max-part+1,max);
     End;
'1': Begin
     Writeln('Опаньки! Левая тяжелее. Значит фальшивая монета где-то среди ',min,' - ',min+part,' монет');
     ReadKey;
     Find(min, min+part);
     End;
'2': Begin
     Writeln('Ух ты! Правая тяжелее. Значит фальшивая монета где-то среди ',min+part+1,' - ',max - part-1,' монет');
     ReadKey;
     Find(min+part+1, max-part-1);
     End;
End;
End;

Begin
ClrScr;
Writeln('Загадайте монетку от 1 до ',Nums[N]); ReadKey;
Writeln('Загадали?'); ReadKey;
Writeln('Лучше запишите, а то я вас знаю....'); Readkey;
Writeln('Приступаем...'); ReadKey;
Find(1, Nums[N]);
End.

Источник: