merthsoft
Delphi programm code for search this loops
Code:
unit Unit3;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, jpeg, ExtCtrls;
type
TForm1 = class(TForm)
Label1: TLabel;
Memo1: TMemo;
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
procedure FormCreate(Sender: TObject);
function DS(dx:string):string;
procedure Button1Click(Sender: TObject);
procedure Edit1Change(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
xy:array[0..100,0..1] of longint;
qc:array[0..16] of longint;
r,i,n,n2:longint;
x1,y1,x2,y2,x0,y0:real;
abacaba,abc,sx: string;
x,gc: array[0..2048*64] of longint;
m,pm: array[0..2048*64] of longint;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
i:=0;
r:=0;
end;
function TForm1.DS(dx:string):string;
var i,l,t,c,j,k,n,n2,r,q,max,pc,mc,f,gf:longint;
lx,cx:string;
begin
max:=8192*2;
l:=Length(dx)-1;
sx:=dx;
dx:=dx+dx;
n2:=1;
n:=0;
for q:=0 to max-1 do
begin
r:=0;
n2:=n2*2;
n:=n+1;
if l>=(n-1) then
begin
for i:=0 to n2-1 do m[i]:=0;
for i:=0 to l do
begin
t:=0;
for j:=0 to n-1 do
begin
lx:=dx[1+i+j];
if lx<>'x' then t:=t or ((StrToInt(dx[1+i+j]) and 1) shl (n-j-1)) else f:=1;
end;
m[t]:=1;
end;
for i:=0 to n2-1 do
begin
if (m[i]=1) then
begin
r:=r+1;
end;
end;
end;
if n>max then break;
if n2<>r then break;
end;
r:=1;
for i:=0 to n-2 do r:=r*2;
mc:=0;
for q:=0 to l+1 do
begin
for i:=0 to 2*r-1 do
begin
m[i]:=-1;
pm[i]:=-1;
end;
cx:='';
for i:=0 to r-1 do
begin
t:=0;
f:=1;
for j:=0 to n-2 do
begin
lx:=dx[1+(q+(i+(j mod r)) mod r) mod (l+1)];
f:=0;
if lx<>'x' then t:=t or ((StrToInt(lx) and 1) shl ((n-j-2))) else f:=1;
end;
if f=0 then m[t]:=1 else m[t]:=-1;
end;
pc:=0;
for i:=0 to r-1 do
begin
if (m[i]=1) then
begin
pc:=pc+1;
end;
end;
if pc=r then
begin
cx:='';
for i:=0 to r-1 do
begin
t:=0;
f:=1;
for j:=0 to n-2 do
begin
lx:=dx[1+(q+(i+(j mod r)) mod r) mod (l+1)];
t:=t or ((StrToInt(lx) and 1) shl ((n-j-2)));
end;
f:=1+((q+i+n-1) mod r) mod (r);
cx:=dx[f];
pm[t]:=StrToInt(cx);
end;
for j:=0 to r-1 do
begin
if pm[j]=0 then
begin
dx[1+(q+j) mod (l+1)]:='0';
sx[1+(q+j) mod (l+1)]:='x';
end else
begin
dx[1+(q+j) mod (l+1)]:='1';
sx[1+(q+j) mod (l+1)]:='x';
end;
end;
mc:=mc+1;
break;
end;
if n>max then break;
end;
for j:=0 to r-1 do
begin
q:=(j shr 1) xor j;
sx[1+(j) mod (l+1)]:=dx[1+(q) mod (l+1)];
end;
SetLength(dx,Round(l+1));
SetLength(sx,Round(l+1));
Memo1.Lines.Add(dx+' '+sx+' '+IntToStr(n-1));
DS:=sx;
end;
procedure TForm1.Button1Click(Sender: TObject);
var pi,mpi,cx,cy,cp,bx,by:real;
f,i,j,k,l,r,n,n2,m,c,c0,p,q0,q1,z,cnt,v,w:longint;
qx,s,ts,graycube,st,stp,ms,rythm,new:string;
t,q,max,pc,mc,nc,ps:longint;
bf,mbf:int64;
tm1,tm2:longint;
function HD(a,b,n:longint):longint;
var i,p:longint;
begin
p:=0;
for i:=1 to n do
begin
if (((a and 1) xor (b and 1))=1) then p:=p+1;
a:=a shr 1;
b:=b shr 1;
end;
HD:=p;
end;
procedure GetRuler(ds:string;n,n2:longint);
var Hx:string;
i,max,j,e,p,q,t,f,u,z:longint;
st,rs:string;
s:string;
ruler,x,y,c,rz,mt:array[0..1024] of longint;
begin
for z:=0 to 128 do
begin
ruler[z]:=-1;
x[z]:=-1;
y[z]:=-1;
end;
max:=n2;
st:=ds;
for i:=0 to max-1 do
begin
p:=0;
for j:=0 to n-1 do
begin
if (st[i+j+1]='1') then p:=p or 1;
p:=p shl 1;
end;
x[i]:=p shr 1;
end;
t:=0;
p:=0;
f:=0;
ruler[0]:=0;
y[0]:=1;
while (f=0) do
begin
z:=t;
j:=0;
while (j<max) do
begin
if (y[j]=-1) then
begin
p:=x[j];
q:=0;
i:=0;
if t>(n-1) then u:=n-1 else u:=t+1;
while (i<u) do
begin
if (HD(p,ruler[(t-i)],n)=(i+1)) then
begin
q:=q+1;
end;
i:=i+1;
if q=u then break;
end;
if q=u then
begin
t:=t+1;
ruler[t]:=x[j];
y[j]:=1;
f:=0;
break;
end;
end;
j:=(j+1);
end;
if t=z then break;
end;
if t=max-1 then
begin
st:='';
st:=st+ds;
for i:=0 to max-1 do st:=st+' '+IntToStr(ruler[i]);
Memo1.Lines.Add(st);
end;
end;
begin
tm1:=GetTickCount();
tm2:=0;
mbf:=144115188075855872;
bf:=0;
pi:=3.1415926535897932384626433832795;
mpi:=0;
n:=StrToInt(Edit2.Text);
n2:=1 shl n;//(long)pow(2,n);
p:=0;
z:=0;
cnt:=0;
s:=''; ts:='';
for i:=0 to n2+n do begin if (i<n) then x[i]:=0 else x[i]:=0;end;
i:=n;
while (i<n2+n-1+1) do begin
v:=i;
for j:=0 to i-n do begin
f:=1;
for k:=0 to n-1 do begin if (x[i+k-n+1]<>x[j+k]) then begin f:=0;break;end;end;
if (f=1) then begin break;end;
end;
c:=1;
if (f=1) then begin
j:=i;
while (j>=n) do begin
c0:=x[j];
x[j]:=(x[j]+c) mod 2;
if (c0=1) then begin c:=1;j:=j-1;end else begin break;end;
end;
i:=j;
end else begin
i:=i+1;
end;
//print
if ((i=(n2+n-1)) and ((p mod 2)=0)) then begin
//s:=s+#13#10;
for l:=0 to n2-1 do begin
s:=s+IntToStr(x[l]);
end;
// s:=s+#13#10;
GetRuler(s,n,n2);
s:='';
// break; //for one print
end;
p:=p+1;
if (i<n) then begin break; end;
end;
s:='';
tm2:=GetTickCount();
Memo1.Lines.Add(IntToStr(Round(tm2-tm1)));
Memo1.Lines.Add('end');
end;
procedure TForm1.Edit1Change(Sender: TObject);
var i,l,t,c,j,n,n2,r,q,max,pc,mc,f:longint;
x,lx:string;
cinx:array[0..32,0..32] of longint;
m:array[0..65536] of longint;
begin
x:='';
x:=Edit1.Text;
max:=16;
l:=Length(x)-1;
x:=x+x;
n2:=1;
n:=0;
Label1.Caption:=IntToStr(l+1);
for q:=0 to max-1 do
begin
r:=0;
n2:=n2*2;
n:=n+1;
if l>=(n-1) then
begin
for i:=0 to n2-1 do m[i]:=0;
for i:=0 to l do
begin
t:=0;
for j:=0 to n-1 do
begin
t:=t or ((StrToInt(x[1+i+j]) and 1) shl (n-j-1));
end;
m[t]:=1;
end;
for i:=0 to n2-1 do
begin
if (m[i]=1) then
begin
r:=r+1;
end;
end;
end;
if n>max then break;
if n2<>r then break;
end;
r:=1;
for i:=0 to n-2 do r:=r*2;
mc:=0;
for q:=0 to l+1 do
begin
for i:=0 to 2*r-1 do m[i]:=-1;
for i:=0 to r-n+3 do
begin
t:=0;
f:=1;
for j:=0 to n-2 do
begin
lx:=x[1+(q+(i+(j mod r)) mod r) mod (l+1)];
f:=0;
if lx<>'x' then t:=t or ((StrToInt(lx) and 1) shl ((n-j-2))) else f:=1;
end;
if f=0 then m[t]:=1 else m[t]:=-1;
// Memo1.Lines.Add(IntToStr(t));
end;
pc:=0;
for i:=0 to r-1 do
begin
if (m[i]=1) then
begin
pc:=pc+1;
end;
end;
if pc=r then
begin
for j:=0 to r-1 do x[1+q+j]:='x';
mc:=mc+1;
//break;
end;
if n>max then break;
end;
max:=n-1;
if mc>max then max:=mc;
Label1.Caption:=Label1.Caption+' '+IntToStr(n-1)+'*'+IntToStr(mc)+' max= '+IntToStr(max)+' ok. '+IntToStr(r)+'/'+IntToStr(n2);
end;
end.
Edit by Merth: Added code tags 
