| /
|/  /  /
|      /
|

procedure TForm1.Button1Click(Sender: TObject);
label
 0,1;
const
 prLen0=4; // Length of Progression -1
 seqLen0=4199; // Length of Sequence -1
var
 prLen,l:Byte;
 i,j,k,d,d0,imin,seqLen:Word;
 l1:Integer;
 b:array[0..seqLen0-1]of Byte; // b[i]=a[i+1]-a[i]
 SOut:String;
begin
Memo1.Lines.Add('Seq.Length='+IntToStr(seqLen0+1));
Memo1.Lines.Add('Prog.Length='+IntToStr(prLen0+1));
FillChar(b,SizeOf(b),0);
imin:=seqLen0-prLen0;
prLen:=prLen0-1;
seqLen:=seqLen0-1;
repeat
for i:=imin downto 0 do for j:=1 to (seqLen0-i) div prLen0 do begin
 d0:=b[i];for k:=i+1 to i+j-1 do inc(d0,b[k]);
 for l:=1 to prLen do begin
  d:=b[i+j*l];for k:=i+j*l+1 to i+j*(l+1)-1 do inc(d,b[k]);
  if d<>d0 then goto 1; // Search for next progression
 end;
 // Progression found, go to the next sequence
 for l1:=i-1 downto 0 do b[l1]:=0;
 l1:=i; while b[l1]=1 do begin b[l1]:=0;inc(l1) end;
 b[l1]:=1;
 goto 0;
1:
end;
// No progessions found
SOut:='';
for i:=seqLen downto 0 do if b[i]=1 then SOut:=SOut+'x' else SOut:=SOut+'o';
Memo1.Lines.Add(SOut);
Break;
0:
until b[seqLen]=1; // by the symmetry , without loss of genearily we can assume b[0]=0
Memo1.Lines.Add('Done');
end;