/** Check if a binary relation is cyclic
*
* @param x square logical matrix
* @return logical scalar
*
* @version 0.2 (Marek Gagolewski)
*/
SEXP rel_is_cyclic(SEXP x)
{
x = prepare_arg_logical_square_matrix(x, "R");
SEXP dim = Rf_getAttrib(x, R_DimSymbol);
R_len_t n = INTEGER(dim)[0];
int* xp = INTEGER(x);
for (int i=0; i<n*n; ++i)
if (xp[i] == NA_LOGICAL)
return Rf_ScalarLogical(NA_LOGICAL);
int* helper = new int[n];
for (int i=0; i<n; ++i)
helper[i] = 0;
bool ret = false;
int i=0;
do {
while (i < n) { if (helper[i] == 0) break; i++; } // get an unmarked node
if (i == n) break;
ret = rel_is_cyclic(i, xp, n, helper);
} while(!ret);
delete[] helper;
return Rf_ScalarLogical(ret);
}
/** Internal function
*
* Check cyclicity; based on depth-first search & topological sorting
*/
bool rel_is_cyclic(int i, int* xp, int n, int* helper) {
if (helper[i] == 1)
return true;
if (helper[i] == 2)
return false;
helper[i] = 1;
for (int j=0; j<n; ++j) {
if (xp[i+j*n]) {
if (j!=i && rel_is_cyclic(j, xp, n, helper))
return true;
}
}
helper[i] = 2;
return false;
}
/** Get the transitive reduction of a binary relation
*
* @param x square logical matrix
* @return square logical matrix
*
* @version 0.2 (Marek Gagolewski)
*/
SEXP rel_reduction_transitive(SEXP x)
{
SEXP cyc = rel_is_cyclic(x);
if (LOGICAL(cyc)[0] != false)
Rf_error(MSG__EXPECTED_ACYCLIC, "R");
x = rel_closure_transitive(x);
// is logical matrix, dimnames are preserved, no NAs, we may overwrite its elements
SEXP dim = Rf_getAttrib(x, R_DimSymbol);
R_len_t n = INTEGER(dim)[0];
int* xp = INTEGER(x);
SEXP y = Rf_allocVector(LGLSXP, n*n);
int* yp = INTEGER(y);
Rf_setAttrib(y, R_DimSymbol, dim);
Rf_setAttrib(y, R_DimNamesSymbol, Rf_getAttrib(x, R_DimNamesSymbol)); // preserve dimnames
// (Aho et al. 1972)
for (R_len_t i=0; i<n; ++i) {
for (R_len_t j=0; j<n; ++j) {
yp[i+n*j] = xp[i+n*j];
if (xp[i+n*j] && i != j) {
// determine whether i -> j may be removed
for (R_len_t k=0; k<n; ++k) {
if (i != k && k != j && xp[i+n*k] && xp[k+n*j]) {
yp[i+n*j] = 0;
break;
}
}
}
}
}
return y;
}
