############################################################################
##
##  elements/pbr.gi
##  Copyright (C) 2015-2022                              Attila Egri-Nagy
##
##  Licensing information can be found in the README file of this package.
##
#############################################################################
##

# This file contains an initial implementation of partitioned binary
# relations (PBRs) as defined in:
#
# Paul Martin and Volodymyr Mazorchuk, Partitioned binary relations,
# Mathematica Scandinavica, v113, n1, p. 30-52, https://arxiv.org/abs/1102.0862

# Internally a PBR is stored as the adjacency list of digraph with
# vertices [1 .. 2 * n] for some n. More precisely if <x> is a PBR, then:
#
#   * <x![1]> is equal to <n>
#
#   * <x![i + 1]> is the vertices adjacent to <i>
#
# The number <n> is the *degree* of <x>.

#############################################################################
# Family and type.
#
# One per degree to avoid lists with pbrs of different degrees
# belonging to IsAssociativeElementCollection.
#############################################################################

BindGlobal("TYPES_PBR", []);
BindGlobal("TYPE_PBR",
function(n)

  if not IsInt(n) or n < 0 then
    ErrorNoReturn("the argument is not a non-negative integer");
  fi;

  n := n + 1;  # since the degree can be 0

  if not IsBound(TYPES_PBR[n]) then
    TYPES_PBR[n] := NewType(NewFamily(Concatenation("PBRFamily",
                                                    String(n - 1)),
                                      IsPBR,
                                      CanEasilySortElements,
                                      CanEasilySortElements),
                            IsPBR and IsPositionalObjectRep);
  fi;

  return TYPES_PBR[n];
end);

#############################################################################
# Pickler
#############################################################################

InstallMethod(IO_Pickle, "for a PBR",
[IsFile, IsPBR],
function(file, x)
  if IO_Write(file, "PABR") = fail then
    return IO_Error;
  fi;
  return IO_Pickle(file, List([1 .. 2 * x![1] + 1], i -> x![i]));
end);

IO_Unpicklers.PABR := function(file)
  local x;
  x := IO_Unpickle(file);
  if x = IO_Error then
    return IO_Error;
  fi;
  return Objectify(TYPE_PBR(x![1]), x);
end;

#############################################################################
# TODO(later) the embeddings from the paper, AsPBR for a pbr (extend or
# restrict),
#############################################################################

InstallMethod(EmptyPBR, "for a pos int", [IsPosInt],
n -> PBRNC(List([1 .. n], y -> []), List([1 .. n], y -> [])));

InstallMethod(IdentityPBR, "for a pos int", [IsPosInt],
n -> PBRNC(List([1 .. n], y -> [-y]), List([1 .. n], y -> [y])));

InstallMethod(UniversalPBR, "for a pos in", [IsPosInt],
function(n)
  local x;
  x := Concatenation([-n .. -1], [1 .. n]);
  return PBRNC(List([1 .. n], y -> x), List([1 .. n], y -> x));
end);

# The following is temporary, with the current definition of
# IsGeneratorsOfInverseSemigroup for a pbr collection, the One of any element
# in the collection does not satisfy IsGeneratorsOfInverseSemigroup, and so it
# cannot be inverted.

InstallMethod(InverseMonoidByGenerators,
[IsPBRCollection],
function(_)
  ErrorNoReturn("not yet implemented");
end);

# See the comment above, this is not really correct.

InstallOtherMethod(InverseMutable, "for a PBR", [IsPBR],
function(x)
  # TODO(later) change IsBlockBijection(AsBipartition(x)) to
  # IsBlockBijectionPBR.
  if IsPartialPermPBR(x) or
      (IsBipartitionPBR(x) and IsBlockBijection(AsBipartition(x))) then
    return Star(x);
  fi;
  return fail;
end);

# See the comment above, this is not really correct.

InstallMethod(IsGeneratorsOfInverseSemigroup, "for a pbr collection",
[IsPBRCollection],
function(coll)
  return ForAll(coll, IsBipartitionPBR)
         and IsGeneratorsOfInverseSemigroup(List(coll, AsBipartition));
end);

InstallMethod(StarOp, "for a pbr", [IsPBR],
function(x)
  local ext;
  ext := ShallowCopy(ExtRepOfObj(x) * -1);
  Apply(ext, ShallowCopy);
  Apply(ext[1], ShallowCopy);
  Apply(ext[2], ShallowCopy);
  return PBR(ext[2], ext[1]);
end);

InstallMethod(DegreeOfPBRCollection, "for a PBR collection",
[IsPBRCollection],
function(coll)
  if IsPBRSemigroup(coll) then
    return DegreeOfPBRSemigroup(coll);
  fi;
  return DegreeOfPBR(coll[1]);
end);

InstallMethod(IsBipartitionPBR, "for a pbr",
[IsPBR],
x -> IsEquivalenceBooleanMat(AsBooleanMat(x)));

InstallMethod(IsTransformationPBR, "for a pbr",
[IsPBR],
function(x)
  local n, i;

  n := x![1];
  for i in [2 .. n + 1] do
    if Length(x![i]) <> 1 or x![i][1] <= n
        or not i - 1 in x![x![i][1] + 1] then
      return false;
    fi;
  od;
  for i in [n + 2 .. 2 * n + 1] do
    if not ForAll(x![i], j -> j <= n and x![j + 1][1] = i - 1) then
      return false;
    fi;
  od;

  return true;
end);

InstallMethod(IsBlockBijectionPBR, "for a pbr",
[IsPBR],
x -> IsBipartitionPBR(x) and IsBlockBijection(AsBipartition(x)));

InstallMethod(IsPartialPermPBR, "for a pbr",
[IsPBR],
x -> IsBipartitionPBR(x) and IsPartialPermBipartition(AsBipartition(x)));

InstallMethod(IsPermPBR, "for a pbr",
[IsPBR],
x -> IsBipartitionPBR(x) and IsPermBipartition(AsBipartition(x)));

InstallMethod(IsDualTransformationPBR, "for a pbr",
[IsPBR],
x -> IsBipartitionPBR(x) and IsDualTransBipartition(AsBipartition(x)));

InstallMethod(NumberPBR, "for a pbr",
[IsPBR],
x -> NumberBooleanMat(AsBooleanMat(x)));

InstallMethod(PBRNumber, "for pos int and pos int",
[IsPosInt, IsPosInt],
{nr, deg} -> AsPBR(BooleanMatNumber(nr, 2 * deg)));

InstallMethod(IsEmptyPBR, "for a partition binary relation",
[IsPBR],
function(x)
  local n, i;

  n := x![1];
  for i in [2 .. 2 * n + 1] do
    if Length(x![i]) > 0 then
      return false;
    fi;
  od;
  return true;
end);

InstallMethod(IsIdentityPBR, "for a partition binary relation",
[IsPBR],
function(x)
  local n, i;

  n := x![1];
  for i in [2 .. n + 1] do
    if Length(x![i]) <> 1 or x![i][1] <> i + n - 1 then
      return false;
    fi;
  od;
  for i in [n + 2 .. 2 * n + 1] do
    if Length(x![i]) <> 1 or x![i][1] <> i - n - 1 then
      return false;
    fi;
  od;
  return true;
end);

InstallMethod(IsUniversalPBR, "for a partition binary relation",
[IsPBR],
function(x)
  local n, i;

  n := x![1];
  for i in [2 .. 2 * n + 1] do
    if Length(x![i]) < 2 * n then
      return false;
    fi;
  od;
  return true;
end);

InstallMethod(AsPBR, "for a partial perm and pos int",
[IsPartialPerm, IsPosInt],
function(x, deg)
  local left, right, j, i;

  left  := List([1 .. deg], x -> []);
  right := List([1 .. deg], x -> []);

  for i in [1 .. deg] do
    j := i ^ x;
    if j <= deg and j <> 0 then
      Add(left[i], -j);
      Add(right[j], i);
    fi;
  od;

  return PBR(left, right);
end);

InstallMethod(AsPBR, "for a partial perm", [IsPartialPerm],
x -> AsPBR(x, Maximum(DegreeOfPartialPerm(x), CoDegreeOfPartialPerm(x))));

InstallMethod(AsPBR, "for a transformation and pos int",
[IsTransformation, IsPosInt],
function(x, deg)
  local left, right, i;

  left  := List([1 .. deg], x -> []);
  right := List([1 .. deg], x -> []);

  for i in [1 .. deg] do
    Add(left[i], -(i ^ x));
    Add(right[i ^ x], i);
  od;

  return PBR(left, right);
end);

InstallMethod(AsPBR, "for a transformation", [IsTransformation],
x -> AsPBR(x, DegreeOfTransformation(x)));

InstallMethod(AsPBR, "for a multiplicative element",
[IsMultiplicativeElement], x -> AsPBR(AsBipartition(x)));

InstallMethod(AsPBR, "for a multiplicative element and pos int",
[IsMultiplicativeElement, IsPosInt], {x, n} -> AsPBR(AsBipartition(x, n)));

# TODO(later) The following doesn't define a monoid embedding of P_n into
# PBR_n. What is a monoid embedding from P_n to PBR_n?

InstallMethod(AsPBR, "for a bipartition",
[IsBipartition], x -> AsPBR(x, DegreeOfBipartition(x)));

InstallMethod(AsPBR, "for a bipartition and pos int",
[IsBipartition, IsPosInt],
function(x, n)
  local deg, blocks, out, dom, block, i;

  deg    := DegreeOfBipartition(x);
  blocks := ExtRepOfObj(x);
  out    := [[], []];
  dom := Union([-n .. -1], [1 .. n]);

  for block in blocks do
    for i in block do
      if AbsInt(i) <= n then
        if i < 0 then
          out[2][-i] := Intersection(block, dom);
        else
          out[1][i] := Intersection(block, dom);
        fi;
      fi;
    od;
  od;
  for i in [deg + 1 .. n] do
    Add(out[1], []);
    Add(out[2], []);
  od;

  return PBRNC(out[1], out[2]);
end);

InstallMethod(AsPBR, "for a boolean matrix", [IsBooleanMat],
function(x)
  local dim, succ;

  dim := DimensionOfMatrixOverSemiring(x);
  if not IsEvenInt(dim) then
    ErrorNoReturn("the 1st argument (a boolean matrix)is not of ",
                  "even dimension");
  fi;
  succ := Successors(x);
  return PBRNC(succ{[1 .. dim / 2]}, succ{[dim / 2 + 1 .. dim]});
end);

InstallMethod(AsPBR, "for a boolean mat and pos int",
[IsBooleanMat, IsPosInt],
function(mat, n)
  local m, nbs, k, i, j;

  if not IsEvenInt(n) then
    ErrorNoReturn("the 2nd argument (a pos. int) is not even");
  fi;

  m := DimensionOfMatrixOverSemiring(mat);

  if not IsEvenInt(m) then
    ErrorNoReturn("the 1st argument (a boolean matrix) ",
                  "does not have even dimension");
  fi;

  nbs := [List([1 .. n / 2], x -> []),
          List([1 .. n / 2], x -> [])];

  if n <= m then
    for i in [1 .. n / 2] do
      for j in [1 .. n] do
        if mat[i][j] then
          Add(nbs[1][i], j);
        fi;
      od;
    od;
    for i in [n / 2 + 1 .. n] do
      for j in [1 .. n] do
        if mat[i][j] then
          Add(nbs[2][i - n / 2], j);
        fi;
      od;
    od;
  else
    k := (n - m) / 2;

    for i in [1 .. m / 2] do
      for j in [1 .. m / 2] do
        if mat[i][j] then
          Add(nbs[1][i], j);
        fi;
      od;
      for j in [m / 2 + 1 .. m] do
        if mat[i][j] then
          Add(nbs[1][i], j + k);
        fi;
      od;
    od;
    for i in [m / 2 + 1 .. m] do
      for j in [1 .. m / 2] do
        if mat[i][j] then
          Add(nbs[2][i - m / 2], j);
        fi;
      od;
      for j in [m / 2 + 1 .. m] do
        if mat[i][j] then
          Add(nbs[2][i - m / 2], j + k);
        fi;
      od;
    od;
  fi;

  return PBRNC(nbs[1], nbs[2]);
end);

# TODO(later) 2 arg version of this

InstallMethod(AsTransformation, "for a pbr", [IsPBR],
function(x)
  local out, n, i;

  if not IsTransformationPBR(x) then
    ErrorNoReturn("the argument (a pbr) does not define a transformation");
  fi;

  out := [];
  n := x![1];

  for i in [2 .. n + 1] do
    out[i - 1] := x![i][1] - n;
  od;

  return Transformation(out);
end);

# TODO(later) 2 arg version of this

InstallMethod(AsPartialPerm, "for a pbr", [IsPBR],
function(x)
  if not IsPartialPermPBR(x) then
    ErrorNoReturn("the argument (a pbr) does not define a partial perm");
  fi;
  return AsPartialPerm(AsBipartition(x));
end);

# TODO(later) 2 arg version of this

InstallMethod(AsPermutation, "for a pbr", [IsPBR],
function(x)
  if not IsPermPBR(x) then
    ErrorNoReturn("the argument (a pbr) does not define a permutation");
  fi;
  return AsPermutation(AsBipartition(x));
end);

InstallMethod(RandomPBR, "for a pos int", [IsPosInt],
function(n)
  local digraph;
  digraph := RandomDigraph(2 * n);
  return PBRNC(OutNeighbours(digraph){[1 .. n]},
               OutNeighbours(digraph){[n + 1 .. 2 * n]});
end);

InstallMethod(RandomPBR, "for a pos int", [IsPosInt, IsFloat],
function(n, p)
  local digraph;
  digraph := RandomDigraph(2 * n, p);
  return PBRNC(OutNeighbours(digraph){[1 .. n]},
               OutNeighbours(digraph){[n + 1 .. 2 * n]});
end);

InstallMethod(PBR, "for pair of dense list",
[IsDenseList, IsDenseList],
function(left, right)
  local deg, i;

  if Length(left) <> Length(right) then
    ErrorNoReturn("the arguments (dense lists) do not have equal length");
  fi;

  deg := Length(left);

  for i in [1 .. deg] do
    if not IsHomogeneousList(left[i]) then
      ErrorNoReturn("expected a homogeneous list in position ", i,
                    " of the 1st argument (a dense list)");
    elif not IsHomogeneousList(right[i]) then
      ErrorNoReturn("expected a homogeneous list in position ", i,
                    " of the 2nd argument (a dense list)");
    elif   not ForAll(left[i], j -> IsInt(j) and j <> 0
                                    and j <= deg and j >= -deg)
        or not ForAll(right[i], j -> IsInt(j) and j <> 0
                                     and j <= deg and j >= -deg) then
      # TODO(later) more informative
      ErrorNoReturn("the entries in the arguments are not integers ",
                    "in [", -deg, " .. -1] or [1 .. ", deg, "]");
    fi;
  od;
  return PBRNC(left, right);
end);

InstallGlobalFunction(PBRNC,
function(arg...)
  local left, right, n, i, j;

  arg   := StructuralCopy(arg);
  left  := arg[1];  # things adjacent to positives
  right := arg[2];  # things adjacent to negatives

  n := Length(left);

  for i in [1 .. n] do
    for j in [1 .. Length(left[i])] do
      if left[i][j] < 0 then
        left[i][j] := -left[i][j] + n;
      fi;
    od;
    left[i] := ShallowCopy(left[i]);
    Sort(left[i]);
    for j in [1 .. Length(right[i])] do
      if right[i][j] < 0 then
        right[i][j] := -right[i][j] + n;
      fi;
    od;
    right[i] := ShallowCopy(right[i]);
    Sort(right[i]);
  od;
  MakeImmutable(arg);
  arg := Concatenation([Length(arg[1])], Concatenation(arg));
  return Objectify(TYPE_PBR(arg[1]), arg);
end);

InstallMethod(DegreeOfPBR, "for a pbr",
[IsPBR], pbr -> pbr![1]);

InstallMethod(\*, "for pbrs", IsIdenticalObj,
[IsPBR, IsPBR],
function(x, y)
  local n, out, x_seen, y_seen, empty, x_dfs, y_dfs, tmp, i, j;

  n := x![1];

  out := Concatenation([n], List([1 .. 2 * n], x -> BlistList([1 .. 2 * n],
                                                              [])));

  x_seen := BlistList([1 .. 2 * n], []);
  y_seen := BlistList([1 .. 2 * n], []);
  empty  := BlistList([1 .. 2 * n], []);

  x_dfs := function(i, adj)  # starting in x
    local j;
    if x_seen[i] then
      return;
    fi;
    x_seen[i] := true;
    for j in x![i + 1] do
      if j <= n then
        adj[j] := true;
      else  # j > n
        y_dfs(j - n, adj);
      fi;
    od;
    return;
  end;

  y_dfs := function(i, adj)  # starting in y
    local j;
    if y_seen[i] then
      return;
    fi;
    y_seen[i] := true;
    for j in y![i + 1] do
      if j > n then
        adj[j] := true;
      else  # j <= n
        x_dfs(j + n, adj);
      fi;
    od;
    return;
  end;

  tmp := [];

  for i in [1 .. n] do  # find everything connected to vertex i
    for j in x![i + 1] do
      if j <= n then
        out[i + 1][j] := true;
      elif IsBound(tmp[j]) then
        UNITE_BLIST(out[i + 1], tmp[j]);
      else
        tmp[j] := BlistList([1 .. 2 * n], []);
        IntersectBlist(x_seen, empty);
        IntersectBlist(y_seen, empty);
        x_seen[i] := true;
        y_dfs(j - n, tmp[j]);
        UNITE_BLIST(out[i + 1], tmp[j]);
      fi;
      if SizeBlist(out[i + 1]) = 2 * n then
        break;
      fi;
    od;
  od;

  for i in [n + 1 .. 2 * n] do  # find everything connected to vertex i
    for j in y![i + 1] do
      if j > n then
        out[i + 1][j] := true;
      elif IsBound(tmp[j]) then
        UNITE_BLIST(out[i + 1], tmp[j]);
      else
        tmp[j] := BlistList([1 .. 2 * n], []);
        IntersectBlist(x_seen, empty);
        IntersectBlist(y_seen, empty);
        y_seen[i] := true;
        x_dfs(j + n, tmp[j]);
        UNITE_BLIST(out[i + 1], tmp[j]);
      fi;
      if SizeBlist(out[i + 1]) = 2 * n then
        break;
      fi;
    od;
  od;
  for i in [2 .. 2 * n + 1] do
    out[i] := ListBlist([1 .. 2 * n], out[i]);
  od;
  return Objectify(TYPE_PBR(n), out);
end);

InstallMethod(ExtRepOfObj, "for a pbr",
[IsPBR],
function(x)
  local n, out, i, j, k;

  n := x![1];
  out := [[], []];
  for i in [0, 1] do
    for j in [1 + n * i .. n + n * i] do
      Add(out[i + 1], []);
      for k in x![j + 1] do
        if k > n then
          AddSet(out[i + 1][j - n * i], -(k - n));
        else
          AddSet(out[i + 1][j - n * i], k);
        fi;
      od;
    od;
  od;

  return out;
end);

# These ViewObj and PrintObj methods are here because Print(ext[1]) produces
# nicer output than Print(ViewString(ext[1])). The ViewString and PrintString
# methods are required for use in things like Green's relations.

InstallMethod(ViewObj, "for a pbr", [IsPBR], PrintObj);

InstallMethod(PrintObj, "for a pbr", [IsPBR],
function(x)
  local ext;

  ext := ExtRepOfObj(x);
  Print("\>\>PBR(\>\>", ext[1], "\<\<,");

  if Length(String(ext[1])) > 72 or Length(String(ext[2])) > 72 then
    Print("\n");
  else
    Print(" ");
  fi;

  Print("\>\>", ext[2], "\<\<\<\<)");
end);

InstallMethod(ViewString, "for a pbr", [IsPBR], PrintString);

InstallMethod(PrintString, "for a pbr",
[IsPBR],
function(x)
  local ext, str;

  ext := ExtRepOfObj(x);

  str := Concatenation("\>\>PBR(\>\>", PrintString(ext[1]), "\<\<,");

  if Length(String(ext[1])) > 72 or Length(String(ext[2])) > 72 then
    Append(str, "\n");
  else
    Append(str, " ");
  fi;

  Append(str, "\>\>");
  Append(str, PrintString(ext[2]));
  Append(str, "\<\<\<\<)");

  # print empty lists with two spaces for consistency
  # see https://github.com/gap-system/gap/pull/5418
  return ReplacedString(str, "[ ]", "[  ]");
end);

InstallMethod(String, "for a pbr", [IsPBR],
function(x)
  local ext, str;
  ext := ExtRepOfObj(x);
  str := Concatenation("PBR(", String(ext[1]), ", ", String(ext[2]), ")");
  # print empty lists with two spaces for consistency
  # see https://github.com/gap-system/gap/pull/5418
  return ReplacedString(str, "[ ]", "[  ]");
end);

InstallMethod(\=, "for pbrs", IsIdenticalObj,
[IsPBR, IsPBR],
function(x, y)
  local n, i;

  n := x![1];
  for i in [1 .. 2 * n + 1] do
    if x![i] <> y![i] then
      return false;
    fi;
  od;
  return true;
end);

InstallMethod(\<, "for pbrs", IsIdenticalObj,
[IsPBR, IsPBR],
function(x, y)
  local n, i;

  n := x![1];
  for i in [1 .. 2 * n + 1] do
    if x![i] < y![i] then
      return true;
    elif x![i] > y![i] then
      return false;
    fi;
  od;
  return false;
end);

InstallMethod(OneMutable, "for a pbr",
[IsPBR],
function(x)
  local n, out, i;

  n := x![1];
  out := [n];
  for i in [1 .. n] do
    out[i + 1] := [i + n];
    out[i + n + 1] := [i];
  od;
  return Objectify(TYPE_PBR(n), out);
end);
