Re: [Dmug] QR G. Thunberg

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

Ein Zwischenschrittchen

Clear[qrFull]
qrFull = Import[
  FileNameJoin[{NotebookDirectory[], "test", "QR_G_Thunberg.jpg"}],
  "JPEG"]

(* es sollte eine 29 x 29 Version 3 QR Code sein *)
Clear[qr]
qr = ImageTake[qrFull, {680, 1450}, {1230, 1930}]

euclidM =
  ComponentMeasurements[
   Binarize[qr, {.0, .7}], {"Centroid",
    "EquivalentDiskRadius"}, #AdjacentBorderCount == 0 &&
     2 < #Area < 50 &];


Clear[noneR]
noneR[v_List?VectorQ, n_List?VectorQ] := (v /. (Rule[#, \[Iota]] & /@ 
n)) /; ContainsAll[v, n]

(* erneut unautomatisiert *)
Clear[skipL]
skipL = {56, 57, 62, 61, 75, 79, 83, 95, 104, 110, 113, 116, 119, 114,
    117, 124, 120, 125, 130, 138, 141, 150, 158, 168, 169, 177, 175,
   179, 188, 187, 199, 197, 209, 210, 221, 220, 232, 239, 240, 250,
   251, 266, 268, 276, 277, 287, 300, 308, 318, 366, 369, 410, 414,
   457, 453, 435, 430, 434, 425, 422, 419, 417, 413, 424, 411, 408,
   405, 455, 449, 442, 450, 445, 451, 448, 406, 441, 409, 398, 397,
   401, 402, 403, 436 , 437, 438, 439, 377, 372, 373, 351, 340, 342,
   334, 323, 325, 320, 321, 315, 312, 316, 310, 303, 306, 301, 302,
   296, 292, 290, 280, 282, 283, 284, 274, 272, 275, 264, 265, 260,
   259, 249, 244, 245, 234, 235, 236, 224, 225, 226, 222, 211, 217,
   212, 206, 202, 203, 201, 195, 192, 190, 193, 184, 180, 182, 171,
   172, 170, 167, 162, 164, 161, 155, 156, 152, 154, 146, 144, 147,
   143, 137, 135, 133, 102, 103, 90, 96, 91, 92, 84, 313};


Clear[gitteR]
(* das sollen die Punkte von eqM (hat 338 Punkte) sein, die nicht das 
Label '\[Iota]' (Iota) haben. ski*)
gitteR :=
 Part[Select[Select[euclidM, (52 <= #[[1]] <= 457) &], 
(!IntersectingQ[{#[[1]]}, skipL]) & ], All, 2, 1]

(* Abbildung von gitteR auf ein quadratisches Gitter, mit dieser 
Abbildung soll auch das Bild transformiert werden. *)
Graphics[{PointSize[.011], Point[gitteR]}, Frame -> True, GridLines -> 
Transpose[gitteR]]

Export[FileNameJoin[{NotebookDirectory[], "test", "QR-real-def.jpg"}], 
%21, "JPEG"]


...


Grüsse

Udo.

Am 28.07.2021 um 20:28 schrieb Susanne & Udo Krause via demug:
> 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]
>
>
> _______________________________________________
> DMUG Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch
> http://www.mathematica.ch/mailman/listinfo/demug
> Archiv: http://www.mathematica.ch/archiv.html

QR-real-def.jpg
Description: JPEG image

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