8. Relaciones binarias y conjuntos ordenados

Ejercicios resueltos

Ejercicio 1.

Sea A = {a, b, c, 8, 13}. Consideremos la relación binaria R = {(a, b), (b, c), (8, 13)}.
a) Completar la relación binaria R para que sea una relación de orden.
b) Completar la relación binaria R para que sea reflexiva y transitiva, pero no sea simétrica ni antisimétrica.
c) Completar la relación del apartado b) para que sea una relación de equivalencia.

Solución:

a) Para que R sea una relación de orden debe de ser reflexiva, antisimétrica y transitiva. Para ser reflexiva necesitamos añadir todos los pares (x, x) para cualquier x ∈ A. La propiedad antisimétrica la conseguimos simplemente evitando que los pares (x, y) e (y, x) con x ≠ y aparezca a la vez en R. Por último, para que satisfaga la propiedad transitiva hemos de añadir los pares (x, z) siempre que en R estén los pares (x, y) e (y, z) para cualesquiera x, y, z ∈ A. Consideremos, por ejemplo, el siguiente conjunto R

A = {a, b, c, 8, 13};
R = {{a, b}, {b, c}, {8, 13}, {a, a}, {b, b}, {c, c}, {8, 8}, {13, 
            13}, {a, c}};

Reflexiva = True; 
    For[n = 1, n ≤ Length[A], n++, 
      If[Intersection[{{A[[n]], A[[n]]}}, 
            R] == {{A[[n]], A[[n]]}}, Null, 
        Reflexiva = False]]; Simetrica = True; 
    For[m = 1, m ≤ Length[R], m++, 
      If[Intersection[{{R[[m, 2]], R[[m, 1]]}}, 
            R] == {{R[[m, 2]], R[[m, 1]]}}, Null, 
        Simetrica = False]];
Transitiva = True; 
    For[p = 1, 
      p ≤ 
        Length[R], p++, For[q = 1, 
          q ≤ 
            Length[R], q++, If[R[[p, 1]] == R[[q, 2]], 
              If[Intersection[{{R[[q, 1]], R[[p, 2]]}}, 
                    R] == {{R[[q, 1]], R[[p, 2]]}}, Null, 
                Transitiva = False]];];]; Antisimetrica = True; 
    For[r = 1, r ≤ Length[R], r++, 
      If[Intersection[{{R[[r, 2]], R[[r, 1]]}}, 
              R] == {{R[[r, 2]], 
                R[[r, 1]]}} && ! (ToString[R[[r, 1]]] == 
                ToString[R[[r, 2]]]), Antisimetrica = False]]; 
    If[Reflexiva, Print["R es reflexiva"], 
        Print["R no es reflexiva"]] 
      If[Simetrica, Print["R es simétrica"], 
        Print["R no es simétrica"]] 
      If[Transitiva, Print["R es transitiva"], 
        Print["R no es transitiva"]] 
      If[Antisimetrica, Print["R es antisimétrica"], 
        Print["R no es antisimétrica"]]; 
    If[Reflexiva && Simetrica && Transitiva, 
      Print["R es una relación de equivalencia"], 
      Print["R no es relación de equivalencia"]]; 
    If[Reflexiva && Antisimetrica && Transitiva, 
      Print["R es una relación de orden"], 
      Print["R no es relación de orden"]]

b) Ahora queremos que sea reflexiva y transitiva pero que no sea ni simétrica, ni antisimétrica, para ellos añadimos todos los pares (x, x) para cualquier x ∈ A y los pares (x, z) siempre que en R estén los pares (x, y) e (y, z) para cualesquiera x, y, z ∈ A. Para evitar que sea antisimética basta con que añadamos dos pares (x, y) e (y, x) con x ≠ y. Por último la simétria la rompemos si cuando tengamos en R un par (x, y), el par (y, x) no esté en R. Consideremos, por ejemplo, el siguiente conjunto R

A = {a, b, c, 8, 13};
R = {{a, b}, {b, c}, {8, 13}, {a, a}, {b, b}, {c, c}, {8, 8}, {13, 
            13}, {a, c}, {c, b}};

Reflexiva = True; 
    For[n = 1, n ≤ Length[A], n++, 
      If[Intersection[{{A[[n]], A[[n]]}}, 
            R] == {{A[[n]], A[[n]]}}, Null, 
        Reflexiva = False]]; Simetrica = True; 
    For[m = 1, m ≤ Length[R], m++, 
      If[Intersection[{{R[[m, 2]], R[[m, 1]]}}, 
            R] == {{R[[m, 2]], R[[m, 1]]}}, Null, 
        Simetrica = False]];
Transitiva = True; 
    For[p = 1, 
      p ≤ 
        Length[R], p++, For[q = 1, 
          q ≤ 
            Length[R], q++, If[R[[p, 1]] == R[[q, 2]], 
              If[Intersection[{{R[[q, 1]], R[[p, 2]]}}, 
                    R] == {{R[[q, 1]], R[[p, 2]]}}, Null, 
                Transitiva = False]];];]; Antisimetrica = True; 
    For[r = 1, r ≤ Length[R], r++, 
      If[Intersection[{{R[[r, 2]], R[[r, 1]]}}, 
              R] == {{R[[r, 2]], 
                R[[r, 1]]}} && ! (ToString[R[[r, 1]]] == 
                ToString[R[[r, 2]]]), Antisimetrica = False]]; 
    If[Reflexiva, Print["R es reflexiva"], 
        Print["R no es reflexiva"]] 
      If[Simetrica, Print["R es simétrica"], 
        Print["R no es simétrica"]] 
      If[Transitiva, Print["R es transitiva"], 
        Print["R no es transitiva"]] 
      If[Antisimetrica, Print["R es antisimétrica"], 
        Print["R no es antisimétrica"]]; 
    If[Reflexiva && Simetrica && Transitiva, 
      Print["R es una relación de equivalencia"], 
      Print["R no es relación de equivalencia"]]; 
    If[Reflexiva && Antisimetrica && Transitiva, 
      Print["R es una relación de orden"], 
      Print["R no es relación de orden"]]

a) Para que la relación definida en el apartado b) sea una relación de equivalencia debe de ser reflexiva, simétrica y transitiva. Como ya es reflexiva y transitiva, sólo tenemos que añadir pares de manera que también sea simétrica. Para ello basta con añadir el par (y, x) para cualquier par (x, y) que esté en R. Por ejemplo:

A = {a, b, c, 8, 13};
R = {{a, b}, {b, c}, {8, 13}, {a, a}, {b, b}, {c, c}, {8, 8}, {13, 
            13}, {a, c}, {c, b}, {b, a}, {13, 8}, {c, a}};

Reflexiva = True; 
    For[n = 1, n ≤ Length[A], n++, 
      If[Intersection[{{A[[n]], A[[n]]}}, 
            R] == {{A[[n]], A[[n]]}}, Null, 
        Reflexiva = False]]; Simetrica = True; 
    For[m = 1, m ≤ Length[R], m++, 
      If[Intersection[{{R[[m, 2]], R[[m, 1]]}}, 
            R] == {{R[[m, 2]], R[[m, 1]]}}, Null, 
        Simetrica = False]];
Transitiva = True; 
    For[p = 1, 
      p ≤ 
        Length[R], p++, For[q = 1, 
          q ≤ 
            Length[R], q++, If[R[[p, 1]] == R[[q, 2]], 
              If[Intersection[{{R[[q, 1]], R[[p, 2]]}}, 
                    R] == {{R[[q, 1]], R[[p, 2]]}}, Null, 
                Transitiva = False]];];]; Antisimetrica = True; 
    For[r = 1, r ≤ Length[R], r++, 
      If[Intersection[{{R[[r, 2]], R[[r, 1]]}}, 
              R] == {{R[[r, 2]], 
                R[[r, 1]]}} && ! (ToString[R[[r, 1]]] == 
                ToString[R[[r, 2]]]), Antisimetrica = False]]; 
    If[Reflexiva, Print["R es reflexiva"], 
        Print["R no es reflexiva"]] 
      If[Simetrica, Print["R es simétrica"], 
        Print["R no es simétrica"]] 
      If[Transitiva, Print["R es transitiva"], 
        Print["R no es transitiva"]] 
      If[Antisimetrica, Print["R es antisimétrica"], 
        Print["R no es antisimétrica"]]; 
    If[Reflexiva && Simetrica && Transitiva, 
      Print["R es una relación de equivalencia"], 
      Print["R no es relación de equivalencia"]]; 
    If[Reflexiva && Antisimetrica && Transitiva, 
      Print["R es una relación de orden"], 
      Print["R no es relación de orden"]]

Ejercicio 2.

Sea A = {1, 2, 3, 4, 5, 6, 7, 8} y consideremos la relación binaria R = {(1, 1), (1, 2), (1, 3), (1, 4), (1, 5), (1, 6), (1, 7), (1, 8), (2, 2), (2, 5), (2, 6), (2, 8),    (3, 3), (3, 5), (3, 7), (3, 8), (4, 4), (4, 6), (4, 7), (4, 8), (5, 5), (5, 8), (6, 6), (6, 8), (7, 7), (7, 8), (8, 8)}. Se pide:
a) Comprobar que R determina un orden en A.
b) Calcular los máximos y mínimos del conjunto ordenado A para la relación de orden R.
c) Calcular los máximales y minimales del conjunto ordenado B = A - {1,8} para la relación de orden inducida por R.
d) Calcular las cotas superiores e inferiores de B = A - {1,8} en A.
e) Representar gráficamente los conjuntos A y B.

Solución:

a) Definimos A y R y usamos el programa 8.1.:

A = {1, 2, 3, 4, 5, 6, 7, 8};
R = {{1, 1}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 6}, {1, 7}, {1, 
            8}, {2, 2}, {2, 5}, {2, 6}, {2, 8}, {3, 3}, {3, 5}, {3, 7}, {3, 
            8}, {4, 4}, {4, 6}, {4, 7}, {4, 8}, {5, 5}, {5, 8}, {6, 6}, {6, 
            8}, {7, 7}, {7, 8}, {8, 8}};
Reflexiva = True; 
    For[n = 1, n ≤ Length[A], n++, 
      If[Intersection[{{A[[n]], A[[n]]}}, 
            R] == {{A[[n]], A[[n]]}}, Null, 
        Reflexiva = False]]; Simetrica = True; 
    For[m = 1, m ≤ Length[R], m++, 
      If[Intersection[{{R[[m, 2]], R[[m, 1]]}}, 
            R] == {{R[[m, 2]], R[[m, 1]]}}, Null, 
        Simetrica = False]];
Transitiva = True; 
    For[p = 1, 
      p ≤ 
        Length[R], p++, For[q = 1, 
          q ≤ 
            Length[R], q++, If[R[[p, 1]] == R[[q, 2]], 
              If[Intersection[{{R[[q, 1]], R[[p, 2]]}}, 
                    R] == {{R[[q, 1]], R[[p, 2]]}}, Null, 
                Transitiva = False]];];]; Antisimetrica = True; 
    For[r = 1, r ≤ Length[R], r++, 
      If[Intersection[{{R[[r, 2]], R[[r, 1]]}}, 
              R] == {{R[[r, 2]], 
                R[[r, 1]]}} && ! (ToString[R[[r, 1]]] == 
                ToString[R[[r, 2]]]), Antisimetrica = False]]; 
    If[Reflexiva, Print["R es reflexiva"], 
        Print["R no es reflexiva"]] 
      If[Simetrica, Print["R es simétrica"], 
        Print["R no es simétrica"]] 
      If[Transitiva, Print["R es transitiva"], 
        Print["R no es transitiva"]] 
      If[Antisimetrica, Print["R es antisimétrica"], 
        Print["R no es antisimétrica"]]; 
    If[Reflexiva && Simetrica && Transitiva, 
      Print["R es una relación de equivalencia"], 
      Print["R no es relación de equivalencia"]]; 
    If[Reflexiva && Antisimetrica && Transitiva, 
      Print["R es una relación de orden"], 
      Print["R no es relación de orden"]]

b)

A = {1, 2, 3, 4, 5, 6, 7, 8};
R = {{1, 1}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 6}, {1, 7}, {1, 
            8}, {2, 2}, {2, 5}, {2, 6}, {2, 8}, {3, 3}, {3, 5}, {3, 7}, {3, 
            8}, {4, 4}, {4, 6}, {4, 7}, {4, 8}, {5, 5}, {5, 8}, {6, 6}, {6, 
            8}, {7, 7}, {7, 8}, {8, 8}};

maximo = {}; 
    Do[maxi = True; 
      Do[If[Intersection[{{A[[m]], A[[n]]}}, R] == {}, 
          maxi = False], {m, 1, Length[A]}]; 
      If[maxi, AppendTo[maximo, A[[n]]]];, {n, 1, Length[A]}]; 
    If[maximo == {}, Print["No tiene máximo"], 
      Print["Máximo: ", maximo[[1]]]]

minimo = {}; 
    Do[mini = True; 
      Do[If[Intersection[{{A[[n]], A[[m]]}}, R] == {}, 
          mini = False], {m, 1, Length[A]}]; 
      If[mini, AppendTo[minimo, A[[n]]]];, {n, 1, Length[A]}]; 
    If[minimo == {}, Print["No tiene mínimo"], 
      Print["Mínimo: ", minimo[[1]]]]

c)

A = {2, 3, 4, 5, 6, 7};
R = {{2, 2}, {2, 5}, {2, 6}, {3, 3}, {3, 5}, {3, 7}, {4, 4}, {4, 
            6}, {4, 7}, {5, 5}, {6, 6}, {7, 7}};

maximales = {}; 
    Do[maximal = True; 
      Do[If[Intersection[{{A[[n]], A[[m]]}}, R] ≠ {} && 
            n ≠ m, maximal = False], {m, 1, Length[A]}]; 
      If[maximal, AppendTo[maximales, A[[n]]]];, {n, 1, Length[A]}]; 
    Print["Maximales: ", maximales]

minimales = {}; 
    Do[minimal = True; 
      Do[If[Intersection[{{A[[m]], A[[n]]}}, R] ≠ {} && 
            n ≠ m, minimal = False], {m, 1, Length[A]}]; 
      If[minimal, AppendTo[minimales, A[[n]]]];, {n, 1, Length[A]}]; 
    Print["Minimales: ", minimales]

d)

A = {1, 2, 3, 4, 5, 6, 7, 8};
B = {2, 3, 4, 5, 6, 7};
R = {{1, 1}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 6}, {1, 7}, {1, 
            8}, {2, 2}, {2, 5}, {2, 6}, {2, 8}, {3, 3}, {3, 5}, {3, 7}, {3, 
            8}, {4, 4}, {4, 6}, {4, 7}, {4, 8}, {5, 5}, {5, 8}, {6, 6}, {6, 
            8}, {7, 7}, {7, 8}, {8, 8}};
cotassuperiores = {}; 
    Do[csuper = True; 
      Do[If[Intersection[{{B[[m]], A[[n]]}}, R] == {}, 
          csuper = False], {m, 1, Length[B]}]; 
      If[csuper, AppendTo[cotassuperiores, A[[n]]]];, {n, 1, Length[A]}]; 
    If[cotassuperiores == {}, Print["No hay cotas superiores"], 
      Print["Cotas superiores: ", cotassuperiores]; supremo = {}; 
      Do[mini = True; 
        Do[If[Intersection[{{cotassuperiores[[n]], 
                    cotassuperiores[[m]]}}, R] == {}, 
            mini = False], {m, 1, Length[cotassuperiores]}]; 
        If[mini, AppendTo[supremo, cotassuperiores[[n]]]];, {n, 1, 
          Length[cotassuperiores]}]; 
      If[supremo == {}, Print["No tiene supremo"], 
        Print["Supremo: ", supremo[[1]]]]];

cotasinferiores = {}; 
    Do[cinfer = True; 
      Do[If[Intersection[{{A[[n]], B[[m]]}}, R] == {}, 
          cinfer = False], {m, 1, Length[B]}]; 
      If[cinfer, AppendTo[cotasinferiores, A[[n]]]];, {n, 1, Length[A]}]; 
    If[cotasinferiores == {}, Print["No hay cotas inferiores"], 
      Print["Cotas inferiores: ", cotasinferiores]; infimo = {}; 
      Do[maxi = True; 
        Do[If[Intersection[{{cotasinferiores[[m]], 
                    cotasinferiores[[n]]}}, R] == {}, 
            maxi = False], {m, 1, Length[cotasinferiores]}]; 
        If[maxi, AppendTo[infimo, cotasinferiores[[n]]]];, {n, 1, 
          Length[cotasinferiores]}]; 
      If[infimo == {}, Print["No tiene ínfimo"], 
        Print["Ínfimo: ", infimo[[1]]]]];

e) Primero representamos el conjunto A:

<< Graphics`Arrow`
A = {1, 2, 3, 4, 5, 6, 7, 8};
R = {{1, 1}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 6}, {1, 7}, {1, 
            8}, {2, 2}, {2, 5}, {2, 6}, {2, 8}, {3, 3}, {3, 5}, {3, 7}, {3, 
            8}, {4, 4}, {4, 6}, {4, 7}, {4, 8}, {5, 5}, {5, 8}, {6, 6}, {6, 
            8}, {7, 7}, {7, 8}, {8, 8}};
Clear[Coord];
tabla = Table[0, {i1, Length[A]}, {j1, 3}]; B = A; t1 = 1; nivel = 0; 
    While[B ≠ {}, minimales = {}; nivel++; 
      Do[minimal = True; 
Do[
          If[Intersection[{{B[[m1]], B[[n1]]}}, R] ≠ {} && 
              n1 ≠ m1, minimal = False], {m1, 1, 
            Length[B]}]; 
If[minimal, 
          AppendTo[minimales, B[[n1]]]; 
          tabla[[t1]] = {nivel, B[[n1]], 
              0}; 
t1++;];, 
{n1, 1, 
          Length[B]}]; 
B = 
        Complement[B, 
          minimales];
]
R1 = {};
Do[
        AppendTo[R1, {A[[i1]], A[[i1]]}], {i1, 1, 
          Length[A]}];
R = Complement[R, R1]; R1 = {}; 
    Do[Do[Do[If[
            Intersection[
                R, {{R[[k1, 1]], A[[j1]]}, {A[[j1]], 
                    R[[k1, 2]]}}] == {{R[[k1, 1]], 
                  A[[j1]]}, {A[[j1]], R[[k1, 2]]}}, 
            R1 = Union[R1, {R[[k1]]}]]], {j1, 1, Length[A]}], {k1, 1, 
        Length[R]}];
R = Complement[R, R1];
puntos = {}; t1 = 0;
Do[cont = 0; 
Do[
        If[tabla[[i1, 1]] == j1, cont = cont + 1], {i1, 1, 
          Length[A]}]; 
      Do[t1++; 
        puntos = 
          Union[puntos, {Text[
                tabla[[t1, 2]], {k1 - (cont/2) -  .1, j1 +  .1}], 
              Point[{k1 - (cont/2), 
                  j1}]}]; 
tabla[[t1, 3]] = 
          k1 - (cont/2), {k1, 1, cont}], 
{j1, 1, 
        tabla[[Length[A], 1]]}]; 
    Coord[elem_] := 
      Do[If[elem == 
            tabla[[h1, 2]], 
Coord[
              elem] = {tabla[[h1, 3]], tabla[[h1, 1]]}], {h1, 1, 
          Length[A]}]; Do[Coord[A[[i1]]], {i1, 1, Length[A]}]; 
    Do[AppendTo[puntos, 
          Arrow[Coord[R[[t1, 1]]], 
            Coord[R[[t1, 2]]]]];
, {t1, 1, 
        Length[R]}];
Print["Diagrama de orden:"]
Show[Graphics[puntos]]

Y ahora el conjunto B.

A = {2, 3, 4, 5, 6, 7};
R = {{2, 2}, {2, 5}, {2, 6}, {3, 3}, {3, 5}, {3, 7}, {4, 4}, {4, 
            6}, {4, 7}, {5, 5}, {6, 6}, {7, 7}};
Clear[Coord];
tabla = Table[0, {i1, Length[A]}, {j1, 3}]; B = A; t1 = 1; nivel = 0; 
    While[B ≠ {}, minimales = {}; nivel++; 
      Do[minimal = True; 
Do[
          If[Intersection[{{B[[m1]], B[[n1]]}}, R] ≠ {} && 
              n1 ≠ m1, minimal = False], {m1, 1, 
            Length[B]}]; 
If[minimal, 
          AppendTo[minimales, B[[n1]]]; 
          tabla[[t1]] = {nivel, B[[n1]], 
              0}; 
t1++;];, 
{n1, 1, 
          Length[B]}]; 
B = 
        Complement[B, 
          minimales];
]
R1 = {};
Do[
        AppendTo[R1, {A[[i1]], A[[i1]]}], {i1, 1, 
          Length[A]}];
R = Complement[R, R1]; R1 = {}; 
    Do[Do[Do[If[
            Intersection[
                R, {{R[[k1, 1]], A[[j1]]}, {A[[j1]], 
                    R[[k1, 2]]}}] == {{R[[k1, 1]], 
                  A[[j1]]}, {A[[j1]], R[[k1, 2]]}}, 
            R1 = Union[R1, {R[[k1]]}]]], {j1, 1, Length[A]}], {k1, 1, 
        Length[R]}];
R = Complement[R, R1];
puntos = {}; t1 = 0;
Do[cont = 0; 
Do[
        If[tabla[[i1, 1]] == j1, cont = cont + 1], {i1, 1, 
          Length[A]}]; 
      Do[t1++; 
        puntos = 
          Union[puntos, {Text[
                tabla[[t1, 2]], {k1 - (cont/2) -  .1, j1 +  .1}], 
              Point[{k1 - (cont/2), 
                  j1}]}]; 
tabla[[t1, 3]] = 
          k1 - (cont/2), {k1, 1, cont}], 
{j1, 1, 
        tabla[[Length[A], 1]]}]; 
    Coord[elem_] := 
      Do[If[elem == 
            tabla[[h1, 2]], 
Coord[
              elem] = {tabla[[h1, 3]], tabla[[h1, 1]]}], {h1, 1, 
          Length[A]}]; Do[Coord[A[[i1]]], {i1, 1, Length[A]}]; 
    Do[AppendTo[puntos, 
          Arrow[Coord[R[[t1, 1]]], 
            Coord[R[[t1, 2]]]]];
, {t1, 1, 
        Length[R]}];
Print["Diagrama de orden:"]
Show[Graphics[puntos]]