37
$\begingroup$

I was trying to create a Matrix falling code image with Mathematica. Here is my code:

mcolors=Blend[{{0.00,Darker[Green,0.7]},{0.90,Darker@Green},{0.90,Lighter[Green]},{1.00,Lighter[Green,0.9]}},#]&;
(*DensityPlot[x,{x,0,1},{y,0,1},ColorFunction\[Rule]mcolors,ColorFunctionScaling\[Rule]False,AspectRatio\[Rule]0.2]*)

stringColum[n_,opacity_]:=Module[{letters,fallingCode},

  letters=MapIndexed[Text@Style[#1,mcolors[#2[[1]]/n],Opacity[opacity],Bold,14,FontFamily->"Courier"]&,FromCharacterCode/@RandomInteger[{48,90},n]];  

  fallingCode=Column[
    letters
    ,Background->None
    ,Spacings->-0.4
    ,Alignment->Center
  ]
]

layer1=Graphics[Table[Inset[stringColum[RandomInteger[{1,30}],1.0],Scaled[{i,RandomReal[{0.7,1}]}],Top],{i,0.000,1,0.05}],PlotRange->All];
layer2=Graphics[Table[Inset[stringColum[RandomInteger[{1,30}],0.4],Scaled[{i,RandomReal[{0.7,1}]}],Top],{i,0.025,1,0.05}],PlotRange->All];

Show[layer1,layer2,AspectRatio->1,Background-> Black,ImageSize-> {600,500}]

Where I get as result images like this:

enter image description here

Not very exciting when compared to this one: enter image description here

How can I improve that?

Some itens that I see.

  1. I see a blur that I don't know as to reproduce using Blur, for different layers.
  2. The letter are not just A to Z letters.
  3. The columns space are not linear.
  4. I don't like the way I handler all the code. It's sound to complex in Graphics part.
Improve this question
$\endgroup$
6
  • 2
    $\begingroup$ +1, but perhaps borderline as asked right now (the popular confetti question had the same issue and was edited to be a bit more specific...) $\endgroup$
    – Yves Klett
    Mar 3, 2013 at 18:40
  • 1
    $\begingroup$ Agree with Yves... AFAICT this "letter-fall" has no real application, so if you're just asking how to reproduce a particular visual effect then it's too localized almost by definition. Notice that the example you give for comparison avoids punctuation, but includes Hebrew, Greek, and Cyrillic letters; the darker columns also appear to be blurred. This might make it more visually interesting. $\endgroup$
    – Oleksandr R.
    Mar 3, 2013 at 19:05
  • 4
    $\begingroup$ Yes, it's just for fun. Just like snow fall, confetti question, animated avatar, fountain effect so on. I don't see any problem on that. $\endgroup$
    – Murta
    Mar 3, 2013 at 19:56
  • 1
    $\begingroup$ I don't personally object to the question, but until now there seemed to be a firm concensus that "how do I draw a certain arbitrary figure/visual effect" isn't a sufficiently general topic to justify its posting here and we should not allow such questions to proliferate much further than the above examples. Far from wishing to spoil anyone's fun, my point is simply that if new users are going to get downvoted into oblivion for such questions, we should be consistent in our treatment. I didn't downvote either, but I do think it's TL. $\endgroup$
    – Oleksandr R.
    Mar 4, 2013 at 12:07
  • 1
    $\begingroup$ @OleksandrR. Hi. In your example (I draw a certain ...) in my opinion the major problem is the fact that the user didn't try to work on the question, and the question itself if boring. He just asks for some solution from zero. I believe that questions like Matrix, XKCD and so one, are important in the capture and motivation of new MMA/SE users, and should be officially allowed. I recognize that is't difficult to objectively apart good from bad ones, but maybe we can let votes work for it. $\endgroup$
    – Murta
    Mar 4, 2013 at 12:16

2 Answers 2

Reset to default
46
$\begingroup$

First, define the dimensions and colors associated with our matrix:

{mheight, mwidth} = mdim = {12, 20};
mdepth = 20;

mcolors = 
  Reverse@Array[
    Blend[{{0, Darker[Green, 0.9]}, {0.4, Darker[Green]}, {0.6, 
        Darker[Green]}, {0.90, Lighter[Green]}, {1, 
        Lighter[Green, 0.8]}}, #/(mdepth - 1)] &, mdepth, 0];

Next, define some useful character ranges:

crange[digits] = Range[48, 57];
crange[punc] = 
  Join[Range[33, 47], Range[58, 64], Range[91, 96], Range[123, 126]];
crange[lower] = Range[97, 122];
crange[upper] = Range[65, 90];
crange[hebrew] = Range[1488, 1514];
crange[greeklower] = Range[945, 969];
crange[greekupper] = DeleteCases[Range[913, 937], 930];
crange[cyrillicupper] = Range[1040, 1071];
crange[cyrilliclower] = Range[1072, 1103];
crange[katakana] = Range[12449, 12538];
crange[hiragana] = Range[12353, 12438];
crange[hangul] = Range[44032, 55211];
crange[hanzi] = Range[13312, 19901];

If you look at the matrix image, they don't really use that many funny characters, just a sprinkling, and they don't use all available sets. Here's a nice mix:

mrandomchar := 
 FromCharacterCode[
  RandomChoice[
   crange[RandomChoice[{0.5, 0.1, 0.3, 0.01, 0.04, 0.04} -> {digits, 
       punc, upper, katakana, greeklower, cyrillicupper}]]]]

The graphic will be made by masking characters onto swatches of our colors, which we make here:

black = Rasterize[
   Grid[{{""}}, Background -> Black, ItemSize -> {1, 1}, 
    Spacings -> 0], Background -> Black, RasterSize -> 20, 
   ImageSize -> 20];

greens = Rasterize[
     Grid[{{""}}, Background -> #, ItemSize -> {1, 1}, Spacings -> 0],
      Background -> #, RasterSize -> 20, ImageSize -> 20 ] & /@ 
   mcolors;

We initialize the matrix to blackness and add a drip in the middle to start things off:

init := Module[{},
  drips = {{0, mwidth/2}}; ClearAll[matrix];
  matrix = Array[{mdepth + 1, black} &, mdim];]

At each step, we let the drips drip down one square. We add new drips with Poisson-distributed probability with expectation 0.8 drips per step. Each time a character has achieved 1/5 of maximum age, we blur it more and we track the age of each character. We also throw some random character blips in with Poisson expectation 0.5 per step.

step := Module[{}, 
  drips = Join[
    Select[# + {1, 0} & /@ drips, First[#] <= mheight &], {1, #} & /@ 
     RandomInteger[{1, mwidth}, {Random[PoissonDistribution[0.8]]}]]; 
  matrix = Map[
    If[#[[1]] >= mdepth, {mdepth + 1, black}, {#[[1]] + 1, 
       If[Mod[#[[1]], Ceiling[mdepth/5]] == 0, Blur, Identity][#[[
         2]]]}] &, 
    matrix, {2}]; (matrix[[##]] = {1, 
       Rasterize[
        Grid[{{Style[mrandomchar, mcolors[[1]], 
            FontFamily -> "Courier", FontWeight -> Bold]}}, 
         Background -> Black, ItemSize -> {1, 1}, Spacings -> 0], 
        Background -> Black, RasterSize -> 20, ImageSize -> 20]}) & @@@
    Join[drips,(*dots*)
    Table[{RandomInteger[{1, mheight}], 
      RandomInteger[{1, mwidth}]}, {Random[
       PoissonDistribution[0.5]]}]];]

Iterate this for a hundred steps to get a nice animation:

init; anim = {};
Monitor[Do[step; AppendTo[anim, matrix], {i, 100}], i]

Render the graphic:

Parallelize[
 Show[ImageAssemble[
     Map[If[#[[1]] <= mdepth, 
        ImageMultiply[greens[[#[[1]]]], #[[2]]], #[[2]]] &, #, {2}]], 
    ImageSize -> Automatic] & /@ anim]

Resulting in

Matrix

EDIT: Update for speed! I originally envisioned this answer as being updated in real-time, not just exported to a graphic. These improvements will get us closer. First, prerender all our characters; calls to Rasterize take at least 0.3s, which is too long for dynamic updating. As long as we don't prerender Hangul or Hanzi, this takes less than a minute and a few MB.

(raster[#] = 
    ColorConvert[
     Rasterize[
      Grid[{{Style[FromCharacterCode[#], White, 
          FontFamily -> "Courier", FontWeight -> Bold]}}, 
       ItemSize -> {1, 1}], Background -> Black, RasterSize -> 20, 
      ImageSize -> 200], "Grayscale"]) & /@ 
 Join @@ (crange /@ {digits, punc, lower, upper, hebrew, greeklower, 
     greekupper, cyrilliclower, cyrillicupper, katakana, hiragana});

Now we just need a random code instead of a random character:

mrandomcode := 
 RandomChoice[
  crange[RandomChoice[{0.5, 0.1, 0.3, 0.01, 0.04, 0.04} -> {digits, 
      punc, upper, hebrew, greeklower, cyrillicupper}]]]

Make sure that our black is also in grayscale; in this new scheme, we don't need the greens at all, just the colors.

black = ColorConvert[
  Rasterize[Grid[{{""}}, ItemSize -> {1, 1}], Background -> Black, 
   RasterSize -> 20, ImageSize -> 20], "Grayscale"]

This lets us take the expensive calls to Rasterize out of our update step. Reversing the update order saves us calls to Blur when the blurred character is about to get clobbered anyway.

step := (drips = 
   Join[Select[# + {1, 0} & /@ drips, 
     First[#] <= mheight &], {1, #} & /@ 
     RandomInteger[{1, mwidth}, {Random[PoissonDistribution[0.8]]}]];
  (matrix[[##]] = {0, raster[mrandomcode]}) & @@@ 
   Join[drips,(*dots*)
    Table[{RandomInteger[{1, mheight}], 
      RandomInteger[{1, mwidth}]}, {Random[
       PoissonDistribution[0.5]]}]];
  matrix = 
   Map[If[#[[1]] >= mdepth, {mdepth + 1, black}, {#[[1]] + 1, 
       If[Mod[#[[1]], Ceiling[mdepth/5]] == 0 && #[[1]] > 0, Blur, 
         Identity][#[[2]]]}] &, matrix, {2}])

On my system, step now takes 0.06s and the render takes 0.08s, so now we can enjoy the proceedings in a dynamic graphic:

Dynamic[Show[
  ImageAssemble[
   Map[If[#[[1]] <= mdepth, 
      ImageMultiply[#[[2]], mcolors[[Max[1, #[[1]]]]]], #[[2]]] &, 
    matrix, {2}]], ImageSize -> Automatic]]
init;
anim = Table[step, {i, 100}];
Improve this answer
$\endgroup$
5
  • $\begingroup$ Coooolll!!... I was not expecting an animation!.. All the memory, distributions and fades are really nice code +1!! $\endgroup$
    – Murta
    Mar 4, 2013 at 2:41
  • $\begingroup$ @Xerxes: Very nice. All this might make a very nice CDF or demonstration for demonstrations.wolfram.com E.g., controls could control character sets, size, color, etc. $\endgroup$
    – Rolf Mertig
    Mar 4, 2013 at 20:30
  • $\begingroup$ @RolfMertig Yes, I was thinking of that for later updates. Some of these cute notebooks just turn into endless rabbit holes of just-one-more improvements... $\endgroup$
    – Xerxes
    Mar 4, 2013 at 20:33
  • $\begingroup$ BTW: wikipedia and adobe after effects tutorial ... $\endgroup$
    – Rolf Mertig
    Mar 4, 2013 at 20:52
  • $\begingroup$ If you are going to create a CDF, I suggest you to have a text field where the user can write it name, and the name sporadically falls in some strings. Create your own Matrix :) $\endgroup$
    – Murta
    Mar 4, 2013 at 21:03
18
$\begingroup$

You could start to scrape allowed characters in that font, e.g.:

mcolors = 
  Blend[{{0.00, Darker[Green, 0.7]}, {0.90, Darker@Green}, {0.90, 
      Lighter[Green]}, {1.00, Lighter[Green, 0.9]}}, #] &;
$unic := $unic = 
   Join[{"\[Wolf]", "\[MathematicaIcon]", "\[HappySmiley]"}, 
    Drop[ToExpression[
        "\"" <> StringReplace[#, "U+" -> "\\:"] <> "\""] & /@ 
      Cases[Import[
        "http://www.fileformat.info/info/unicode/font/courier_new/\
list.htm", {"HTML", "Data"}], u_String /; StringMatchQ[u, "U+*"], -1],
      4]];

stringColum[n_, opacity_] := Module[{letters, fallingCode},

  letters = 
   MapIndexed[
    Text@Style[#1, mcolors[#2[[1]]/n], Opacity[opacity], Bold, 14, 
       FontFamily -> "Courier"] &, RandomChoice[$unic, n]];
  fallingCode = 
   Column[letters, Background -> None, Spacings -> -0.4, 
    Alignment -> Center]]

layer1 = Graphics[
   Table[Inset[stringColum[RandomInteger[{1, 30}], 1.0], 
     Scaled[{i, RandomReal[{0.7, 1}]}], Top], {i, 0.000, 1, 0.05}], 
   PlotRange -> All];
layer2 = Graphics[
   Table[Inset[stringColum[RandomInteger[{1, 30}], 0.4], 
     Scaled[{i, RandomReal[{0.7, 1}]}], Top], {i, 0.025, 1, 0.05}], 
   PlotRange -> All];

Show[layer1, layer2, AspectRatio -> 1, Background -> Black, 
 ImageSize -> {600, 500}]

Mathematica graphics

Improve this answer
$\endgroup$
2
  • $\begingroup$ Wow.. nice strange characters list! +1 $\endgroup$
    – Murta
    Mar 3, 2013 at 19:59
  • $\begingroup$ for some fun: rColumns[x_, n_, time_] := Text[stringColum[n, 1.0], Dynamic@{x, Clock[{40, -40, -.2}, time]}]; Graphics[ Table[rColumns[i, RandomInteger[{5, 40}], RandomInteger[{2, 5}]], {i, -12, 12}], PlotRange -> {{-15, 15}, {-10, 10}}, Background -> Black, ImageSize -> 500] $\endgroup$
    – halmir
    Mar 5, 2013 at 3:10

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.