Post has attachment
How can we classify this structure from Mathematical view point ?

Post has attachment
Yo uso MATHEMATICA
Yo uso MATHEMATICA
plus.google.com

Post has attachment
mathematics using lines

Post has shared content
Project Euler Problem #8

Find the greatest product of five consecutive digits in the 1000-digit number.

73167176531330624919225119674426574742355349194934
96983520312774506326239578318016984801869478851843
85861560789112949495459501737958331952853208805511
12540698747158523863050715693290963295227443043557
66896648950445244523161731856403098711121722383113
62229893423380308135336276614282806444486645238749
30358907296290491560440772390713810515859307960866
70172427121883998797908792274921901699720888093776
65727333001053367881220235421809751254540594752243
52584907711670556013604839586446706324415722155397
53697817977846174064955149290862569321978468622482
83972241375657056057490261407972968652414535100474
82166370484403199890008895243450658541227588666881
16427171479924442928230863465674813919123162824586
17866458359124566529476545682848912883142607690042
24219022671055626321111109370544217506941658960408
07198403850962455444362981230987879927244284909188
84580156166097919133875499200524063689912560717606
05886116467109405077541002256983155200055935729725
71636269561882670428252483600823257530420752963450

--------------------------------------------------------------------------------------

This is the next question (after #4) where you have to do more than just calling a built in function in Wolfram Language (for the sake of brevity I will call Wolfram Language from now on Wolfram)

When I first read the question I found immediately remembered to a question google once asked on a billboard in Silicon Valley on southbound Highway 101 near Ralston, California in July 2004 (see picture).

Questions like this are something like a showcase of Wolfram capabilities.

With Wolfram you can describe the problem as easily as follows:

    partition the the digits of e into sub-lists of length 10 and pick
    the first one which is prime:

    Select[FromDigits /@ Partition[First@RealDigits[E, 10, 1000], 10, 1], PrimeQ, 1]

    => 7427466391

We may use a similar technique to tackle the above question:

    1) partition the list in chunks of list of length = 5
    
here we get a, for instance, a sub-list consisting of {7, 3, 1, 6}, for the first partition. In order now to multiply the elements out we need to use Apply or @@ as a shortcut:

    Times@@{7, 3, 1, 6} => 882

    2) do this for every sub-list and pick the Max

    Max[Times @@#& /@ Partition[First@RealDigits["number from above"], 5, 1]] 

And immediately we will get the correct result: 40824.

Conclusion: Very often it is quite useful, if you are trained in problem solving, because oftenly one problem is just a variation of another one, which you might have seen before or even solved.
Photo

Post has shared content
Project Euler Problem #4

A palindromic number reads the same both ways. The largest palindrome made from the product of two 2-digit numbers is 9009 = 91 × 99.

Find the largest palindrome made from the product of two 3-digit numbers.

----------------------------------------------------------------------------------------------------

This seems to be the first of the problems, where usage of WL/Mathematica does seem to make sense.

There are several solutions to this problem. 

1. Brute force method

iterate through a multiplication table from 100 up to 999 and pick those where the constraint holds. In order not to get to many results we need to create the complement of the multiplication table (since several results occurs more than once):

    Max@Select[Table[i*j],{i,100, 999}, {j, 100, 999}] // Flatten // Complement, IntegerDigits[#] == Reverse[IntegerDigits[#]& ]

which yields after about three seconds the correct result 906609.

Let's see if we can speed up things.

2. Intersect with the list of palindrome numbers

What we know is, that the product of two 3-digit numbers will yield a six-digit number.
So, let's first of all generate all 6-digit palindromic numbers:

    1000 # + FromDigits@Reverse@IntegerDigits[#]&/@ Range[100, 999]

which yields:

    {100001, 101101, 102201, 103301, ... , 999999}

Next we intersect this with the multiplication table, but this time we're using Outer in combination with Times for producing the table:

    Intersection[1000 # + FromDigits@Reverse@IntegerDigits[#]&/@ Range[100, 999], Flatten@Outer[Times, Range[100, 999], Range[110, 990, 11]]] // Max

now this yields in 0.0080 seconds the result 906609.
Our second approach seems to be extremely fast for this problem and we may stop here.

The conclusion could be, although the second approach is not so much different from the first brute-force variant, it seizes the fact, that Wolfram Language is extremely fast when it comes to pattern matching. We create every number, but we are not checking if the specific constraint holds, but pick those elements which intersect and select the maximum number of it.

Update of an old chaos program:
Clear[x, y, z, K, Tau]
gradient = {{0., {0, 0, 0.5}}, {0.1, {0, 0, 1}}, {0.2, {0, 0.5,
     1}}, {0.3, {0, 1, 1}}, {0.4, {0, 1, 0.5}}, {0.5, {0.5, 1,
     0}}, {0.6, {1, 0.5, 0}}, {0.7, {1, 1, 0}}, {0.8, {0.5, 0.5,
     0}}, {0.9, {1, 0, 0}}, {1, {0.5, 0, 0}}};
Gradient2[x_, grad_] :=
  Module[{i = 1, n = Length[grad]},
   While[i <= n && grad[[i, 1]] < x, i++];
   RGBColor @@
    If[1 < i <= n,
     Module[{x1 = grad[[i - 1, 1]],
       x2 = grad[[i,
         1]]}, ((x2 - x) grad[[i - 1, 2]] + (x - x1) grad[[i,
           2]])/(x2 - x1)], grad[[Min[i, n], 2]]]];
(* simple Chaotic system: the Serret-Frenet equations*)
(* by Roger \
L. Bagula 20 Aug 2013©*)
ComplexExpand[(x[t] + I*y[t])^3]
(* curvature*)
K[t_] = 1 - (x[t]^3 - 3 x[t] y[t]^2)/3
(* torsion*)
Tau[t_] = 3  x[t]^2 y[t] - y[t]^3
NDSolve[ {x'[t] ==  K[t]*y[t],
            y'[t] == -K[t]*x[t] + Tau[t]*z[t],
            z'[t] == -Tau[t]*y[t],
            x[0] == 1/Sqrt[3], z[0] == 0, y[0] == 1},
         {x, y, z}, {t, -500, 500}, MaxSteps -> 75000 ]
g1 = ParametricPlot3D[Evaluate[{x[t], y[t], z[t]} /. %],
                           {t, -500, 500}, PlotPoints -> 10000,
  PlotRange -> All, Boxed -> False, Axes -> False,
  ColorFunction -> (Gradient2[#, gradient] &), ImageSize -> 1000,
  Background -> Black]

Kummer octahedral implicit:
gradient = {{0., {0, 0, 0.5}}, {0.1, {0, 0, 1}}, {0.2, {0, 0.5,
     1}}, {0.3, {0, 1, 1}}, {0.4, {0, 1, 0.5}}, {0.5, {0.5, 1,
     0}}, {0.6, {1, 0.5, 0}}, {0.7, {1, 1, 0}}, {0.8, {0.5, 0.5,
     0}}, {0.9, {1, 0, 0}}, {1, {0.5, 0, 0}}};
Gradient2[x_, grad_] :=
  Module[{i = 1, n = Length[grad]},
   While[i <= n && grad[[i, 1]] < x, i++];
   RGBColor @@
    If[1 < i <= n,
     Module[{x1 = grad[[i - 1, 1]],
       x2 = grad[[i,
         1]]}, ((x2 - x) grad[[i - 1, 2]] + (x - x1) grad[[i,
           2]])/(x2 - x1)], grad[[Min[i, n], 2]]]];
mu = Sqrt[1/3]
x1 = Cos[x]
y1 = Cos[y]
z1 = Cos[z]
w = Sqrt[x1^2 + y1^2 + z1^2]
l = (3*mu^2 - 1)/(3 - mu^2)
p = w - x1
q = w + x1
r = w - y1
s = w + y1
u = w + z1
v = w - z1
f[x_, y_, z_] =
 Simplify[(x1^2 + y1^2 + z1^2 - mu^2*w^2)^3 - l*p*q*r*s*u*v]

  fermiplot[energy_] :=
          ContourPlot3D[
           f[kx, ky, kz],
           {kx, -Pi, Pi}, {ky, -Pi, Pi}, {kz, -Pi, Pi},
   PlotPoints -> 6,
                   Contours -> {energy}, Boxed -> False,
   Axes -> False, Mesh -> False,
   ColorFunction -> (Gradient2[#, gradient] &)];
gg = Table[fermiplot[0.000001 + i], {i, 0, 2, 0.25}]
Export["Kummer_octahedral.mov", gg]
Show[gg, ImageSize -> 1000, Background -> Black]

Post has attachment
A Switched Menger cross of crosses:
pieces =
   Complement[
     Flatten[Table[{i, j, k}, {i, 0, 4}, {j, 0, 4}, {k, 0, 4}],
       2],
  Union[Flatten[
    Table[{{1, 2, i}, {2, 1, i}, {2, 2, i}, {2, 3, i}, {3, 2, i}, {1,
       i, 2}, {2, i, 1}, {2, i, 2}, {2, i, 3}, {3, i, 2}, {i, 1,
       2}, {i, 2, 1}, {i, 2, 2}, {i, 2, 3}, {i, 3, 2}}, {i, 0, 4}],
    1]]]

 a = Flatten[Table[{i, j, k}, {i, 0, 4}, {j, 0, 4}, {k, 0, 4}],
      2]

pieces0 = Complement[a, pieces]

 menger[cornerPt_, sideLen_, n_] := If[Mod[n, 2] == 0,
    menger[cornerPt + #1*(sideLen/5), sideLen/5, n - 1] & /@ pieces0,
  menger[cornerPt + #1*(sideLen/5), sideLen/5, n - 1] & /@ pieces]
 menger[cornerPt_, sideLen_, 0] :=
   {Cyan, EdgeForm[],
  Cuboid[cornerPt, cornerPt + sideLen*{1, 1, 1}]}


cc = Show[Graphics3D[Flatten[menger[{0, 0, 0}, 1, 2]]],
  Boxed -> False, ImageSize -> 1000, Background -> Black]
Photo

A pretty 3d surface:
Clear[f, g, h, k]
(* sinoid egg shaped parametric*)
a = 1; b = -1/2;
f[t_] = {Cos[t], -2 + Exp[a + b*Sin[t]]/Exp[a + b]};
ParametricPlot[f[t], {t, 0, 2*Pi}]
(* definition of evolute algorithm*)
g[t_] = D[f[t], t];
h[t_] = D[g[t], t];
k = Det[{g[t], h[t]}];
e[t_] = f[t] + {-g[t][[2]], g[t][[1]]}/k;
ParametricPlot[{f[t], e[t]}, {t, 0, 2*Pi}]
(* 3d projection of the evolute*)
ga =
 ParametricPlot3D[{e[t][[1]]*Cos[p], e[t][[1]]*Sin[p],
   e[t][[2]]}, {t, -Pi, Pi}, {p, -Pi/2, Pi/2},
  ViewPoint -> {1.455, 3.050, 0.177}, Axes -> False, Boxed -> False,
  Mesh -> False, PlotPoints -> 40, ColorFunction -> "CMYKColors",
  ImageSize -> 1000]

Post has attachment
Wait while more posts are being loaded