Entrada destacada

Distancia media de dos puntos en un cuadrado unitario

martes, 29 de mayo de 2018

Círculo Osculador



Dada una curva el Círculo Osculador es el círculo que es tangente a la curva y además en su punto de tangencia comparten, círculo y curva, la misma curvatura. El término osculador viene de la palabra latina osculum que significa beso.

Recordemos, que dada una función y = f(x) su curvatura k(x) en el punto (x,f(x)) está dada por la fórmula:



Y la curvatura de una circunferencia de radio R es 1/R.

Primero definimos la curvatura para una función f en un punto x de su dominio por:

curva[f_, a_] := Abs[D[f, {x, 2}]]/(1 + D[f, x]^2)^(3/2) /. {x -> a}

Ahora, construimos el Manipulate que nos gráfica el círculo oscilador para las funciones seno, coseno, tangente y una cuadrática.

parabola[x_] := 0.3 x^2

Manipulate[
 aaa = {x, y} /. 
   SortBy[NSolve[{y - f[a] == -1/(D[f[x], x] /. {x -> a}) (x - a), 
      Sqrt[(x - a)^2 + (y - f[a])^2] == 1/curva[f[x], a]}, {x, y}], 
    Last]; {h, k} = 
  If[(D[f[x], {x, 2}] /. {x -> a}) < 0, aaa[[1]], aaa[[2]]]; 
 radio = 1./curva[f[x], a]; 
 Show[Graphics[{Red, Circle[{h, k}, radio]}, AspectRatio -> 1], 
  Plot[f[x], {x, -10, 10}], PlotRange -> 10, Axes -> True, 
  PlotLabel -> 
   Grid[{{"Cículo osculador"}, {StringForm[
       "Centro: (`1`,`2`)  Radio: `3`", h, k, radio]}}]], {a, -5, 
  5}, {f, {Sin, Cos, Tan, parabola -> "Parábola"}}]




Para aprender más sobre Mathematica ingrese aquí sitio de aprendizaje de Wolfram o en mi website ustamathematica.wixsite.com/basicas


viernes, 25 de mayo de 2018

Frase Célebre de Tymockzo

Usar un ordenador para establecer una verdad matemática 
es transformar pruebas en experimentos.

Tymockzo

martes, 22 de mayo de 2018

Creación de Fractales con Funciones Afines mediante el Juego del Caos


En publicaciones anteriores sobre Transformaciones Afines (17 de Abril de 2018) y El Juego del Caos (24 Abril de 2018) dí los elementos básicos para que podamos construir fractales sencillos, la idea básica es la auto similitud propiedad fundamental de los fractales, la parte se parece al todo y la parte de la parte también se parece al todo y así al infinito.

Vamos a recrear la idea mediante un ejemplo, la construcción del Triángulo de Sierpinski.

Triángulo de Sierpinski

En honor al matemático polaco Waclaw Sierpinski.  Se construye a partir de un triángulo equilátero, aunque no necesariamente, al quitarle el triángulo interior con vértices los puntos medios de los lados del triángulo inicial, con los tres triángulos restantes se repite el proceso sucesivamente hasta el infinito.


Para construirlo por auto similitud, la parte se parece al todo, vemos que el triángulo está construido sobre el cuadrado [0,1]x[0,1]




y lo podemos descomponer en tres partes similares con él


La idea es por medio de funciones afines transformar el cuadrado inicial en cada uno de los cuadrados marcados como 1, 2 y 3 en la figura, para esto utilizamos el aplicativo que tenemos en la publicación de las funciones Afines, obtenemos los siguientes valores:



estos valores los hemos obtenido por ejemplo para el primer cuadrado



Estos valores los guardamos en las siguientes listas, donde p nos indica el porcentaje que corresponde a cada área del total de la figura y ran nos simula un dado que en este caso arroja como resultados {1,2,3} de acuerdo con los porcentajes p calculados según el área de cada región, así, si el cuadrado 1 tuviera el doble de área que el cuadrado 2, tendría el doble de posibilidades de salir como resultado en el dado simulado por ran.

a = {0.5, 0.5, 0.5};
b = {0, 0, 0};
c = {0, 0.5, 0.25};
d = {0, 0, 0};
e = {0.5, 0.5, 0.5};
f = {0, 0, 0.5};
area = {0.25, 0.25, 0.25};
total = Total[area];
p = Table[area[[n]]/total, {n, Length[area]}]
ran := RandomChoice[p -> Range[Length[area]], 1][[1]]

Ahora definimos

fun[n_, {x_, y_}] := {a[[n]] x + b[[n]] y + c[[n]], 
  d[[n]] x + e[[n]] y + f[[n]]}

donde n toma los valores 1, 2 o 3, definiéndonos tres funciones una para cada cuadrado, de acuerdo con los valores dados en la tabla anterior. Estas funciones se denominan un Sistema Iterado de Funciones o IFS por sus siglas en inglés, veamos que cada función es una contracción del cuadrado inicial pues su área es menor que la de dicho cuadrado.

Ya para construir el Triángulo de Sierpinski, definimos la función sig que aplica a un punto {x,y} fun1, fun2 o fun3 dependiendo del resultado del dado ran. Con ayuda del comando NestList aplicamos sig empezando en {1,1} un número de 100000 veces y graficamos los puntos:

sig[punto_] := fun[ran, punto]
ListPlot[NestList[sig, {1, 1}, 100000], PlotStyle -> PointSize[Tiny], 
 PlotRange -> Automatic, Axes -> True]



Este proceso basado en la idea del Juego del Caos se denomina Ping Pong Fractal y se le debe a Michael Barnsley, que corresponde a un proceso de tipo estocástico (probabilístico) y no determinístico para la construcción de fractales.

Los cuadrados no tiene que estar necesariamente dentro del cuadrado inicial pero sí tienen que ser de menor área, por ejemplo con los valores:



obtenemos  la siguiente gráfica:


Ejercicio

Construir el siguiente fractal




Para aprender más sobre Mathematica ingrese aquí sitio de aprendizaje de Wolfram o en mi website ustamathematica.wixsite.com/basicas


viernes, 18 de mayo de 2018

Frase Célebre de María Goeppert Mayer

Las matemáticas comienzan a parecerse 
cada vez más a resolver un puzzle.
La física también, pero son puzzles creados por la naturaleza, 
no por la mente del hombre.

María Goeppert Mayer

martes, 15 de mayo de 2018

Forma Gráfica de los Multiplicadores de Lagrange



Colaboración de Johann Stev Castellanos estudiante de la Universidad Santo Tomás

El problema consiste en optimizar la función f(x,y)= xy sobre los puntos de la elipse



El Teorema de los Multiplicadores de Lagrange nos dice que si un punto óptimo de la función f(x,y) sobre la elipse existe, en ese punto, los gradientes de la función a optimizar y el de la restricción son paralelos.

Manipulate[
 Show[ContourPlot[(x^2/9) + (y^2/16) == 1, {x, -2, 7}, {y, -2, 7}, 
   PerformanceGoal -> "Quality", PlotRange -> {{-2, 7}, {-2, 7}}, 
   ImageSize -> Large], 
  ContourPlot[x*y, {x, -2, 7}, {y, -2, 7}, ContourShading -> None, 
   PerformanceGoal -> "Quality", 
   Contours -> Table[3 i, {i, -24, 24}]], 
  Graphics[Point[Dynamic[{x, 4 Sqrt[9 - x^2]/3}], 
    VertexColors -> Red]], 
  Graphics[{Green, 
    Arrow[{{x, 4 Sqrt[9 - x^2]/3}, {(11 x)/9, (3 Sqrt[9 - x^2])/
       2}}]}], Graphics[{Red, 
    Arrow[{{x, 
       4 Sqrt[9 - x^2]/3}, {x + (6/x), (6/x) + x}}]}]], {x, .0001, 3}]






Para aprender más sobre Mathematica ingrese aquí sitio de aprendizaje de Wolfram o en mi website ustamathematica.wixsite.com/basicas

viernes, 11 de mayo de 2018

martes, 8 de mayo de 2018

Generador de Funciones en Diagrama Sagital


Dados dos conjuntos discretos X={a,b,c,d,e,f} y Y={1,2,3,4,5,6} construimos un generador de funciones del conjunto X en el conjunto Y.

puntosa = Table[Point[{0, n}], {n, -4, 6, 2}];
puntosb = Table[Point[{10, n}], {n, -4, 6, 2}];
aaa = Graphics[{Circle[{0, 0}, {3, 7}], Circle[{10, 0}, {3, 7}], 
    Circle[{5, 0}, 8, {Pi/3, 2 Pi/3}], Arrow[{{8.9, 6.95}, {9, 6.9}}],
     Text["f", {5, 7}], Text["X", {-2, 7}], Text["Y", {12, 7}], Text["a", {-1, 6}], Text["b", {-1, 4}], Text["c", {-1, 2}], Text["d", {-1, 0}], Text["e", {-1, -2}], Text["f", {-1, -4}], Text["1", {11, 6}], Text["2", {11, 4}], Text["3", {11, 2}], Text["4", {11, 0}], Text["5", {11, -2}], Text["6", {11, -4}], puntosa, puntosb}];
ran := RandomChoice[{-4, -2, 0, 2, 4, 6}]
Manipulate[
 Show[aaa, 
  If[asignar, 
   Graphics[{Red, Table[Arrow[{{0, n}, {10, ran}}], {n, -4, 6, 2}]}], 
   aaa]], {asignar, {False, True}}, SaveDefinitions -> True]



A diferencia del aplicativo anterior, ahora generamos un aplicativo que nos muestra el dominio de la función f de X en Y.

puntosa = Table[Point[{0, n}], {n, -4, 6, 2}];
puntosb = Table[Point[{10, n}], {n, -4, 6, 2}];
aaa = Graphics[{Circle[{0, 0}, {3, 7}], Circle[{10, 0}, {3, 7}], 
    Circle[{5, 0}, 8, {Pi/3, 2 Pi/3}], Arrow[{{8.9, 6.95}, {9, 6.9}}],
     Text["f", {5, 7}], Text["X", {-2, 7}], Text["Y", {12, 7}], Text["a", {-1, 6}], Text["b", {-1, 4}], Text["c", {-1, 2}], Text["d", {-1, 0}], Text["e", {-1, -2}], Text["f", {-1, -4}], Text["1", {11, 6}], Text["2", {11, 4}], Text["3", {11, 2}], Text["4", {11, 0}], Text["5", {11, -2}], Text["6", {11, -4}], puntosa, puntosb}];
ran := RandomChoice[{-4, -2, 0, 2, 4, 6}]
Manipulate[
 Show[aaa, 
  If[asignar, num = RandomInteger[{1, 5}]; 
   Graphics[{Red, 
     Table[Arrow[{{0, n}, {10, ran}}], {n, 6, 8 - 2 num, -2}], Blue, 
     Circle[{0, 7 - num}, {1.3, num}], Text["Dom(f)", {-2.7, 7 - num}]}], 
   aaa]], {asignar, {False, True}}, SaveDefinitions -> True]





Para aprender más sobre Mathematica ingrese aquí sitio de aprendizaje de Wolfram o en mi website ustamathematica.wixsite.com/basicas


viernes, 4 de mayo de 2018

Frase Célebre de Miguel de Guzmán

Una paradoja no es una desgracia, es una gran oportunidad, pues indica que hay algo profundo debajo de todo el asunto que no hemos entendido bien y que nos puede conducir a nuevos mundos.

Miguel de Guzmán

martes, 1 de mayo de 2018

Acertijo de Suma Producto



Este es un Acertijo del mismo tipo del Problema del Cumpleaños que publique el 5 de enero de 2018, donde hacia mención que utilizar Mathematica en su solución era como utilizar un tractor para arreglar el jardín de la casa, pues ahora sí es indispensable la ayuda de la computación aunque el razonamiento sea el mismo del problema del cumpleaños.

Enunciado

Se escogen dos números enteros mayores que 1 y menores que 100. A continuación, y por separado, al sujeto S se le comunica cuál es la suma de estos dos números y al sujeto P el producto de estos dos números. S sabe que P conoce el producto, P que S conoce la suma y a ninguno se le ha dicho cuáles son los números iniciales.Tras esto, S y P se reúnen y se les pregunta si saben cuáles son los números iniciales. Y eso es lo que contestan :

P : No sé cuales son estos números.
S : Sabía que no podrías saberlo.
P : Ah, pues entonces ya sé qué números son.
S : Pues entonces yo también.

Solución

Se puede determinar de forma analítica una solución, voy a dar es una solución dese el punto de vista computacional. Los invito a buscar la solución de forma analítica.

Formamos las cuartetas de todas las posibles opciones, tomando el menor de los dos números en la primera componente, en la segunda el mayor de los números, en la tercera su producto y en la cuarta su suma.

opc = Flatten[Table[{x, y, x y, x + y}, {y, 2, 99}, {x, 2, y}], 1]


La cantidad inicial de posibilidades que se tienen son:

Length[opc]
4851

P : No sé cuales son estos números.

Indica P que el número que le dijeron es un producto que se obtiene de más de una forma, por tanto hallamos todos los posibles productos que se obtienen de una sola forma

prod = Transpose[
    Select[Tally[Transpose[opc][[3]]], MemberQ[#, 1] &]][[1]];

cantidad de posibles valores que NO le pudieron dar a P

Length[prod]
1775

S : Sabía que no podrías saberlo.

Al afirmar esto dice que el valor que le dieron a S corresponde SIEMPRE a la suma de números cuyo producto se obtiene de más de una forma.
Los posibles valores que le podían dar a S son números desde 4 hasta 198, vamos a determinar para cuales de estos valores siempre corresponde a la suma de dos números cuyo producto se pueda obtener de otra forma:

noopc = {};
Do[If[IntersectingQ[Table[j (k - j), {j, 2, k - 2}], prod], 
  AppendTo[noopc, k]], {k, 4, 198}]
noopc

{4, 5, 6, 7, 8, 9, 10, 12, 13, 14, 15, 16, 18, 19, 20, 21, 22, 24,
25, 26, 28, 30, 31, 32, 33, 34, 36, 38, 39, 40, 42, 43, 44, 45, 46, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198}

Así, el posible valor que le dieron a S es uno de los siguientes:

suma = Complement[Range[4, 198], noopc]
{11, 17, 23, 27, 29, 35, 37, 41, 47, 53}

P : Ah, pues entonces ya sé qué números son.

Conociendo P el valor del producto de los números y la lista de los posibles valores que le dieron a S como la suma de ellos, determinamos todas las posibles opciones que tienen como suma los números anteriores

opc1 = {};
Do[If[MemberQ[suma, opc[[n, 4]]], AppendTo[opc1, opc[[n]]]], {n, 
  Length[opc]}]
opc1

{{5, 6, 30, 11}, {4, 7, 28, 11}, {3, 8, 24, 11}, {2, 9, 18, 11},
{8, 9, 72, 17}, {7, 10, 70, 17}, {6, 11, 66, 17}, {5, 12, 60, 17}, {11, 12, 132, 23}, {4, 13, 52, 17}, {10, 13, 130, 23},
{3, 14, 42, 17}, {9, 14, 126, 23}, {13, 14, 182, 27}, 
{2, 15, 30, 17}, {8, 15, 120, 23}, {12, 15, 180, 27}, 
{14, 15, 210, 29}, {7, 16, 112, 23}, {11, 16, 176, 27}, 
{13, 16, 208, 29}, {6, 17, 102, 23}, {10, 17, 170, 27}, 
{12, 17, 204, 29}, {5, 18, 90, 23}, {9, 18, 162, 27}, 
{11, 18, 198, 29}, {17, 18, 306, 35}, {4, 19, 76, 23}, 
{8, 19, 152, 27}, {10, 19, 190, 29}, {16, 19, 304, 35}, 
{18, 19, 342, 37}, {3, 20, 60, 23}, {7, 20, 140, 27}, 
{9, 20, 180, 29}, {15, 20, 300, 35}, {17, 20, 340, 37}, 
{2, 21, 42, 23}, {6, 21, 126, 27}, {8, 21, 168, 29}, 
{14, 21, 294, 35}, {16, 21, 336, 37}, {20, 21, 420, 41}, 
{5, 22, 110, 27}, {7, 22, 154, 29}, {13, 22, 286, 35}, 
{15, 22,330, 37}, {19, 22, 418, 41}, {4, 23, 92, 27}, 
{6, 23, 138, 29}, {12, 23, 276, 35}, {14, 23, 322, 37}, 
{18, 23, 414, 41}, {3, 24, 72, 27}, {5, 24, 120, 29}, 
{11, 24, 264, 35}, {13, 24, 312, 37}, {17, 24, 408, 41}, 
{23, 24, 552, 47}, {2, 25, 50, 27}, {4, 25, 100, 29}, 
{10, 25, 250, 35}, {12, 25, 300, 37}, {16, 25, 400, 41}, 
{22, 25, 550, 47}, {3, 26, 78, 29}, {9, 26, 234, 35}, 
{11, 26, 286, 37}, {15, 26, 390, 41}, {21, 26, 546, 47}, 
{2, 27, 54, 29}, {8,27, 216, 35}, {10, 27, 270, 37}, 
{14, 27, 378, 41}, {20, 27, 540, 47}, {26, 27, 702, 53}, 
{7, 28, 196, 35}, {9, 28, 252, 37}, {13, 28, 364, 41}, 
{19, 28, 532, 47}, {25, 28, 700, 53}, {6, 29, 174, 35}, 
{8, 29, 232, 37}, {12, 29, 348, 41}, {18, 29, 522, 47}, 
{24, 29, 696, 53}, {5, 30, 150, 35}, {7, 30, 210, 37}, 
{11, 30, 330, 41}, {17, 30, 510, 47}, {23, 30, 690, 53}, 
{4, 31, 124, 35}, {6, 31,186, 37}, {10, 31, 310, 41}, 
{16, 31, 496, 47}, {22, 31, 682, 53}, {3, 32, 96, 35}, 
{5, 32, 160, 37}, {9, 32, 288, 41}, {15, 32, 480, 47}, 
{21, 32, 672, 53}, {2, 33, 66, 35}, {4, 33, 132, 37}, 
{8, 33, 264, 41}, {14, 33, 462, 47}, {20, 33, 660, 53}, 
{3, 34, 102, 37}, {7, 34, 238, 41}, {13, 34, 442, 47}, 
{19, 34, 646, 53}, {2, 35,70, 37}, {6, 35, 210, 41}, 
{12, 35, 420, 47}, {18, 35, 630, 53}, {5, 36, 180, 41}, 
{11, 36, 396, 47}, {17, 36, 612, 53}, {4, 37,148, 41}, 
{10, 37, 370, 47}, {16, 37, 592, 53}, {3, 38, 114, 41}, 
{9, 38, 342, 47}, {15, 38, 570, 53}, {2, 39, 78, 41}, 
{8, 39, 312, 47}, {14, 39, 546, 53}, {7, 40, 280, 47}, 
{13, 40, 520, 53}, {6, 41, 246, 47}, {12, 41, 492, 53}, 
{5, 42, 210, 47}, {11, 42,462, 53}, {4, 43, 172, 47}, 
{10, 43, 430, 53}, {3, 44, 132, 47}, {9, 44, 396, 53}, 
{2, 45, 90, 47}, {8, 45, 360, 53}, {7, 46, 322, 53}, 
{6, 47, 282, 53}, {5, 48, 240, 53}, {4, 49, 196, 53}, 
{3, 50, 150, 53}, {2, 51, 102, 53}}

El posible número que conocía P, es entonces uno de los siguientes:

prod2 = Transpose[
   Select[Tally@Table[opc1[[n, 3]], {n, Length[opc1]}], 
    MemberQ[#, 1] &]][[1]]

{28, 24, 18, 52, 130, 182, 112, 176, 208, 170, 204, 162, 198, 306,
76, 152, 190, 304, 140, 340, 168, 294, 336, 110, 154, 418, 92, 138, 276, 414, 408, 552, 50, 100, 250, 400, 550, 234, 390, 54, 216, 270, 378, 540, 702, 252, 364, 532, 700, 174, 232, 348, 522, 696, 510, 690, 124, 186, 310, 496, 682, 96, 160, 288, 480, 672, 660, 238, 442, 646, 630, 612, 148, 370, 592, 114, 570, 280, 520, 246, 492, 172, 430, 360, 282, 240}

Length[prod2]
86

Las cuartetas asociadas con prod2, son:

opc2 = {};
Do[If[MemberQ[prod2, opc1[[n, 3]]], AppendTo[opc2, opc1[[n]]]], {n, 
  Length[opc1]}]
opc2

{{4, 7, 28, 11}, {3, 8, 24, 11}, {2, 9, 18, 11}, {4, 13, 52, 17}, {10, 13, 130, 23}, {13, 14, 182, 27}, {7, 16, 112, 23}, 
{11, 16, 176, 27}, {13, 16, 208, 29}, {10, 17, 170, 27}, 
{12, 17, 204, 29}, {9, 18, 162, 27}, {11, 18, 198, 29}, 
{17, 18, 306, 35}, {4, 19, 76, 23}, {8, 19, 152, 27}, 
{10, 19, 190, 29}, {16, 19, 304, 35}, {7, 20,140, 27}, 
{17, 20, 340, 37}, {8, 21, 168, 29}, {14, 21, 294, 35}, 
{16, 21, 336, 37}, {5, 22, 110, 27}, {7, 22, 154, 29}, 
{19, 22, 418, 41}, {4, 23, 92, 27}, {6, 23, 138, 29}, 
{12, 23, 276, 35}, {18, 23, 414, 41}, {17, 24, 408, 41}, 
{23, 24, 552, 47}, {2, 25, 50, 27}, {4, 25, 100, 29}, 
{10, 25, 250, 35}, {16, 25, 400, 41}, {22, 25, 550, 47}, 
{9, 26, 234, 35}, {15, 26, 390, 41}, {2, 27,54, 29}, 
{8, 27, 216, 35}, {10, 27, 270, 37}, {14, 27, 378, 41}, 
{20, 27, 540, 47}, {26, 27, 702, 53}, {9, 28, 252, 37}, 
{13, 28, 364, 41}, {19, 28, 532, 47}, {25, 28, 700, 53}, 
{6, 29, 174, 35}, {8, 29, 232, 37}, {12, 29, 348, 41}, 
{18, 29, 522, 47}, {24, 29, 696, 53}, {17, 30, 510, 47}, 
{23, 30, 690, 53}, {4, 31, 124, 35}, {6, 31, 186, 37}, 
{10, 31, 310, 41}, {16, 31, 496, 47}, {22, 31, 682, 53}, 
{3, 32, 96, 35}, {5, 32, 160, 37}, {9, 32, 288, 41}, 
{15, 32, 480, 47}, {21, 32, 672, 53}, {20, 33, 660, 53}, 
{7, 34, 238, 41}, {13, 34, 442, 47}, {19, 34, 646, 53}, 
{18, 35, 630, 53}, {17, 36, 612, 53}, {4, 37, 148, 41}, 
{10, 37, 370, 47}, {16, 37, 592, 53}, {3, 38, 114, 41}, 
{15, 38, 570, 53}, {7, 40, 280, 47}, {13, 40, 520, 53}, 
{6, 41, 246, 47}, {12, 41, 492, 53}, {4, 43,172, 47}, 
{10, 43, 430, 53}, {8, 45, 360, 53}, {6, 47, 282, 53}, 
{5, 48, 240, 53}}

Length[opc2]
86

Como cada valor del producto, tercera componente, solo aparece una vez, al conocer P el producto conocía los números. Aquí obtenemos el número y las veces que aparece:

Tally[Transpose[opc2][[3]]]

{{28, 1}, {24, 1}, {18, 1}, {52, 1}, {130, 1}, {182, 1}, {112, 1}, {176, 1}, {208, 1}, {170, 1}, {204, 1}, {162, 1}, {198, 1}, {306,1}, {76, 1}, {152, 1}, {190, 1}, {304, 1}, {140, 1}, {340,1}, {168, 1}, {294, 1}, {336, 1}, {110, 1}, {154, 1}, {418, 1}, {92, 1}, {138, 1}, {276, 1}, {414, 1}, {408, 1}, {552, 1}, {50, 1}, {100, 1}, {250, 1}, {400, 1}, {550, 1}, {234, 1}, {390, 1}, {54, 1}, {216, 1}, {270, 1}, {378, 1}, {540, 1}, {702, 1}, {252, 1}, {364,1}, {532, 1}, {700, 1}, {174, 1}, {232, 1}, {348, 1}, {522, 1}, {696,1}, {510, 1}, {690, 1}, {124, 1}, {186, 1}, {310, 1}, {496, 1}, {682,1}, {96, 1}, {160, 1}, {288, 1}, {480,1}, {672, 1}, {660, 1}, {238, 1}, {442, 1}, {646, 1}, {630, 1}, {612, 1}, {148, 1}, {370, 1}, {592,1}, {114, 1}, {570, 1}, {280, 1}, {520, 1}, {246, 1}, {492, 1}, {172,1}, {430, 1}, {360, 1}, {282, 1}, {240, 1}}


Es decir, si a P le habían dado el número 28 el sabe que los números son 4 y 7 (viendo la tabla de opc2) pues 4+7=11 está entre los posibles valores que le dieron a S. Aclaro, que la posibilidad 2 y 14 no puede ser pues 2+14=16 no está entre los posibles valores que le dieron a S (ver lista llamada suma).

S : Pues entonces yo también.

Esto quiere decir que de las posibilidades de opc2 es la suma que aparezca una sola vez

Select[Tally[Transpose[opc2][[4]]], MemberQ[#, 1] &]
{{17,1}}

Así, la cuarteta es :

Do[If[opc2[[n, 4]] == 17, Print[opc2[[n]]]], {n, Length[opc2]}]
{4,13,52,17}

Por tanto, los números son 4 y 13.

Ejercicio

Dos variaciones del problema inicial:

     Variación 1.

Vamos a considerar ahora exactamente el mismo problema pero cambiando una línea del diálogo.

P : No sé cuales son estos números.
S : Pues yo tampoco.
P : Ah, pues entonces ya sé qué números son.
S : Pues entonces yo también.

La pregunta vuelve a ser que cuales son los números iniciales. ¿Serán los mismos anteriores?
   
     Variación 2.

De nuevo consideramos el mismo problema y el diálogo va a ser el mismo que en la variación 1 pero cambiando el orden en el que hablan, es decir :

S : No sé cuales son estos números.
P : Pues yo tampoco.
S : Ah, pues entonces ya sé qué números son.
P : Pues entonces yo también.

En este caso vamos a tener un dato extra, sabemos que la suma va a ser como mucho 100 (pero P desconoce este dato).

¿Cuáles son los números iniciales? ¿Serán los mismos anteriores?


Para aprender más sobre Mathematica ingrese aquí sitio de aprendizaje de Wolfram o en mi website ustamathematica.wixsite.com/basicas