User blog comment:Rgetar/Clested fundamental sequence systems/@comment-25601061-20171228155613/@comment-159.255.64.182-20171228173447

You mean source code? Here it is:

unit Ord;

interface

uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Math;

type TForm1 = class(TForm) Button1: TButton; Label1: TLabel; Edit1: TEdit; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end;

var Form1: TForm1; st,st1: string; e,i,m,fsc: integer; b,mo,clested:boolean; s: array of string; l: array of boolean; c: array of integer; f: textfile; fss: byte; implementation

{$R *.dfm}

// get position of last symbol p of string st (if l=true then first) function getls(st,p:string;l:boolean=false):integer; var e,na,np: integer; begin if length(st)<2 then result:=ifthen(l,length(st)+1,0) else begin if l then e:=0 else e:=length(st)+1; if p='>' then na:=-1 else na:=0; np:=0; repeat if l then inc(e) else dec(e); if st[e]='<' then dec(na); if st[e]='>' then inc(na); if st[e]='(' then dec(np);     if st[e]=')' then inc(np); until (not l and (e=1)) or (l and (e=length(st))) or ((st[e]=p) and (na=0) and (np=0)); if not l and (e=1) then e:=0 else if l and (e=length(st)) then e:=length(st)+1; result:=e; end; end;

// get last element of set st with separator s function le(st:string;s:string='+'):string; begin result:=copy(st,getls(st,s)+1,length(st)); end;

// get first element of set st with separator s function fe(st:string;s:string='+'):string; begin result:=copy(st,1,getls(st,s,true)-1); end;

// get left rest of set st with separator s function lrest(st:string;s:string='+'):string; begin result:=copy(st,1,getls(st,s)-1); if result='' then result:='0'; end;

// get right rest of set st with separator s function rrest(st:string;s:string='+'):string; begin result:=copy(st,getls(st,s,true)+1,length(st)); if result='' then result:='0'; end;

// last term of Cantor normal form st set to beta function ltst(st,beta:string):string; begin if beta='0' then result:=lrest(st) else begin if lrest(st)='0' then result:='' else result:=lrest(st)+'+'; result:=result+beta; end; end;

// get type of ordinal st (0 - limit, 1 - successor, 2 - limit) function getordtype(st:string):byte; begin if st='0' then result:=0 else if le(st)='1' then result:=1 else result:=2; end;

// get array of Veblen function st function getx(st:string):string; begin result:=copy(st,2,length(st)-2); end;

// get last base element of array x function lbeo(x:string):string; begin x:=le(x,','); result:=copy(x,getls(x,'>')+1,length(x)); end;

// get coordinates of last base element of array x function colbeo(x:string):string; begin x:=le(x,','); result:=copy(x,1,getls(x,'>')-1); if result='' then result:='0' else delete(result,1,1); end;

// get left rest of array x function lrt(x:string):string; begin result:=copy(x,1,getls(x,',')-1); if result='' then result:='0'; end;

// get first base element of array x function fbeo(x:string):string; begin x:=fe(x,','); result:=copy(x,getls(x,'>')+1,length(x)); end;

// get coordinates of first base element of array x function cofbeo(x:string):string; begin x:=fe(x,','); result:=copy(x,1,getls(x,'>')-1); if result='' then result:='0' else delete(result,1,1); end;

// get right rest of array x function rrt(x:string):string; begin result:=copy(x,getls(x,',',true)+1,length(x)); if result='' then result:='0'; end;

// get last element of array x function leo(x:string):string; begin if colbeo(x)='0' then result:=lbeo(x) else result:='0'; end;

// last base element of array x set to beta function lbest(x,beta:string):string; begin if beta='0' then result:=lrt(x) else begin if lrt(x)='0' then result:='' else result:=lrt(x)+','; if colbeo(x)<>'0' then result:=result+'<'+colbeo(x)+'>'; result:=result+beta; end; end;

// last element of array x set to beta function lest(x,beta:string):string; begin if colbeo(x)='0' then result:=lbest(x,beta) else if beta='0' then result:=x else result:=x+','+beta; end;

// add element e with coordinates c to array x function addbe(x,c,e:string):string; begin if x='0' then x:='' else x:=x+','; if c<>'0' then x:=x+'<'+c+'>'; result:=x+e; end;

// get iterated last base element of array x function ilbeo(x:string; s:string=''):string; begin result:=s+lbeo(x); if colbeo(x)<>'0' then result:=ilbeo(colbeo(x),result+'|'); end;

// get iterated set of base elements of array x function isobe(x:string; s:string=''):string; begin result:=s; repeat if result<>'' then result:=result+'|'; result:=result+lbeo(x); if colbeo(x)<>'0' then result:=isobe(colbeo(x),result); x:=lrt(x); until x='0'; end;

// get iterated set of base elements without iterated last base element of array x function isobewilbeo(x:string; s:string=''):string; var e:integer; begin result:=s; e:=-1; repeat inc(e); if e>0 then begin if result<>'' then result:=result+'|'; result:=result+lbeo(x); end; if colbeo(x)<>'0' then if e=0 then result:=isobewilbeo(colbeo(x),result) else result:=isobe(colbeo(x),result); x:=lrt(x); until x='0'; end;

// compare arrays x1 and x2 of standard form function compare(x1,x2:string):shortint; var e:shortint;

// compare ordinals st1 and st2 function compareo(st1,st2:string):shortint; var e:shortint; s1,s2:string;

// compare Veblen functions s1 and s2 function comparev(s1,s2:string):shortint; var x1,x2,l,s,xs,i,st:string; e,p:shortint; b:boolean; begin x1:=getx(s1); x2:=getx(s2); b:=false; if s1=s2 then result:=0 else begin repeat e:=compare(cofbeo(x1),cofbeo(x2)); if e=0 then begin e:=compareo(fbeo(x1),fbeo(x2)); if e<>0 then b:=true; end; if e=0 then begin x1:=rrt(x1); x2:=rrt(x2); end; until (e<>0) or ((x1='0') and (x2='0')); if e=0 then result:=0 else begin if e<0 then begin p:=-1; s:=s1; l:=s2; xs:=x1; end else begin p:=1; s:=s2; l:=s1; xs:=x2; end; if b and (cofbeo(x1)='0') then result:=e else begin if b then xs:=rrt(xs); i:=isobewilbeo(xs); b:=false; if i<>'' then repeat if compareo(fe(i,'|'),l)>-1 then b:=true else i:=rrest(i,'|'); until b or (i='0'); if b then result:=-p else begin i:=ilbeo(xs); b:=false; repeat st:=fe(i,'|'); if compareo(st,'1')<>0 then b:=true else i:=rrest(i,'|'); until b or (i='0'); if not b then result:=p else begin e:=compareo(st,l); i:=rrest(i,'|'); if e=0 then begin if i='0' then result:=0 else begin b:=false; repeat if compareo(fe(i,'|'),l)>-1 then b:=true else i:=rrest(i,'|'); until b or (i='0'); if b then result:=-p else result:=0; end; end else begin b:=false; if e=1 then result:=-p else if i='0' then result:=p else begin repeat if compareo(fe(i,'|'),l)>-1 then b:=true else i:=rrest(i,'|'); until b or (i='0'); if b then result:=-p else result:=p; end; end; end; end; end; end; end; end;

begin if st1=st2 then result:=0 else begin if st1='' then st1:='0'; if st2='' then st2:='0'; if (st1='0') or (st1='1') or (st2='0') or (st2='1') then begin if (st1='0') or (st1='1') then else st1:='2'; if (st2='0') or (st2='1') then else st2:='2'; result:=comparevalue(strtoint(st1),strtoint(st2)); end else begin repeat s1:=fe(st1); s2:=fe(st2); if (st1='0') or (st1='1') or (st2='0') or (st2='1') then e:=compareo(s1,s2) else e:=comparev(s1,s2); if e=0 then begin st1:=rrest(st1); st2:=rrest(st2); end; until (e<>0) or ((st1='0') and (st2='0')); result:=e; end; end; end;

// start begin if x1=x2 then result:=0 else if (x1='0') or (x1='1') or (x2='0') or (x2='1') then begin if (x1='0') or (x1='1') then else x1:='2'; if (x2='0') or (x2='1') then else x2:='2'; result:=comparevalue(strtoint(x1),strtoint(x2)); end else begin repeat e:=compare(cofbeo(x1),cofbeo(x2)); if e=0 then e:=compareo(fbeo(x1),fbeo(x2)); if e=0 then begin x1:=rrt(x1); x2:=rrt(x2); end; until (e<>0) or ((x1='0') and (x2='0')); result:=e; end; end;

// check are Veblen function s1 and Veblen function in standard form s2 equal function csu(s1,s2:string):boolean; var x1,x2,i,i2,l:string; b:boolean; e:shortint; begin x1:=getx(s1); x2:=getx(s2); if (x1='1') or (x2='1') then result:=x1=x2 else begin // left equal part of x1 b:=true; repeat e:=compare(cofbeo(x1),cofbeo(x2)); if e=0 then e:=compare(fbeo(x1),fbeo(x2)) else b:=false; if e=0 then begin x1:=rrt(x1); x2:=rrt(x2); end; until (e<>0) or ((x1='0') and (x2='0')); if e=0 then result:=true else if e=1 then result:=false else

// part of x1 before its lbeo begin if b then x1:=rrt(x1); repeat if getls(x1,',')=0 then begin i:=isobewilbeo(cofbeo(x1)); i2:=fbeo(x1); if ilbeo(cofbeo(x1))<>'0' then i2:=i2+'|'+ilbeo(cofbeo(x1)); end else i:=fbeo(x1)+'|'+isobe(cofbeo(x1)); b:=false; if i='' then i:='0'; repeat l:=le(i,'|'); if compare(l,s2)>-1 then b:=true else i:=lrest(i,'|'); until b or (i='0'); x1:=rrt(x1); until b or (x1='0'); if b then result:=false else

// lbeo of x1     begin b:=false; repeat l:=fe(i2,'|'); if l<>'1' then b:=true; i2:=rrest(i2,'|'); until b or (i2='0'); if compare(l,s2)<>0 then result:=false else if i2='0' then result:=true else begin b:=false; repeat l:=fe(i2,'|'); if compare(l,s2)>-1 then b:=true; i2:=rrest(i2,'|'); until b or (i2='0'); result:=not b;        end; end; end; end; end;

// standard form of ordinal st function sf(st:string):string;

// standard form of array x function sfa(x:string):string; begin result:=''; repeat result:=sf(lbeo(x))+result; if colbeo(x)<>'0' then result:='<'+sfa(colbeo(x))+'>'+result; x:=lrt(x); if x<>'0' then result:=','+result; until x='0'; end;

// standard form of Cantor normal form term st function sft(st:string):string; var x,i,l,s:string; b:boolean; begin if (st='1') or (st='(0)') then result:='1' else begin x:=getx(st); i:=ilbeo(x); b:=false; s:='('+sfa(x)+')'; repeat //l:=sf(le(i,'|')); l:=le(i,'|'); //if (lrest(l)='0') and (l[1]='(') and csu(s,l) then     if (lrest(l)='0') and (l[1]='(') and (compare(s,l)=0) then b:=true else i:=lrest(i,'|'); until b or (i='0'); if b then result:=l else result:=s; end; end;

// start begin if st='0' then result:='0' else begin result:=''; repeat result:=sft(le(st))+result; st:=lrest(st); if st<>'0' then result:='+'+result; until st='0'; end; end;

// n-th fundamental sequence element of ordinal st function fse(st:string; n:integer; m:boolean=false; v:boolean=false):string; var r,l,x,i,delta:string; a,c:array[0..1000] of string; q,w,y{,n2}:integer; b:boolean; begin //n2:=n; if st='BHO' then begin r:='1'; while n>0 do  begin r:='<'+r+'>1'; dec(n); end; result:='('+r+')'; end else begin r:=lrest(st); if m and not v and (r='0') and (le(st)<>'1') and (le(st)<>'(1)') then begin {if getordtype(fse(st,1,m,true))<2 then n:=n+2 else} if getordtype(fse(st,0,m,true))<2 then begin inc(n); //inc(n2); end; end; v:=false; if r<>'0' then

// Cantor normal form begin l:=fse(le(st),n,m,v); if l<>'0' then r:=r+'+'+l; end else

// Cantor normal form term begin if st='1' then r:='0' else               // 0 if st='(1)' then                         // omega if {not m and} (n=0) then r:='0' else                        // old m      begin r:=''; repeat if r<>'' then r:=r+'+'; r:=r+'1'; dec(n); until n={ifthen(m,-1,0)}0;                             // old m      end else begin x:=getx(st); if (cofbeo(x)='0') and (getordtype(x)=1) then

// x - successor ordinal if {not m and} (n=0) then r:='0' else                     // old m         begin r:=''; l:=sf('('+fse(x,0,m,v)+')'); repeat if r<>'' then r:=r+'+'; r:=r+l; dec(n); until n={ifthen(m,-1,0)}0;                           // old m         end

else begin //setlength(a,1); //setlength(c,1); c[0]:=lest(x,'0'); if leo(x)='0' then {if m and (lbeo(c[0])='1') and (lrt(c[0])='0') then delta:='1' else} delta:='0'             // old m                                                 // not modified else delta:='('+lest(x,fse(leo(x),n,m,v))+')'+'+1'; if getordtype(leo(x))=2 then

// leo(x) - limit ordinal r:=copy(delta,1,length(delta)-2)

else

// leo(x) - not limit ordinal begin i:=ilbeo(c[0]); q:=0; repeat a[q]:=fe(i,'|'); i:=rrest(i,'|'); inc(q); //setlength(a,q+1); //setlength(c,q+1); c[q]:=colbeo(c[q-1]); until i='0'; dec(q); b:=false; w:=-1; repeat inc(w); if getordtype(a[w])=2 then b:=true; until b or (w=q); r:=''; y:=w+1; if b then

// ilbeo contains limit ordinal begin repeat dec(y); l:=lbest(c[y],fse(lbeo(a[y]),n,m,v)); if l='0' then l:=''; if y=w then r:=l else begin if (l<>) and (r<>) then r:=l+','+r else r:=l+r; end; if y>0 then begin if r<>'' then r:='<'+r+'>'; r:=r+'1'; end; until y=0; if not clested or (delta<>'0') then r:=lest(r,sf(delta));       // do not set to zero last element (clest) end else

// ilbeo does not contain limit ordinal begin repeat dec(y); l:=lbest(c[y],fse(lbeo(a[y]),n,m,v)); if y=w then if n>0 then begin if l<>'0' then l:='<'+l+'>' else l:=''; r:=l+fse(st,n-1,m,true);                        // v                        end else

// 2nd system begin if (fss=2) and (delta<>'0') then begin if l<>'0' then l:='<'+l+'>' else l:=''; r:=l+delta;                        // v                           end; end

else begin if l='0' then l:=''; if (l<>) and (r<>) then r:=l+','+r else r:=l+r; if y>0 then begin if r<>'' then r:='<'+r+'>'; r:=r+'1'; end; end; until y=0; if (fss=6) and (n=0) and (not clested or (delta<>'0')) then r:=lest(r,delta);   // 6th system, do not set to zero last element (clest) end; if (r='0') or (r='') then r:='1' else r:='('+r+')'; end; end; end; end; {if n2=1 then l:=sf(r); if (n2=1) and (r<>l) then result:=r else} //if n2>0 then result:=r else result:=sf(r); end; end;

// expand current list by n levels procedure levelup(n:integer); var e,i,y,o,c1:integer; begin repeat c1:=0; for e:=0 to length(s)-1 do if l[e] then inc(c1); dec(n); dec(m); e:=1; repeat if not l[e] and l[c[e]] then begin l[e]:=true; e:=c[e]; end else if l[e] then begin inc(fsc); dec(c1); l[e]:=false; form1.Label1.Caption:=inttostr(fsc)+' / '+inttostr(c1)+'                                         '; form1.Label1.Refresh; //if (e<length(s)-1) and (getordtype(s[e+1])=2) then l[e+1]:=true; setlength(s,length(s)+m); setlength(l,length(l)+m); setlength(c,length(c)+m); o:=c[e]; c[length(s)-1]:=o; c[e]:=length(s)-m; for i:=length(s)-m to length(s)-2 do c[i]:=i+1; i:=-1; repeat inc(i); until compare(fse(s[e],i,mo),s[o])=1; for y:=1 to m do        begin s[length(s)-y]:=fse(s[e],i+y-1,mo); if y=1 then if getordtype(s[length(s)-y])=2 then inc(c1); if (y<3) and (getordtype(s[length(s)-y])=2) then l[length(s)-y]:=true else l[length(s)-y]:=false; end; e:=c[e]+m-1; end else e:=c[e]; until c[e]=-1; until n=0; end;

procedure TForm1.Button1Click(Sender: TObject); begin st:='<7>3,<<11>12,<1>8,<<20>30,6>10>5'; st1:='<7>3,<1>500000'; //st:='0'; //st1:=lbeo(st); //st1:=ilbeo(st); //st1:=isobe(st); //st1:=isobewilbeo(st);

//st:='<1+1+1+1+1+1+1>1+1+1,<<1+1+1+1+1+1+1+1+1+1+1>1+1+1+1+1+1+1+1+1+1+1+1,<1>1+1+1+1+1+1+1+1,<<1+1>1+1+1,1+1+1+1+1+1>1+1+1+1+1+1+1+1+1+1>1+1+1+1+1'; //st1:='<1+1+1+1+1+1+1>1+1+1,<1>1+1+1+1+1';

//st:='(<1+1+1+1+1+1+1>1+1+1,<1>1+1+1+1+1)'; //st1:='(<1+1+1+1+1+1+1>1+1+1,<<1+1+1+1+1+1+1+1+1+1+1>1+1+1+1+1+1+1+1+1+1+1+1,<1>1+1+1+1+1+1+1+1,<<1+1>1+1+1,1+1+1+1+1+1>1+1+1+1+1+1+1+1+1+1>1+1+1+1+1)';

//st:='(<1>(<1+1>1),1)'; //st1:='(<1+1>1)';

{st:='(<<1+1+1>1+1+1+1>1+1+1+1+1+1+1+1,1+1+1+1+1+1)'; st:='(<<1>1>1,1)'; st:='(<1>1+1)';

st:=fse(st,0);}

//e:=compare('(<1>1,(((((((((((1))))))))))))','(((((((((((1))))))))))))'); //e:=compare('(<1>1)','(((((1)))))'); //e:=compare('(<<<<1>1>1>1>1)','(<<<1>1>1>1)');

//st:=fse('(<<1>1>1,(<<((<1>1)+1)>1>1)+1)',9); //st:=fse('(<1>1)',15); //st:=sf('(<1>1,(<1>1,(<1>1,(<1>1))))'); //form1.Edit1.Text:=st; //form1.Edit1.Refresh;

//st:=sf('(<(<(<(<(<(<(<(<(<((<<((<1>1))>1>1)+1)>1)>1)>1)>1)>1)>1)>1)>1)>1)'); //e:=compare('(<(<(<(<(<(<(<(<(<((<<1>1>1)+1)>1)>1)>1)>1)>1)>1)>1)>1)>1)','(<(<(<(<(<(<(<(<(<(<<1>1>1)>1)>1)>1)>1)>1)>1)>1)>1)>1)'); //e:=compare('(<(<(<(<(1)+1>1)>1)>1)>1)','(<(<(<(<(1)+1+1>1)>1)>1)>1)');

fss:=6;           // fundamental sequence system clested:=true;    // clested

st:=sf('(<(<<1>1>1)>1)'); st:=fse('(<(<<1>1>1)+1>1)',1,true); st:=sf(st);

setlength(s,2); setlength(l,2); setlength(c,2);

s[0]:='0'; l[0]:=false; c[0]:=-1;

s[1]:='BHO'; //s[1]:='(<1>1)'; l[1]:=true; c[1]:=0;

mo:=true;         // modified m:=8; fsc:=0; levelup(1); levelup(1); levelup(1); levelup(1); levelup(1); levelup(1); levelup(1); levelup(1); levelup(1); levelup(1); levelup(1); //levelup(1);

{assignfile(f,'D:\Delphi\Ord2\1.txt'); rewrite(f); e:=1; repeat writeln(f,s[e]); e:=c[e]; until e=-1; closefile(f);} end;

end.