Решение задачи C квалификационного раунда Google Code Jam 2016

Условия задачи «Джемкойны»

Решение для малого набора данных (N = 16, J = 50)

program JamCoin;

uses
  SysUtils;
const
  minBase = 2;
  maxBase = 10;
var
  N: Byte; //total number of digits
  T, i: Byte;
  J: Word;
  NJ: string;
  spacePos: SizeInt;
  bits, mBits: Word;
  b: Byte;
  jj: Word;
  k: Byte;
  num: QWord;
  d: LongWord;
  dcount: Byte;
  divs: array[minBase..maxBase] of LongWord;
  stop: boolean;

function BitSet(bits: Word; i: Byte): boolean;
var
  mask: Word;
begin
  mask:=1 shl i;
  result:=(bits and mask) = mask;
end;

function Number(bits: Word; base: Byte): QWord;
var
  b: Byte;
  i: Byte;
  power: QWord;
begin
  result:=0;
  for b:=0 to N - 1 do
    if BitSet(bits, b) then
    begin
      power:=1;
      for i:=1 to b do
        power:=power * base;
      result:=result + power;
    end;
end;

function Divisor(number: QWord; base: Byte): QWord;
var
  i: QWord;
  last: QWord;
begin
  result:=0;
  i:=2;
  last:=number - 1;
  while i < last do
  begin
    if i Mod base = 0 then
    begin
      Inc(i);
      Continue;
    end;
    if  number Mod i = 0 then
    begin
      result:=i;
      Break;
    end
    else
    begin
      last:=number Div i;
    end;
    Inc(i);
  end;
end;

procedure PrintBits(number: LongWord);
var
  bitCount: Byte;
begin
  bitCount:=0;
  for b:=N - 1 downto 0 do
  begin
    if BitSet(number, b) then
    begin
      Write('1');
      Inc(bitCount);
    end
    else
      Write('0');
  end;
  if bitCount = N then stop:=true;
end;

begin
  Readln(T);
  for i:=1 to T do
  begin
    Readln(NJ);
    spacePos:=Pos(' ', NJ);
    N:=StrToInt(LeftStr(NJ, spacePos - 1));
    J:=StrToInt(RightStr(NJ, Length(NJ) - spacePos));
    Writeln('Case #', i, ':');
    mbits:=0;
    jj:=0;
    while (jj < J) and not stop do
    begin
      dcount:=0;
      while dcount < 9 do begin bits:=1 shl (N - 1) + (mbits shl 1) + 1; for k:=minBase to maxBase do begin num:=Number(bits, k); d:=Divisor(num, k); divs[k]:=d; if d > 0 then
          begin
            Inc(dcount);
          end
          else
          begin
            dcount:=0;
            Break;
          end;
        end;
        Inc(mbits);
      end;
      Inc(jj);
      PrintBits(bits);
      for k:=minBase to maxBase do
        Write(' ', divs[k]);
      Writeln;
    end;
  end;
end.