3
$\begingroup$

I cannot find the MNIST dynamic activation example I strongly believe I have seen in the documentation.

What would be the most efficient way to

  1. draw a black & white bitmap interactively
  2. have each edit evaluate a function (/ dynamic value)

?


There was a much more robust version of the below somewhere in the documentation I believe:

c // ClearAll
c[m_] := With[{w = Clip[m, {1, s}]}, a[[s - w[[2]], w[[1]]]] = 0];
a = ConstantArray[1, {s, s}];
DynamicModule[{},
  EventHandler[Dynamic@Image[a], {
    "MouseDragged" :> (c@MousePosition["Graphics"])
    }]
  ]
$\endgroup$
  • $\begingroup$ Open “Paint” or equivalent. Or open the drawing tools. $\endgroup$ – Jason B. Dec 10 '19 at 0:29
  • $\begingroup$ @JasonB. - I need immediate programmatic access to what is being painted. See my edit. $\endgroup$ – Cetin Sert Dec 10 '19 at 0:49
  • 2
    $\begingroup$ @JasonB and Cetin: Check out "Neat examples" on the Classify documentation page. The very last one seems like what you want. Unfortunately, the raw code wasn't included and would be some trouble to retrieve. $\endgroup$ – Szabolcs Dec 10 '19 at 8:09
2
$\begingroup$

With Szabolcs' reference: https://reference.wolfram.com/language/ref/Classify#1782628206

s = 64;
a = ConstantArray[1, {s, s}];
DynamicModule[{p1, p2},
 Grid[{
   {
    EventHandler[Dynamic[Image[a], TrackedSymbols :> {a}], {
      "MouseDown" :> (p1 = p2 = PixelPos[]; PaintDot[a, p1]),
      "MouseDragged" :> (p1 = p2; p2 = PixelPos[]; 
        PaintLine[a, p1, p2])
      }]
    },
   {Button["clear", a = ConstantArray[1, {s, s}]]}}
  , Frame -> True
  ]
 ]

where (need to be defined first; kindly extracted by Szabolcs from the above example):

PixelPos[] := 
 Replace[MousePosition["Graphics"], {{i_, j_} :> Round[{64 - j, i}], 
          _ :> None}]

Attributes[PaintDot] = {HoldFirst};
PaintDot[data_Symbol, p : {i1_, j1_}] := Block[{dim = Length[data]}, 
        Do[
   If[EuclideanDistance[N[{i, j}], N[p]] < 2.5, data[[i, j]] = 0.], 
          {i, Max[i1 - 3, 1], Min[i1 + 3, dim]}, {j, Max[j1 - 3, 1], 
    Min[j1 + 3, dim]}]]

Attributes[PaintLine] = {HoldFirst};
PaintLine[data_Symbol, {i1_, j1_}, 
        {i2_, j2_}] := Block[{dim, indices, ib, ie, jb, je}, 
        indices = InterpolatePoints[N[{i1, j1}], N[{i2, j2}], 2.5]; 
         {ib, ie} = Sort[{i1, i2}]; {jb, je} = 
   Sort[{j1, j2}]; {{ib, jb}, {ie, je}} = 
           Clip[{{ib, jb} - 3, {ie, je} + 3}, {1, Length[data]}]; 
         Quiet[
   Do[If[Min[(EuclideanDistance[N[{i, j}], #1] & ) /@ indices] < 
      2.5, 
               data[[i, j]] = 0.], {i, ib, ie}, {j, jb, je}]]; ]

InterpolatePoints[start$_, stop$_] := Module[{dist$, unit$}, 
        dist$ = N[EuclideanDistance[start$, stop$]]; 
  If[dist$ < 3, 
           Return[{start$, stop$}]
   ];
   unit$ = Normalize[stop$ - N[start$]];
    Append[stop$][Table[start$ + i*unit$, {i, 0, dist$, 3}]]
  ]

InterpolatePoints[p1_, p2_, r_] := 
 Module[{d, v}, d = EuclideanDistance[p1, p2]; 
         If[d < 2*r, Return[{p1, p2}]]; v = Normalize[p2 - p1]; 
         Developer`ToPackedArray[
   Append[p2][Table[p1 + i*v, {i, 0., d, r}]], Real]]
```
| improve this answer | |
$\endgroup$
  • $\begingroup$ No, they're not undocumented functions. They're defined within the Initialization :> option of that DynamicModule. You can try to extract them if you have the time and patience ... You can also try to write to Wolfram and request the code for that documentation example (I would do that). $\endgroup$ – Szabolcs Dec 10 '19 at 9:44
  • $\begingroup$ Here are the missing definitions. Can you clean them up and add them to the answer? $\endgroup$ – Szabolcs Dec 10 '19 at 15:54
  • $\begingroup$ @Szabolcs thank you for your effort in extracting them! I first thought any DynamicModule defined them during initialization. It was just the one from that example and you have extracted them - thank you! $\endgroup$ – Cetin Sert Dec 11 '19 at 1:00
  • $\begingroup$ Thanks for this useful answer. Btw, a background can be added, e.g. bg = Graphics[{Blue, Circle[{32, 32}, #] & /@ {9, 20, 30}}, PlotRange -> {{0, 64}, {0, 64}}, ImageSize -> 64] by replacing Image[a] with Show[Graphics[Inset[Image[a, ImageSize -> s]]], bg, PlotRange -> {{0, s}, {0, s}}, ImageSize -> s] $\endgroup$ – Chris Degnen May 24 at 18:27

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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