[Dmug] QR G. Thunberg

[Susanne & Udo Krause via demug <demug@XXXXXXX.ch>]

Liebe Freundinnen und Freunde der seitlichen Arabeske,


G. Thunberg hat letzthin einen Kreuzstich getwittert,

------------------------------------------------------------------------
Greta Thunberg (@GretaThunberg) Tweeted:
https://t.co/2h9WzM82z5 
https://twitter.com/GretaThunberg/status/1416801148145651715?s=20
------------------------------------------------------------------------

(QR_G_Thunberg.jpg) - was sagt der QR Code?

Clear[qr2]
qr2 = ImageTake[
  ImageTransformation[
   ImageTransformation[
     LocalAdaptiveBinarize[
     ImageResize[ImageTake[qrFull, {680, 1450}, {1230, 1930}],
      Scaled[1.2]], 20, {0.45, 0.1, 0.02}],
    RotationTransform[3. Degree]
    ],
   ShearingTransform[1.6 Degree, {1, 0}, {0, 1}]
   ],
  {128, 823}, {68, 763}
  ]


ergibt einen mühsam achsparallelen Ausschnitt (Bild 
QR_G_Thunberg_2.jpg). Weil sie einen Finger drauf hat, gibt es eh' 
Korrekturen, also zunächst hier kein weiterer Aufwand - der kommt dann 
noch.  Das digitalisiert 🤪man etwas

Clear[qrMatrix]
qrMatrix = ArrayReshape[If[# > 1, 1, 0] & /@ 
Flatten[ImageForestingComponents[qr2]],
   ImageDimensions[qr2]];

zu

Clear[qrm2]
qrm2 = subArray[qrMatrix[[1 ;; 31*22, 1 ;; 31*22]], 22, 22];

(Die Marke linkts oben erscheint bei 106. Die Marke rechts unten 
erscheint bei 136), was einen unbrauchbaren QR Code

MatrixPlot[
 Map[If[# < 136, 0, 1] &,
   Map[Count[#, 1, Infinity] &, qrm2, {2}], {2}][[2 ;; 30, 3 ;; 31]],
 ColorFunction -> "Monochrome", Frame -> False]

darstellt (QR_Thunberg_Raw.png).

Die folgenden händischen Korrekturen ergeben sich aus der Sichtkontrolle

With[{barr = 136},
 q = Map[If[# < barr, 0, 1] &,
    Map[Count[#, 1, Infinity] &, qrm2, {2}], {2}][[2 ;; 30, 3 ;; 31]];
 q[[1, 10]] = 1;
 q[[1, 14]] = 0;
 q[[1, 15]] = 1;
 q[[1, 16]] = 0;
 (* left upper marker *)
 q[[1, 25 ;; 29]] = 1;
 q[[2 ;; 3, 29]] = 1;
 q[[3, 24]] = 0;
 q[[4 ;; 5, 22]] = 0;
 q[[6, 29]] = 1;
 (* left side left upper marker *)
 q[[3, 18]] = 0;
 q[[3, 20]] = 0;
 q[[5, 19]] = 0;
 q[[6, 17]] = 0;
 q[[7, 18]] = 0;
 q[[7, 21]] = 1;
 (* l.h.s, below the marker *)
 q[[12, 2]] = 1;
 (* r.h.s. below the marker *)
 q[[9 ;; 10, 28]] = 0;
 q[[9, 21]] = 0;
 q[[9, 24]] = 0;(* -- *)
 q[[10 ;; 11, 22]] = 0;
 q[[12, 28]] = 0;
 q[[12, 29]] = 1;
 q[[14 ;; 15, 29]] = 1;
 (* the lower middle *)
 q[[14 ;; 15, 16]] = 0;
 q[[15, 23]] = 0;
 q[[16, 21]] = 0;
 (* shift the right lower subarray *)
 q1 = q[[16 ;; 29, 17 ;; 28]];
 q[[16 ;; 29, 18 ;; 29]] = q1;
 q[[16, 18]] = 0;
 q[[16, 26]] = 0;
 q[[17, 23]] = 0;
 q[[19, 18]] = 0;
 q[[18, 19]] = 1;
 q[[18, 21]] = 1;
 (* left lower marker *)
 q[[27, 5]] = 1;
 q[[27 ;; 28, 6]] = 0;
 q[[28 ;; 29, 7]] = 1;
 q[[26, 8]] = 0;
 q[[28, 8]] = 0;
 q[[28 ;; 29, 9]] = 1;
 (* correct the rest *)
 q[[20, 12]] = 0;
 q[[20, 19]] = 0;
 q[[20, 23]] = 0;
 q[[21 ;; 22, 13]] = 1;
 q[[21, 14]] = 0;
 q[[21, 16]] = 1;
 q[[21, 17]] = 0;
 q[[25, 10]] = 0;
 q2 = q[[27 ;; 28, 14 ;; 16]];
 q[[27, 14 ;; 16]] = 0;
 q[[28 ;; 29, 15 ;; 17]] = q2;
 q[[24, 13]] = 0;
 q[[25, 12]] = 0;
 q[[26, 11]] = 0;
 q[[25, 11]] = 1;
 q[[25, 13]] = 1;
 q[[27 ;; 28, 12]] = 1;
 q[[26, 13]] = 1;
 q[[28, 14]] = 0;
 q[[27, 14]] = 1;
 q[[26, 15]] = 0;
 q[[26, 16 ;; 17]] = 1;
 q[[23, 20]] = 1;
 q[[27, 20]] = 0;
 q[[27, 21]] = 0;
 q[[27, 22]] = 1;
 q[[28, 24]] = 1;
 q[[29, 20 ;; 21]] = 1;
 q[[29, 26]] = 1;
 q[[29, 28]] = 1;
 (* q becomes the final qrm3; ca. 70 Korrekturschritte -> sehr 
schlechte Automatisierung: viel mehr, als der Finger verdeckt. *)
 MatrixPlot[q, ColorFunction -> "Monochrome", Frame -> False]
 ]

exportiert und importiert

Export[FileNameJoin[{NotebookDirectory[], "test", 
"QR_G_Thunberg_3.png"}], %, "PNG"]

Clear[qr3]
qr3 = Import[FileNameJoin[{NotebookDirectory[], "test", 
"QR_G_Thunberg_3.png"}], "PNG"]

gelingt die Entschlüsselung:

In[19]:= BarcodeRecognize[qr3]
Out[19]= "https://www.youtube.com/watch?v=dQw4w9WgXcQ";


Bingo  (spoiler alert: es ist ein Musikvideo) & Grüsse

Udo.


P.S. 1: Ein bessere Automatisierung sollte sich ergeben, wenn das im 
Bild verformte quadratischer Kreuzstichgitter samt Bild auf ein 
quadratisches Gitter abgebildet wird, eine Rotation und eine Scherung 
beseitigen die Deformationen zu wenig.


P.S. 2: die Hilfsfunktion

Clear[subArray]
(* subdivide the array a into subarrays of r0 rows and c0 columns *)
subArray[a_, r0_Integer?Positive, c0_Integer?Positive] :=
 Block[{r1, c1},
   {r1, c1} = Take[Dimensions[a], 2]/{r0, c0};
   If[! VectorQ[{r1, c1}, IntegerQ],
    Print["{", r0, ",", c0,
     "} does not devide the first two dimensions. Bye."];
    Return[$Failed]
    ];
   Outer[a[[#1, #2]] &,
    Span @@@ Transpose[{Range[1, r0  r1, r0], Range[r0, r0 r1, r0]}],
    Span @@@ Transpose[{Range[1, c0 c1, c0], Range[c0, c0 c1, c0]}]
    ]
   ] /; ArrayQ[a]

QR_G_Thunberg.jpg
Description: JPEG image

QR_G_Thunberg_2.jpg
Description: JPEG image

QR_G_Thunberg_Raw.png
Description: PNG image

QR_G_Thunberg_3.png
Description: PNG image

_______________________________________________
DMUG Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch
http://www.mathematica.ch/mailman/listinfo/demug
Archiv: http://www.mathematica.ch/archiv.html