# =========================================================================== # Tools for manipulating relation algebras # including weakening, restriction, product and intervals # of relation algebras # =========================================================================== # Look at the // # For formating purposes: interface(labelling=false); # STRUCTURE OF EXTENDED RELATION ALGEBRA # The structure contains # base: rel set # identity: rel (identity element for composition) # autoinverse: rel set # neighborhood: relxrel set # composition: relxrel -> rel set # upward: rel -> rel set # downward: rel -> rel set macro(base=1,identity=2,autoinverse=3,neighborhood=4,composition=5,up=6,down=7); defalg := proc (alg, abs, aie, aai, anb, acmp, aup, adn) local x, y, r, buf; global algebra, curalg; buf := curalg; curalg := alg; algebra[alg][base] := abs; algebra[alg][identity] := aie; algebra[alg][autoinverse] := aai; # terminates the definition of neighborhood; tricky but works algebra[alg][neighborhood] := anb; for r in anb do algebra[alg][neighborhood] := algebra[alg][neighborhood] union {[i(r[2]),i(r[1])]}; od; algebra[alg][composition] := acmp; # terminates the definition of composition using aXb = (b-1Xa-1)-1 # No more optimisation is really possible since we do not master # the order in sets (so, 3/4 of the table has to be provided) for x in algebra[alg][base] do for y in algebra[alg][base] do algebra[alg][composition][i(x),i(y)] := i(algebra[alg][composition][y,x]) od od; algebra[alg][up] := aup; algebra[alg][down] := adn; curalg := buf end: # this should be enhanced by: # autoinverse = inversioninvariant: x=x-1 # compositionidempotent: x*x=x # compositionleftinvariant: x*y=y # compositionrightinvariant: y*x=y # I conjecture: cri=clt-1 # =========================================================================== # INTERPRETATION OF ALGEBRAS # --------------------------------------------------------------------------- # inverse operator i := proc (x) global algebra; if type(x,set) then RETURN(map(i,x)) elif type(x,list) and nops(x) = 4 then RETURN([i(op(1,x)), i(op(3,x)), i(op(2,x)), i(op(4,x))]) # This may be dangerous elif not assigned(algebra[curalg][autoinverse]) then RETURN(('i')(x)) elif member(x,algebra[curalg][autoinverse]) then RETURN(x) elif type(x,function) and op(0,x) = ('i') then RETURN(op(1,x)) else RETURN(('i')(x)) fi end: # no ^-1 `print/i` := (x) -> x^i : # --------------------------------------------------------------------------- # neighborhood # neighborp answers NO when x=y neighborp := proc (alg, x, y) global algebra; member(eval([x, y]),algebra[alg][neighborhood]) or member(eval([y, x]),algebra[alg][neighborhood]) end: neighbors := proc (alg, x) local res, r; global algebra; res := {}; for r in algebra[alg][neighborhood] do if x=r[1] then res := res union {r[2]} elif x=r[2] then res := res union {r[1]} fi od; res end: succneighbors := proc(alg,x) local res, r; global algebra; res := {}; for r in algebra[alg][neighborhood] do if x=r[1] then res := res union {r[2]} fi od; res end: predneighbors := proc(alg,x) local res, r; global algebra; res := {}; for r in algebra[alg][neighborhood] do if x=r[2] then res := res union {r[1]} fi od; res end: # --------------------------------------------------------------------------- # composition compose := proc (alg, x, y) local z, w, res; global algebra; res := {}; if type(x,set) then if type(y,set) then for z in x do for w in y do res := res union algebra[alg][composition][z,w] od od else RETURN(`union`(seq(algebra[alg][composition][z,y],z = x))) fi elif type(y,set) then RETURN(`union`(seq(algebra[alg][composition][x,z],z = y))) elif x = algebra[alg][identity] then RETURN({y}) elif y = algebra[alg][identity] then RETURN({x}) else RETURN(algebra[alg][composition][x,y]) fi end: # cannot put the o in between # `print/compose` := (alg,x,y) -> o[alg](x,y) # --------------------------------------------------------------------------- # upward/downward conversion mapunion := proc (ll) local res, l; res := {}; for l in ll do res := res union l od; RETURN(res) end: conversion := proc (x, table) if type(x,set) then RETURN(mapunion(map(conversion,x,table))) elif type(x,function) then if op(0,x) = i then RETURN(i(conversion(op(1,x),table))) else RETURN(('conversion')(x,table)) fi else RETURN(table[x]) fi end: upward[alg] := (x) -> conversion(x,agebra[alg][up]): downward[alg] := (x) -> conversion(x,agebra[alg][down]): # =========================================================================== # TOOLS # --------------------------------------------------------------------------- # Put the printcompasarray := proc(alg) local algbase, M, buf, k, j; global algebra, curalg; buf := curalg; curalg := alg; algbase := algebra[alg][base] union i(algebra[alg][base]); M := array(1..nops(algbase)+1,1..nops(algbase)+1); M[1,1] := alg; for j from 1 to nops(algbase) do M[1,j+1] := op(j,algbase); od; for k from 1 to nops(algbase) do M[k+1,1] := op(k,algbase); for j from 1 to nops(algbase) do M[k+1,j+1] := compose(alg,op(k,algbase),op(j,algbase)); od od; print(M); curalg := buf; end: # --------------------------------------------------------------------------- # Prove that composition table entries are neighborhood checkneighborhood := proc(alg) local buf, cells, cc, toprocess, el, el2, x; global algebra, curalg; buf := curalg; curalg := alg; for el in entries(algebra[alg][composition]) do if nops(op(1,el)) > 1 then cc := op(1,el); # print(`***`.cc); toprocess := [op(1,cc)]; cc := {cc[2..nops(cc)]}; while cc <> {} and toprocess <> [] do el2 := toprocess[1]; # print(`--`.el2); toprocess := [toprocess[2..nops(toprocess)]]; for x in cc do if neighborp(alg,x,el2) then toprocess := [op(toprocess),x]; fi od; cc := cc minus {op(toprocess)}; od; if cc<>{} then curalg := buf; RETURN(false) fi fi; od; curalg := buf; RETURN(true); end: # --------------------------------------------------------------------------- # Simplify composition table simplifycomposition := proc(alg) local buf, cells, tradtable, count, continue, el, iel, x, cc, y; global algebra, curalg; tradtable := NULL; buf := curalg; curalg := alg; cells := {}; for el in entries(algebra[alg][composition]) do if nops(op(1,el)) > 1 then cells := cells union {op(1,el)} fi od; continue := true; count := 0; while continue do continue := false; # look for the first stuff with two elements for el in cells while not continue do # nops=2 maybe a problem if nops(el) = 2 then continue := true; # translate it into a new number count := count + 1; tradtable := tradtable,el; # rename cells # changing sets during affectation may be a problem cc := cells; cells := {}; iel := i(el); for x in cc do if x<>el and x<>iel then if basicincludedp(el,x) then cells := cells union {(x minus el) union {count}} elif basicincludedp(iel,x) then cells := cells union {(x minus iel) union {`i`(count)}} else cells := cells union {x} fi fi od; fi od; od; curalg := buf; RETURN(tradtable); end: # =========================================================================== # ALGEBRA GENERATION THROUGH INTERVALS # Note that following [Hirsch 1996] this could be implemented as a # matrix computation (but the matrix in Maple should then be circumvented) macro(xbyb=1,xbye=2,xeyb=3,xeye=4); # --------------------------------------------------------------------------- # base relations (WITH HIRSCH FORMULAS) # Note that following [Hirsch 1996] this could be implemented as a # matrix computation (but the matrix in Maple should then be circumvented) # it uses a relation rel holding between the extremities of an interval # (it does not have to be an order relation !). # This enables to generate the identity element [e r i(r) e] # and the possible relationship as those [r1 r2 r3 r4] such that: # r \in r1 o i(r3) r \in i(r1) o r2 # r \in r2 o i(r4) r \in i(r3) o r4 inferintervalrelations := proc(alg,rel) local rels, r1, r2, r3, r4, res; rels := algebra[alg][base] union i(algebra[alg][base]); res := {}; for r1 in rels do for r2 in rels do if member(rel,compose(alg,i(r1),r2)) then for r3 in rels do if member(rel,compose(alg,r1,i(r3))) then for r4 in rels do if member(rel,compose(alg,r2,i(r4))) and member(rel,compose(alg,i(r3),r4)) and not member(i([r1,r2,r3,r4]),res) then res := res union {[r1,r2,r3,r4]} fi od; fi od; fi od; od; RETURN(res) end: # --------------------------------------------------------------------------- # autoinverse inferinverse := proc(alg,qalg,relation) local quad; qalg[identity] := [alg[identity],relation,i(relation),alg[identity]]; qalg[autoinverse] := {}; for quad in qalg[base] do if i(quad) = quad then qalg[autoinverse] := qalg[autoinverse] union {quad} fi od end: # --------------------------------------------------------------------------- # neighborhood # This is the hopefully ultimate version. # It is quite specific to A13FP (how to generalise? by using the # generalisation from Ligozat in RFIA-98 paper). inferneighbors := proc(alg) local quad, pos, unc, possibles; global curalg, algebra; algebra[alg][neighborhood] := {}; unc := neighbors(curalg,uncomparable); possibles := algebra[alg][base] union i(algebra[alg][base]); for quad in possibles do #print(quad); for pos from xbyb to xeye do if quad[pos] <> uncomparable # for FP especially then algebra[alg][neighborhood] := algebra[alg][neighborhood] union applyneighbors(quad,pos,succneighbors(curalg,quad[pos]),possibles); else algebra[alg][neighborhood] := algebra[alg][neighborhood] union applyuncneighbors(quad,curalg,pos,possibles,unc); fi; od; od end: applyuncneighbors := proc(quad,curalg,pos,possibles,unc) local res, qq, r1, r2; res := {}; if pos = xbyb then for r1 in unc do for r2 in succneighbors(curalg,quad[xbye]) do qq := [r1,r2,quad[xeyb..xeye]]; if quad <> qq and member(qq,possibles) then res := res union {[quad,qq],[i(qq),i(quad)]}; fi od; for r2 in succneighbors(curalg,quad[xeyb]) do qq := [r1,quad[xbye],r2,quad[xeye]]; if quad <> qq and member(qq,possibles) then res := res union {[quad,qq],[i(qq),i(quad)]}; fi od; od; elif pos = xbye then for r1 in unc do for r2 in succneighbors(curalg,quad[xbyb]) do qq := [r2,r1,quad[xeyb..xeye]]; if quad <> qq and member(qq,possibles) then res := res union {[quad,qq],[i(qq),i(quad)]}; fi od; for r2 in succneighbors(curalg,quad[xeye]) do qq := [quad[xbyb],r1,quad[xeyb],r2]; if quad <> qq and member(qq,possibles) then res := res union {[quad,qq],[i(qq),i(quad)]}; fi od; od; elif pos = xeyb then for r1 in unc do for r2 in succneighbors(curalg,quad[xbyb]) do qq := [r2,quad[xbye],r1,quad[xeye]]; if quad <> qq and member(qq,possibles) then res := res union {[quad,qq],[i(qq),i(quad)]}; fi od; for r2 in succneighbors(curalg,quad[xeye]) do qq := [quad[xbyb..xbye],r1,r2]; if quad <> qq and member(qq,possibles) then res := res union {[quad,qq],[i(qq),i(quad)]}; fi od; od; elif pos = xeye then for r1 in unc do for r2 in succneighbors(curalg,quad[xbye]) do qq := [quad[xbyb],r2,quad[xeyb],r1]; if quad <> qq and member(qq,possibles) then res := res union {[quad,qq],[i(qq),i(quad)]}; fi od; for r2 in succneighbors(curalg,quad[xeyb]) do qq := [quad[xbyb..xbye],r2,r1]; if quad <> qq and member(qq,possibles) then res := res union {[quad,qq],[i(qq),i(quad)]}; fi od; od; fi; RETURN(res); end: applyneighbors := proc (quad, pos, neigh, possibles) local rel, j, res, qq; res := {}; for rel in neigh do qq := [seq(quad[j],j = 1..pos-1), rel, seq(quad[j],j=pos+1..4)]; if quad <> qq and member(qq,possibles) then res := res union {[quad,qq],[i(qq),i(quad)]}; fi od; RETURN(res) end: # THIS IS VERY RELATED TO FP applytwinneighbors := proc(quad,pos1,pos2,curalg,possibles) local res, r1, r2, qq, j; res := {}; for r1 in succneighbors(curalg,uncomparable) do for r2 in succneighbors(curalg,uncomparable) do qq := [seq(quad[j],j=xbyb..pos1-1),r1,seq(quad[j],j=pos1+1..pos2-1), r2,seq( quad[j], j=pos2+1..xeye)]; if quad <> qq and member(qq,possibles) then res := res union {[quad,qq]}; fi od; od; RETURN(res) end: # --------------------------------------------------------------------------- # composition table # Hirsch method intervalcomposition := proc(alg,target) local rels, r1, r2; global algebra; rels := algebra[target][base] union i(algebra[target][base]); for r1 in rels do for r2 in rels do algebra[target][composition][r1,r2] := composequadruples(alg,r1,r2,rels); od od end: composequadruples := proc(alg,r1,r2,rels) local x1,x2,x3,x4,res; res := {}; for x1 in compose(alg,r1[xbyb],r2[xbyb]) intersect compose(alg,r1[xbye],r2[xeyb]) do for x2 in compose(alg,r1[xbyb],r2[xbye]) intersect compose(alg,r1[xbye],r2[xeye]) do for x3 in compose(alg,r1[xeyb],r2[xbyb]) intersect compose(alg,r1[xeye],r2[xeyb]) do for x4 in compose(alg,r1[xeyb],r2[xbye]) intersect compose(alg,r1[xeye],r2[xeye]) do if member([x1,x2,x3,x4],rels) then res := res union {[x1,x2,x3,x4]} fi od od od od; RETURN(res); end: # --------------------------------------------------------------------------- # upward/downward operators # --------------------------------------------------------------------------- # all at once inferintervalalgebra := proc(source,target,relation) local buf, res, r; global algebra,curalg; buf := curalg; curalg := source; algebra[target][base] := inferintervalrelations(source,relation); inferinverse(algebra[source],algebra[target],relation); inferneighbors(target); intervalcomposition(curalg,target); curalg := buf; end: # --------------------------------------------------------------------------- # Finding pointisables in an interval algebra # This algorithm has not been proved but it has been # reasonably designed and find the correct SET of pointisable # (I checked by hand) for A13 # Beware: there are various number of pointisable in the # litterature: # [Van Beek & Cohen 1990]: 188 (according to O. Schmeltzer) # [Ladkin 1988]: 179 # [Van Beek 1990]: 187 (these are those that we found). pointisable := proc(alg) local res, r, x, rel, pos, res2; res := {}; for r in algebra[alg][base] union i(algebra[alg][base]) do res2 := {[seq({r[x]},x=xbyb..xeye)]}; for rel in res do pos := 0; for x from xbyb to xeye do if not member(r[x],rel[x]) then if pos = 0 then pos := x else pos := -1 fi fi; od; if pos > 0 then res2 := res2 union {[rel[xbyb..pos-1],rel[pos]union{r[pos]},rel[pos+1..xeye]]}; fi; od; res := res union res2; od; RETURN(res); end: # The convex relations corresponds to the intervals of the # neighborhood graph (according to [Noekel 1988]). # There are 83 convex relations for A13 # =========================================================================== # ALGEBRA GENERATION THROUGH RESTRICTION # A restriction is a set of relationship to preserve while # suppressing the others # The restriction of a algebra thus does the following # - suppresses the non present relationship from base and autoinverse # - suppresses the couples containing n.p.r. from neighborhood # - suppresses the composition table entries corresponding to n.p.r. # and suppresses form the image or remaining entries the n.p.r. restrictalgebra := proc(alg,restriction) local newalg, extrest, x, r1, r2, buf; global curalg; buf := curalg; curalg := alg; extrest := restriction union i(restriction); newalg[base] := algebra[alg][base] intersect extrest; extrest := newalg[base] union i(newalg[base]); if member(algebra[alg][identity],extrest) then newalg[identity] := algebra[alg][identity] else curalg := buf; ERROR(`The restriction is not an algebra`) fi; newalg[autoinverse] := algebra[alg][autoinverse] intersect extrest; # find an iterated union there newalg[neighborhood] := {}; for x in algebra[alg][neighborhood] do if member(x[1],extrest) and member(x[2],extrest) then newalg[neighborhood] := newalg[neighborhood] union {x} fi od; for r1 in extrest do for r2 in extrest do newalg[composition][r1,r2] := algebra[alg][composition][r1,r2] intersect extrest od od; curalg := buf; RETURN(newalg) end: # =========================================================================== # ALGEBRA COMPARISON # --------------------------------------------------------------------------- # renaming # I did not considered neighborhood here and this is bad # it must be added rename := proc(value,table) local j; if assigned(table[value]) then RETURN(table[value]) elif type(value,function) and op(0,value) = 'i' then RETURN('i'(rename(op(1,value),table))) elif type(value,list) #and nops(value) = 4 then RETURN(map(rename, value, table)) elif type(value,set) then RETURN(map(rename,value,table)) else RETURN(value) fi end: renamealgebra := proc(alg,table) local newalg, rels, r1, r2; newalg[base] := rename(alg[base],table); newalg[identity] := rename(alg[identity],table); newalg[autoinverse] := rename(alg[autoinverse],table); newalg[neighborhood] := rename(alg[neighborhood],table); rels := alg[base] union i(alg[base]); for r1 in rels do for r2 in rels do newalg[composition][rename(r1,table),rename(r2,table)] := rename(alg[composition][r1,r2],table) od od; RETURN(newalg) end: # --------------------------------------------------------------------------- # inclusion tests (that is included-or-equal) basicincludedp := proc(s1,s2) local e; for e in s1 do if not member(e,s2) then RETURN(false) fi; od; RETURN(true) end: includedp := proc(s1,s2) if not assigned(s1) then RETURN(false) fi; if not assigned(s2) then RETURN(false) fi; RETURN(basicincludedp(s1,s2)); end: # --------------------------------------------------------------------------- # equality tests # Compare two algebras # returns a code indicating where the algebras are different: # 1: in the base relations # 2: in the auto-inverse relations # 3: in the neighborhood structure # r1,r2: in the r1,r2 entry of the composition table # 0: if they are equal algebraequalp := proc(alg1,alg2) if not alg1[base] union i(alg1[base]) = alg2[base] union i(alg2[base]) then RETURN(1) elif not alg1[autoinverse] = alg2[autoinverse] then RETURN(2) elif not alg1[neighborhood] = alg2[neighborhood] then RETURN(3) elif comptableequalp(alg1,alg2) <> false then RETURN(comptableequalp(alg1,alg2)) else RETURN(0) fi end: # Compare two composition tables and return: # false: if the tables are the same # r1,r2: if they differ (at least) on the r1,r2 entry comptableequalp := proc(alg1,alg2) local r1, r2, rels; rels := alg1[base] union i(alg1[base]); for r1 in rels do for r2 in rels do if alg1[composition][r1,r2] <> alg2[composition][r1,r2] then RETURN(r1,r2) fi od od; RETURN(false); end: