# File: RAList.g Peter Jipsen # Version 0 Date: 24-1-97 # # Previously RALib.g Version 1.0 7-21-95 # # This GAP file contains routines to produce and access a library of small # relation algebras and generalisations there of. The general internal # datastructure for these algebras is a 3-dim list of booleans that # represents the ternary relation i;j >= k for atoms i,j,k. # Thus an n-atom algebra requires n^3 bits of memory. Of course # many improvements are possible, but for simplicity and generality # only this format will be used by the routines in this file. Rops:=rec(); ThinPR := function(argl) # # ThinPR( , [c:Int/Matrix], [z:Int/Matrix] ) # # Return thin algebra of type s,c,z. # "Thin" means products of diversity atoms are as small as possible. # s is a list. s[i] is the number of symmetric (nonidentity) # atoms for the identity atom i. # c is a lower triangular matrix. For i1 then c:=argl[2]; else c:=List([1..n],x->List([1..x],y->0)); fi; if Length(argl)>2 then z:=argl[3]; else z:=List(s,x->List(s,y->0)); fi; if IsInt(c) then c:=[[c]];fi; if IsInt(z) then z:=[[z]];fi; if Length(Set([Length(s),Length(c),Length(z),Length(z[1])])) <> 1 then Error("Incorrect type"); fi; A:=rec(); ### Record structure of an algebra: A.isDomain:=true; # May be used by GAP A.type:=[s,c,z]; # Type information n:=Length(s)+Sum(s)+2*Sum(Flat(c))+Sum(Flat(z)); # Total number of atoms fix:=List([1..n],x->List([1..n],y->BlistList([1..n],[]))); #A.fixed tab:=Copy(fix); #A.table A.id:=[1..Length(s)]; #identity atoms A.di:=[Length(s)+1..n]; #diversity atoms A.co:=[]; # A.co[i] is converse of atom i, 0 if i has no converse A.name:=""; namestr := "abcdefghopqrstuvwxyz****************************************"; convstr := "ABCDEFGHOPQRSTUVWXYZ****************************************"; idenstr := "IJKLMN******************************************************"; for i in A.id do tab[i][i][i]:=true; A.co[i]:=i; A.name[i]:=idenstr[i]; od; p:=Length(A.id)+1; q:=1; for k in [1..Length(s)] do for i in [1..s[k]] do tab[p][k][p]:=true; tab[k][p][p]:=true; tab[p][p][k]:=true; A.co[p]:=p; A.name[p]:=namestr[q]; q:=q+1; p:=p+1; od; for m in [1..k] do # p p+1 for i in [1..c[k][m]] do # k ---> m , k <--- m tab[p][m][p]:=true; tab[k][p][p]:=true; tab[p+1][k][p+1]:=true; tab[m][p+1][p+1]:=true; tab[p][p+1][k]:=true; tab[p+1][p][m]:=true; A.co[p]:=p+1; A.co[p+1]:=p; A.name[p]:=namestr[q]; A.name[p+1]:=convstr[q]; q:=q+1;p:=p+2; od; # and now the elements with no converse... for i in [1..z[k][m]] do tab[p][m][p]:=true; tab[k][p][p]:=true; A.co[p]:=0; A.name[p]:=namestr[q]; q:=q+1; p:=p+1; od; if k<>m then for i in [1..z[m][k]] do tab[p][k][p]:=true; tab[m][p][p]:=true; A.co[p]:=0; A.name[p]:=namestr[q]; q:=q+1; p:=p+1; od; fi; od; od; for i in [1..n] do for j in [1..n] do for k in A.id do # products with id-atoms are fixed fix[i][j][k]:=true;fix[i][k][j]:=true;fix[k][i][j]:=true; od; k:=1; while not tab[i][k][i] do k:=k+1; od; # k = ran(i) if not tab[k][j][j] then # if k <> dom(j) then fix[i][j]:=BlistList([1..n],[1..n]); # i;j = zero is fixed fi; od; od; A.table:=tab; A.fixed:=fix; A.operations:=Rops; return A; end; ThinR:=function(arg) local A; A:=ThinPR(arg); return A; end; FatR:=function(arg) local A,unit; A:=ThinPR(arg); unit:=BlistList([1..Size(A)],[1..Size(A)]); A.table:=List([1..Size(A)],i->List([1..Size(A)],j-> UnionBlist(A.table[i][j], DifferenceBlist(unit,A.fixed[i][j])))); return A; end; rp:=function(r,x,y) # # Given a 3-dim boolean list r and boolean lists x, y this function # computes the relative product x;y and returns the result as a boolean list. # local i,j,z; z:=ShallowCopy(x); SubtractBlist(z,z); i:=Position(x,true); while i <> false do j := Position(y,true); while j<> false do UniteBlist(z,r[i][j]); j:=Position(y,true,j); od; i:=Position(x,true,i); od; return z; end; rpab:=function(r,a,b) # # Same as above, but a,b are atoms (indices) so this routine is faster # if a<>0 and b<>0 then return ShallowCopy(r[a][b]); fi; return DifferenceBlist(r[1][1],r[1][1]); # if a or b is 0, return end; # blist with all entries false. rpax:=function(r,a,x) local i,z; i:=Position(x,true); if i=false then return DifferenceBlist(x,x); fi; z:=ShallowCopy(r[a][i]); i:=Position(x,true,i); while i <> false do UniteBlist(z,r[a][i]); i:=Position(x,true,i); od; return z; end; rpxa:=function(r,x,a) local i,z; i:=Position(x,true); if i=false then return DifferenceBlist(x,x); fi; z:=ShallowCopy(r[i][a]); i:=Position(x,true,i); while i <> false do UniteBlist(z,r[i][a]); i:=Position(x,true,i); od; return z; end; ProductR:=function(A,x,y) # # This routine computes the relative product and produces # readable output. It is meant for interactive use. # Example: if r is a 3-dim boolean list, # ProductR(r,1,2) = 1;2 # ProductR(r,[1,2],3) = (1+2);3 (+ is boolean join) # ProductR(r,[1,2],[1,2]) = (1+2);(1+2) # local r; if IsRec(A) then r:=A.table; else r:=A; fi; if IsBlist(x) then if IsBlist(y) then return rp(r,x,y); elif IsInt(y) then return rpxa(r,x,y); else return ListBlist([1..Length(r)], rp(r,x,BlistList([1..Length(r)],y))); fi; elif IsInt(x) then if IsBlist(y) then return rpax(r,x,y); elif IsInt(y) then return ListBlist([1..Length(r)],r[x][y]); else return ListBlist([1..Length(r)], rpax(r,x,BlistList([1..Length(r)],y))); fi; elif IsBlist(y) then return ListBlist([1..Length(r)], rp(r,BlistList([1..Length(r)],x),y)); elif IsInt(y) then return ListBlist([1..Length(r)], rpxa(r,BlistList([1..Length(r)],x),y)); else return ListBlist([1..Length(r)], rp(r,BlistList([1..Length(r)],x), BlistList([1..Length(r)],y))); fi; end; RightConj:=function(A) # # Compute the right conjugate of A.table and store it a A.rctable # local rc,t,m,i,j; if IsRec(A) then if IsBound(A.rctable) then return A.rctable; fi; t:=A.table; else t:=A; fi; m := [ 1 .. Length(t) ]; rc:=[]; for i in m do rc[i] := [ ]; for j in m do rc[i][j] := t[i]{m}[j]; od; od; if IsRec(A) then A.rctable:=rc; fi; return rc; end; LeftConj:=function(A) # # Compute the left conjugate of A.table and store it as A.lctable # local lc,t,m,i,j,k; if IsRec(A) then if IsBound(A.lctable) then return A.lctable; fi; t:=A.table; else t:=A; fi; m := [ 1 .. Length(t) ]; lc:=[]; for i in m do lc[i] := [ ]; for j in m do lc[i][j] := []; for k in m do lc[i][j][k]:=t[k][j][i]; od; od; od; if IsRec(A) then A.lctable:=lc; fi; return lc; end; IsIdempotent:=function(A) # # Test if algebra is (semi)idempotent ( i <= i;i ) # local i; if IsBound(A.isIdempotent) then return A.isIdempotent; fi; for i in [1..Size(A)] do if not A.table[i][i][i] then return false; fi; od; A.isIdempotent:=true; return true; end; IsCommutative:=function(A) # # Test if algebra is commutative # local i,j,n,t; if IsBound(A.isCommutative) then return A.isCommutative; fi; t:=A.table; n:=Length(t); for i in [1..n] do for j in [i+1..n] do if t[i][j]<>t[j][i] then return false; fi; od; od; A.isCommutative:=true; return true; end; IsAssociative:=function(A) # # Test if an algebra has an associative operation table i.e. (i;j);k=i;(j;k) # local i,j,k,n,t,empty; if IsRec(A) then if IsBound(A.isAssociative) then return A.isAssociative; fi; t:=A.table; else t:=A; fi; n:=Length(t); empty:=BlistList([1..n],[]); for i in [1..n] do for j in [1..n] do if t[i][j]<>empty then for k in [1..n] do if rpxa(t,t[i][j],k) <> rpax(t,i,t[j][k]) then return false; fi; od; fi;od; od; if IsRec(A) then A.isAssociative:=true; fi; return true; end; IsEuclidean:=function(A) # # Test if algebra is euclidean: (i rc j) ; k <= i rc (j ; k) # local i,j,k,n,rc,t; if IsRec(A) then if IsBound(A.isEuclidean) then return A.isEuclidean; fi; t:=A.table; else t:=A; fi; n:=Length(t); rc:=RightConj(t); for i in [1..n] do for j in [1..n] do for k in [1..n] do if not IsSubsetBlist(rpax(rc,i,t[j][k]), rpxa(t,rc[i][j],k)) then return false; fi; od; od; od; if IsRec(A) then A.isEuclidean:=true; fi; return true; end; IsLinear:=function(A) # # Test if algebra is linear: (i rc j) ; k + (j rc i) rc z = i rc (j ; k) # local i,j,k,n,rc,t; if IsBound(A.isLinear) then return A.isLinear; fi; t:=A.table; n:=Length(t); rc:=RightConj(t); for i in [1..n] do for j in [1..n] do for k in [1..n] do if UnionBlist(rpxa(t,rc[i][j],k),rpxa(rc,rc[j][i],k)) <>rpax(rc,i,t[j][k]) then Print("fails at [i,j,k] = ",[i,j,k],"\n"); return false; fi; od; od; od; A.isLinear:=true; return true; end; # # Define operation record for algebras # Rops.Size:=function(A) # This actually returns the number of atoms of the algebra. return Length(A.table); end; charstr := "123456789abcdefghijklmnopqrstuvwxyz*****************************"; ElementStr:=function(A, a) local i,st; if SizeBlist(a)=0 then return "."; fi; st:=""; for i in [1..Length(a)] do if a[i] then Add(st,A.name[i]); fi; od; return String(st); end; Alg2Str := function( A ) # # prints the operation table of A. # local i, j, n, l, m, st; # find largest element in each column n := Length(A.table); l := [ ]; m := List( [ 1 .. n], x -> [ 1 .. n ] ); for i in [ 1 .. n ] do for j in [ 1 .. n ] do m[j][i] := Length( ElementStr( A, A.table[i][j] ) ); od; od; for i in [ 1 .. n ] do Add( l, Maximum( m[i] ) ); od; st:=List([1..n],x->""); for i in [1..n] do for j in [1..n] do Append( st[i], Concatenation(String( "", QuoInt( l[j]-m[j][i], 2 ) ), ElementStr( A, A.table[i][j] ), String( "", l[j]-m[j][i]-QuoInt( l[j]-m[j][i], 2 ) + 1 ) ) ); od; od; return st; end; QuoteStr:=s->String(Concatenation("\n\"",s,"\"")); # Return table as list of row-strings TableStr:=t->String(List(Alg2Str(t),x->QuoteStr(x))); PrintAlgR := function( arg ) # # prints the operation table of A. # local i,A,fname; if Length(arg)=1 then A:=arg[1]; Print(String(A.name),"\n"); for i in Alg2Str(A) do Print(i,"\n"); od; else A:=arg[2]; fname:=arg[1]; AppendTo(fname,String(A.name),"\n"); for i in Alg2Str(A) do AppendTo(fname,i,"\n"); od; fi; end; PrintWideR:=function(l) local i,j,k,n,nt,nr,m,r; n:=Length(l[1].table); m:=(n-1)*(n+1)+4; nt:=QuoInt(80,m); #linelength=80 nr:=QuoInt(Length(l),nt); for r in [0..nr] do #each row of algebras for i in [1..n] do #each line for j in [1..nt] do #each algebra in the row if IsBound(l[r*nt+j]) then Print(Alg2Str(l[r*nt+j])[i]); Print("| "); fi; od; Print("\n"); od; Print("----------------------------------------------------------\n"); od; end; Rops.Print:=function(A) # Print the algebra, depending on whether it is a RA,UR,SeA,BRM,... local st,n,l2s; l2s:=function(li) local s; if Length(li)=1 then if IsList(li[1]) then s:=String(li[1][1]); else s:=String(li[1]); fi; else s:=String(li); fi; return Filtered(s,x->x<>' '); end; n:=Length(A.table); if not IsBound(A.type) or A.type=false then Print("\nUR(",TableStr(A),")"); #unital residuated algebra elif A.id=[] then Print("\nRalg(",TableStr(A),")"); #residuated algebra elif Set(Flat(A.type[3]))=[0] then if IsAssociative(A) then st:="\nRA("; #relation algebra else st:="\nNA("; #nonassociative relation alg fi; Print(st,TableStr(A),")"); else if IsAssociative(A) then if IsEuclidean(A) then st:="\nSeA("; #sequential algebra else st:="\nBRM("; #balanced residuated monoid fi; else if IsEuclidean(A) then st:="\nBEUR("; #balanced euclidean ur-alg else st:="\nBUR("; #balanced ur-algebra fi; fi; Print(st,TableStr(A),")"); fi; end; ontable:=function( t, prm ) # # Return the table t rearranged according to permutation prm. # local i,j,k,n,tt; tt:=Copy(t); n:=Length(tt); for i in [ 1 .. n ] do for j in [ 1 .. n ] do for k in [ 1 .. n ] do tt[i][j][k] := t[i^prm][j^prm][k^prm]; od; od; od; return tt; end; onTablePairs:=function( tp, prm ) # # Return pair of tables tp rearranged according to prm. # return [ontable(tp[1],prm),ontable(tp[2],prm)]; end; GeneratorsR := function( typ ) # # Returns generators for the automorphism group of typ. # local gens,k,m,p,s,c,z; s:=typ[1]; c:=typ[2]; z:=typ[3]; gens:=[]; p:=Length(s); for k in [1..Length(s)] do Append(gens,List([2..s[k]],x->(p+1,p+x))); p:=p+s[k]; for m in [1..k] do if m=k and c[k][m]>0 then Add(gens,(p+1,p+2)); fi; Append(gens,List([2..c[k][m]],x->(p+1,p+2*x-1)(p+2,p+2*x))); p:=p+2*c[k][m]; Append(gens,List([p+2..p+z[k][m]],x->(p+1,x))); p:=p+2*z[k][m]; if m(p+1,x))); p:=p+2*z[m][k]; fi; od; od; return gens; end; InfoListR:=Ignore; ListR := function(arg) # # Find the next associative euclidean algebra with sl<=rl=ru<=su; # Return algebra if "one" is true, else continue searching and return list # of all algebras. Return [] if none found. # local i,j,k,n,rl,ru,algs,unq,uncq,deq,decq,unp,zero,unit,backtr,genlist, A,B,backtrack,completetable,isnevercanon,flags,initflags, inc,exc,co,include,exclude,grp,cyc,eucf,isof,onef,decf, integ,idemp,idempf,commu,commuf,assoc,assocf,eucli,euclif, printf,nosub,nosubf,savef,fname,user,userf,linea,lineaf,during, nexttriple; initflags:=function() Set(flags); idempf:="id" in flags; commuf:="co" in flags; assocf:="as" in flags; euclif:="eu" in flags; lineaf:="li" in flags; nosubf:="no" in flags; isof :="iso" in flags; onef :="one" in flags; decf :="dec" in flags; printf:="pr" in flags; savef :="sa" in flags; userf :="user" in flags; fname :="algs"; if savef then AppendTo(fname,"#",flags,"\nalgs:=["); fi; end; isnevercanon := function() # # returns true if there is no canonical completion of [rl,ru] # (reduced time for AllR(3) by 66% over version that computes orbit) local p,ok; for p in unp do ok:=true; i:=1; while ok and i <= n do j:=1; while ok and j <= n do k:=1; while ok and k <= n do if not rl[i][j][k] then if ru[i^p][j^p][k^p] then ok:=false; # go to next perm fi; elif not ru[i^p][j^p][k^p] then return true; fi; k:=k+1; od; j:=j+1; od; i:=i+1; od; od; return false; end; integ:=function(a,b) # Check a;b is nonzero. local s; s:=SizeBlist(ru[a][b]); if s>=1 then if s=1 and rl[a][b]=zero then include(a,b,Position(ru[a][b],true)); fi; return true; fi; return false; end; assoc:=function() # Check partial algebra could still have an associative completion. local q,i,j,k,ql,rll,rur,rul,rlr,u,v,l,m; ql:=[]; for q in unq do i:=q[1]; j:=q[2]; k:=q[3]; # if rl[i][j]<>zero ?? rl[j][k]<>zero then rll:=rpxa(rl,rl[i][j],k); rur:=rpax(ru,i,ru[j][k]); if not IsSubsetBlist(rur,rll) then return false; fi; rul:=rpxa(ru,ru[i][j],k); rlr:=rpax(rl,i,rl[j][k]); if not IsSubsetBlist(rul,rlr) then return false; fi; if rll=rul and rlr=rur then Add(ql,q); fi; u:=ShallowCopy(rul); SubtractBlist(u,rur); if u<>zero then v:=rl[i][j]; l:=Position(u,true); while l<>false do m:=Position(v,true); while m<>false do if ru[m][k][l] and not rl[m][k][l] then exclude(m,k,l); fi; m:=Position(v,true,m); od; l:=Position(u,true,l); od; fi; # fi; od; if ql<>[] then SubtractSet(unq,ql); Append(deq,ql); fi; return true; end; eucli:=function() # Check partial algebra could still have a euclidean completion. local q,i,j,k,cl,cu,cql,rll,rur; if uncq<>[] then cl:=RightConj(rl); cu:=RightConj(ru); cql:=[]; for q in uncq do i:=q[1]; j:=q[2]; k:=q[3]; if cl[i][j]<>zero then rll:=rpxa(rl,cl[i][j],k); rur:=rpax(cu,i,ru[j][k]); if not IsSubsetBlist(rur,rll) then return false; fi; if rll=rpxa(ru,cu[i][j],k) and rur=rpax(cl,i,rl[j][k]) then Add(cql,q); fi; fi; od; if cql<>[] then SubtractSet(uncq,cql); Append(decq,cql); fi; fi; return true; end; linea:=function() # Check partial algebra could still have a linear completion. local q,i,j,k,cl,cu,cql,rll,rur,rlr,rul; if uncq<>[] then cl:=RightConj(rl); cu:=RightConj(ru); cql:=[]; for q in uncq do i:=q[1]; j:=q[2]; k:=q[3]; # if cl[i][j]<>zero then rll:=UnionBlist(rpxa(rl,cl[i][j],k),rpxa(cl,cl[j][i],k)); rur:=rpax(cu,i,ru[j][k]); if not IsSubsetBlist(rur,rll) then return false; fi; rul:=UnionBlist(rpxa(ru,cu[i][j],k),rpxa(cu,cu[j][i],k)); rlr:=rpax(cl,i,rl[j][k]); if not IsSubsetBlist(rul,rlr) then return false; fi; if rll=rul and rlr=rur then Add(cql,q); fi; # fi; od; if cql<>[] then SubtractSet(uncq,cql); Append(decq,cql); fi; fi; return true; end; user:=function() return true; end; backtrack:=function(oldnq,oldncq,oldinc,oldexc) # Restore various list to the state they were before the recursive call. local c; backtr:=true; if oldnq0 and not rl[co[a]][c][b] then rl[co[a]][c][b]:=true; Add(inc,[co[a],c,b]); fi; if co[b]<>0 and not rl[c][co[b]][a] then rl[c][co[b]][a]:=true; Add(inc,[c,co[b],a]); fi; if co[a]<>0 and co[c]<>0 and not rl[b][co[c]][co[a]] then rl[b][co[c]][co[a]]:=true; Add(inc,[b,co[c],co[a]]); fi; if co[c]<>0 and co[b]<>0 and not rl[co[c]][a][co[b]] then rl[co[c]][a][co[b]]:=true; Add(inc,[co[c],a,co[b]]); fi; if co[a]<>0 and co[b]<>0 and co[c]<>0 and not rl[co[b]][co[a]][co[c]] then rl[co[b]][co[a]][co[c]]:=true; Add(inc,[co[b],co[a],co[c]]); fi; if commuf and not rl[b][a][c] then # make commutative include(b,a,c); fi; end; exclude:=function(a,b,c) # Delete the cycle [a,b,c] from the partial algebra ru[a][b][c]:=false; Add(exc,[a,b,c]); if co[a]<>0 and ru[co[a]][c][b] then ru[co[a]][c][b]:=false; Add(exc,[co[a],c,b]); fi; if co[b]<>0 and ru[c][co[b]][a] then ru[c][co[b]][a]:=false; Add(exc,[c,co[b],a]); fi; if co[a]<>0 and co[c]<>0 and ru[b][co[c]][co[a]] then ru[b][co[c]][co[a]]:=false; Add(exc,[b,co[c],co[a]]); fi; if co[c]<>0 and co[b]<>0 and ru[co[c]][a][co[b]] then ru[co[c]][a][co[b]]:=false; Add(exc,[co[c],a,co[b]]); fi; if co[a]<>0 and co[b]<>0 and co[c]<>0 and ru[co[b]][co[a]][co[c]] then ru[co[b]][co[a]][co[c]]:=false; Add(exc,[co[b],co[a],co[c]]); fi; if commuf and ru[b][a][c] then # make commutative exclude(b,a,c); fi; end; nexttriple:=function(a,b,c) while a<=n and rl[a][b][c]=ru[a][b][c] do c:=c+1; if c>n then c:=1; b:=b+1; if b>n then b:=1; a:=a+1; fi; fi; od; return [a,b,c]; end; completetable:=function(a,b,c) # Try including, then excluding the next undecided cycle and # do a recursive call in each case. local i,j,k,oldnq,oldncq,oldinc,oldexc,ok,abc; if not( onef and Length(algs)>=1 ) and ( isof or not isnevercanon() ) then # search for next undecided triple abc:=nexttriple(a,b,c); a:=abc[1];b:=abc[2];c:=abc[3]; if a<=n then oldnq:=Length(deq); oldncq:=Length(decq); oldinc:=Length(inc); oldexc:=Length(exc); if not decf then if A.table[a][b][c]=false or backtr then exclude(a,b,c); ok:=integ(a,b); if userf and ok then ok:=user();fi; if assocf and ok then ok:=assoc();fi; if euclif and ok then ok:=eucli();fi; if lineaf and ok then ok:=linea();fi; if ok then completetable(a,b,c);fi; backtrack(oldnq,oldncq,oldinc,oldexc); fi; include(a,b,c); ok:= not (onef and Length(algs)>=1); #### major hack if userf and ok then ok:=user();fi; if assocf and ok then ok:=assoc();fi; if euclif and ok then ok:=eucli();fi; if lineaf and ok then ok:=linea();fi; if ok then completetable(a,b,c);fi; backtrack(oldnq,oldncq,oldinc,oldexc); else if A.table[a][b][c]=true or backtr then include(a,b,c); ok:=true; if userf and ok then ok:=user();fi; if assocf and ok then ok:=assoc();fi; if euclif and ok then ok:=eucli();fi; if lineaf and ok then ok:=linea();fi; if ok then completetable(a,b,c);fi; backtrack(oldnq,oldncq,oldinc,oldexc); fi; exclude(a,b,c); ok:=integ(a,b) and not (onef and Length(algs)>=1); #### major hack if userf and ok then ok:=user();fi; if assocf and ok then ok:=assoc();fi; if euclif and ok then ok:=eucli();fi; if lineaf and ok then ok:=linea();fi; if ok then completetable(a,b,c);fi; backtrack(oldnq,oldncq,oldinc,oldexc); fi; else # table is complete if rl<>A.table or not onef then B:=rec(isDomain:=true,type:=A.type, table:=Copy(rl),fixed:=A.fixed,id:=A.id,di:=A.di,co:=A.co, name:=A.name,operations:=Rops); Add(algs,B); if printf then Print(TableStr(B.table),"\n"); else Print(Length(algs),"\r"); fi; if savef then AppendTo(fname,"\"",TableStr(B.table),"\",\n"); fi; fi; fi; fi; end; A:=arg[1]; flags:=arg{[2..Length(arg)]}; for i in [1..Length(flags)] do if IsString(flags[i]) then flags[i]:=[flags[i]]; fi; od; flags:=Concatenation(flags); initflags(); n:=Length(A.table); co:=A.co; eucf:=ForAny([1..n], x->co[x]=0); euclif:=euclif and (eucf or not assocf); inc:=[]; exc:=[]; zero:=BlistList([1..n],[]); unit:=BlistList([1..n],[1..n]); rl:=List([1..n],i->List([1..n],j-> IntersectionBlist(A.table[i][j],A.fixed[i][j]))); ru:=List([1..n],i->List([1..n],j->UnionBlist(A.table[i][j], DifferenceBlist(unit,A.fixed[i][j])))); if idempf then for i in [1..n] do if not ru[i][i][i] then return []; fi; rl[i][i][i]:=true; od; fi; if not isof then genlist:=Group( Stabilizer( Group(GeneratorsR(A.type),()), [rl,ru], onTablePairs ) ).generators; Print(genlist); unp:=Elements(Group(genlist,())); RemoveSet(unp,()); fi; if not IsBound(A.dom) then A.dom:=List([1..n],x->n); A.ran:=List([1..n],x->n); fi; unq:=[]; uncq:=[]; if assocf then for i in [1..n] do for j in [1..n] do if A.ran[i]=A.dom[j] then for k in [1..n] do if A.ran[j]=A.dom[k] then Add(unq,[i,j,k]); fi; od; fi; od; od; Print(Length(unq),"=Length(unq)\n"); fi; if euclif or lineaf then for i in [1..n] do for j in [1..n] do if A.dom[i]=A.dom[j] then for k in [1..n] do if A.ran[j]=A.dom[k] then Add(uncq,[i,j,k]); fi; od; fi; od; od; Print(Length(uncq),"=Length(uncq)\n"); fi; deq:=[]; decq:=[]; backtr:=false; algs:=[]; completetable(1,1,1); if onef then if algs=[] then return false; else return algs[1];fi; fi; return algs; end; RAf:=["as","eu"]; NextR:=function(A) # # Find the next algebra. Return false if none found. # Repeated execution of A:=NextR(A); starting with A:=ThinR(s,c,z) # generates all algebras of that type. # return ListR(A,["one","as","eu"]); end; AllR:=function(arg) # # Find all algebras of type s,c,z (see ThinPR). # local A; if IsRec(arg[1]) then A:=arg[1]; else A:=ThinPR(arg); fi; return ListR(A,["as","eu"]); end; PatchR:=function(arg) # Build partial nonintegral algebra by patching list of integral # algebras along the diagonal and specifying no. of nondiagonal atoms. local A,al,s,c,z,x,i,j,k,m,unit; al:=arg[1]; # List of (integal?) algebras c:=arg[2]; # Lower triangular matrix of size Length(al)-1 if Length(arg)>2 then z:=[arg[3]]; # Matrix of size Length(al) else z:=[]; fi; s:=[List(al,x->x.type[1][1])]; c:=Concatenation([[]],c); c:=[List([1..Length(al)],x->Concatenation(c[x],al[x].type[2][1]))]; A:=ThinPR(Concatenation(s,c,z)); # copy al[i] into A.table[x][y] where x,y have domain and range id[i] unit:=BlistList([1..Size(A)],[1..Size(A)]); for i in [1..Length(A.id)] do x:=ListBlist([1..Size(A)], # compute x := i;1;i rpxa(A.table,rpax(A.table,A.id[i],unit),A.id[i])); IntersectSet(x,A.di); for j in al[i].di do for k in al[i].di do for m in al[i].di do A.table[x[j]][x[k]][x[m]]:=al[i].table[j][k][m]; A.fixed[x[j]][x[k]][x[m]]:=true; od;od;od;od; return A; end; IsTransitive := function(A,a) # # Check if blist a is a transitive element of A. # return IsSubsetBlist(a,ProductR(A.table,a,a)); end; IdentityR:=function(A) # # Find the identity atoms of A.table # local i,j,k,n,s,t,ok; if IsRec(A) then if IsBound(A.id) then return A.id; fi; t:=A.table; else t:=A; fi; s:=[]; n:=Length(t); for i in [1..n] do ok:=true; j:=1; while ok and j<=n do ok:=t[i][j][j] and t[j][i][j]; k:=j+1; while ok and k<=n do ok:=not(t[i][j][k] or t[i][k][j] or t[j][i][k] or t[k][i][j]); k:=k+1; od; j:=j+1; od; if ok then Add(s,i); fi; od; if IsRec(A) then A.id:=s; fi; return s; end; ConjRel:=function(A) # # Return list of pairs of atoms [i,j] such that (i;j)id <> 0 # local i,j,k,n,c,ibl,t,zero; if IsRec(A) then t:=A.table; else t:=A; fi; c:=[]; n:=Length(t); ibl:=BlistList([1..n],IdentityR(A)); zero:=BlistList([1..n],[]); for i in [1..n] do for j in [1..n] do if IntersectionBlist(t[i][j],ibl)<>zero then AddSet(c,[i,j]); fi; od; od; return c; end; IsSymmetricRel:=function(rel) # # Test if list of pairs is a symmetric relation. # local i,ok; Set(rel); i:=1; ok:=true; while ok and i<=Length(rel) do ok:=[rel[i][2],rel[i][1]] in rel; i:=i+1; od; return ok; end; IsWellDefined:=function(rel) # # Test if list of pair is a functional relation. # local i,ok; Set(rel); i:=1; ok:=true; while ok and i<=Length(rel)-1 do ok:=rel[i][1]<>rel[i+1][1]; od; return ok; end; ConverseList:=function(A) # # Compute list of converses A.co[j] is converse of j. # If converse map is not an involution on atoms then return false. # local rel, i; if IsBound(A.co) then return A.co; fi; rel:=ConjRel(A); if IsSymmetricRel(rel) and IsWellDefined(rel) then A.co:=[]; for i in rel do A.co[i[1]]:=i[2]; od; for i in [1..Size(A)] do if not IsBound(A.co[i]) then A.co[i]:=0; fi; od; return A.co; else return false; fi; end; IsBalanced:=function(A) return ConverseList(A)<>false; end; TypeR:=function(A) # # Compute the parameters s,c,z for A (but atoms may not be in # canonical order). # local i,j,k,t,unit,typ,x; if IsBound(A.type) then return A.type; fi; A.id:=IdentityR(A); A.di:=Difference([1..Size(A)],A.id); unit:=BlistList([1..Size(A)],[1..Size(A)]); t:=A.table; typ:=[[],List(A.id,x->[]),List(A.id,x->[])]; if ConverseList(A)<>false then for i in [1..Length(A.id)] do for j in [1..Length(A.id)] do x:=ListBlist([1..Size(A)], rpxa(t,rpax(t,A.id[i],unit),A.id[j])); IntersectSet(x,A.di); if i=j then typ[1][i]:=Number(x,y->A.co[y]=y); fi; typ[3][i][j]:=Number(x,y->A.co[y]=0); typ[2][i][j]:=Number(x,y->A.co[y]<>y and A.co[y]<>0); od; od; else typ:=false; fi; A.type:=typ; return typ; end; Relativized:=function(A,a) # # Compute the table and type for the relativization of A by blist a. # local Aa; Aa:=rec(isDomain:=true); Aa.table:=A.table{a}{a}{a}; Aa.operations:=A.operations; Aa.type:=TypeR(Aa); Aa.name:=charstr{[1..Length(A.table)]}; return Aa; end; PrintListR := function(fname,l) local i; PrintTo(fname,""); for i in [1..Length(l)] do AppendTo(fname,"#",i,"\n"); PrintAlgR(fname,l[i]); AppendTo(fname,"#-------------------\n"); od; end; Makefiles:=function() # PrintListR("r1.txt",AllR(1)); # PrintListR("r2.txt",AllR(2)); # PrintListR("r3.txt",AllR(3)); # PrintListR("r01.txt",AllR(0,1)); # PrintListR("r11.txt",AllR(1,1)); # PrintListR("r02.txt",AllR(0,2)); # PrintListR("r001.txt",AllR(0,0,1)); # PrintListR("r101.txt",AllR(1,0,1)); # PrintListR("r011.txt",AllR(0,1,1)); # PrintListR("r002.txt",AllR(0,0,2)); # PrintListR("r102.txt",AllR(1,0,2)); PrintListR("r012.txt",AllR(0,1,2)); end;