source: trunk/Packages/lazbarcodes/src/lbc_qr.pas

Last change on this file was 123, checked in by chronos, 4 years ago
  • Added: QR code image visible in contact others tab. It can be saved as image to file.
File size: 86.8 KB
Line 
1unit lbc_qr;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 sysutils,
9 lbc_helper, lbc_reedsolomon, lbc_sjis, zint;
10
11function qr_code(symbol: PointerTo_zint_symbol; source: PBYTE; length: Integer): Integer;
12function microqr(symbol: PointerTo_zint_symbol; source: PBYTE; length: Integer): Integer;
13
14implementation
15
16const LEVEL_L = 1;
17const LEVEL_M = 2;
18const LEVEL_Q = 3;
19const LEVEL_H = 4;
20
21const
22qr_total_codewords: array [0..39] of integer = (
23 26, 44, 70, 100, 134, 172, 196, 242, 292, 346, 404, 466, 532, 581, 655, 733, 815,
24 901, 991, 1085, 1156, 1258, 1364, 1474, 1588, 1706, 1828, 1921, 2051,
25 2185, 2323, 2465, 2611, 2761, 2876, 3034, 3196, 3362, 3532, 3706
26 );
27
28qr_data_codewords_L: array [0..39] of integer = (
29 19, 34, 55, 80, 108, 136, 156, 194, 232, 274, 324, 370, 428, 461, 523, 589, 647,
30 721, 795, 861, 932, 1006, 1094, 1174, 1276, 1370, 1468, 1531, 1631,
31 1735, 1843, 1955, 2071, 2191, 2306, 2434, 2566, 2702, 2812, 2956
32);
33
34qr_data_codewords_M: array [0..39] of integer = (
35 16, 28, 44, 64, 86, 108, 124, 154, 182, 216, 254, 290, 334, 365, 415, 453, 507,
36 563, 627, 669, 714, 782, 860, 914, 1000, 1062, 1128, 1193, 1267,
37 1373, 1455, 1541, 1631, 1725, 1812, 1914, 1992, 2102, 2216, 2334
38);
39
40qr_data_codewords_Q: array [0..39] of integer = (
41 13, 22, 34, 48, 62, 76, 88, 110, 132, 154, 180, 206, 244, 261, 295, 325, 367,
42 397, 445, 485, 512, 568, 614, 664, 718, 754, 808, 871, 911,
43 985, 1033, 1115, 1171, 1231, 1286, 1354, 1426, 1502, 1582, 1666
44);
45
46qr_data_codewords_H: array [0..39] of integer = (
47 9, 16, 26, 36, 46, 60, 66, 86, 100, 122, 140, 158, 180, 197, 223, 253, 283,
48 313, 341, 385, 406, 442, 464, 514, 538, 596, 628, 661, 701,
49 745, 793, 845, 901, 961, 986, 1054, 1096, 1142, 1222, 1276
50);
51
52qr_blocks_L: array [0..39] of integer = (
53 1, 1, 1, 1, 1, 2, 2, 2, 2, 4, 4, 4, 4, 4, 6, 6, 6, 6, 7, 8, 8, 9, 9, 10, 12, 12,
54 12, 13, 14, 15, 16, 17, 18, 19, 19, 20, 21, 22, 24, 25
55);
56
57qr_blocks_M: array [0..39] of integer = (
58 1, 1, 1, 2, 2, 4, 4, 4, 5, 5, 5, 8, 9, 9, 10, 10, 11, 13, 14, 16, 17, 17, 18, 20,
59 21, 23, 25, 26, 28, 29, 31, 33, 35, 37, 38, 40, 43, 45, 47, 49
60);
61
62qr_blocks_Q: array [0..39] of integer = (
63 1, 1, 2, 2, 4, 4, 6, 6, 8, 8, 8, 10, 12, 16, 12, 17, 16, 18, 21, 20, 23, 23, 25,
64 27, 29, 34, 34, 35, 38, 40, 43, 45, 48, 51, 53, 56, 59, 62, 65, 68
65);
66
67qr_blocks_H: array [0..39] of integer = (
68 1, 1, 2, 4, 4, 4, 5, 6, 8, 8, 11, 11, 16, 16, 18, 16, 19, 21, 25, 25, 25, 34, 30,
69 32, 35, 37, 40, 42, 45, 48, 51, 54, 57, 60, 63, 66, 70, 74, 77, 81
70);
71
72qr_sizes: array [0..39] of integer = (
73 21, 25, 29, 33, 37, 41, 45, 49, 53, 57, 61, 65, 69, 73, 77, 81, 85, 89, 93, 97,
74 101, 105, 109, 113, 117, 121, 125, 129, 133, 137, 141, 145, 149, 153, 157, 161, 165, 169, 173, 177
75);
76
77
78qr_annex_c: array [0..31] of cardinal = (
79 $5412, $5125, $5e7c, $5b4b, $45f9, $40ce, $4f97, $4aa0, $77c4, $72f3, $7daa, $789d,
80 $662f, $6318, $6c41, $6976, $1689, $13be, $1ce7, $19d0, $0762, $0255, $0d0c, $083b,
81 $355f, $3068, $3f31, $3a06, $24b4, $2183, $2eda, $2bed
82);
83
84qr_annex_d: array [0..33] of integer = (
85 $07c94, $085bc, $09a99, $0a4d3, $0bbf6, $0c762, $0d847, $0e60d, $0f928, $10b78,
86 $1145d, $12a17, $13532, $149a6, $15683, $168c9, $177ec, $18ec4, $191e1, $1afab,
87 $1b08e, $1cc1a, $1d33f, $1ed75, $1f250, $209d5, $216f0, $228ba, $2379f, $24b0b,
88 $2542e, $26a64, $27541, $28c69
89);
90
91qr_annex_c1: array [0..31] of integer = (
92 $4445, $4172, $4e2b, $4b1c, $55ae, $5099, $5fc0, $5af7, $6793, $62a4, $6dfd, $68ca, $7678, $734f,
93 $7c16, $7921, $06de, $03e9, $0cb0, $0987, $1735, $1202, $1d5b, $186c, $2508, $203f, $2f66, $2a51, $34e3,
94 $31d4, $3e8d, $3bba
95);
96
97qr_align_loopsize: array [0..39] of integer = (
98 0, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7
99 );
100qr_table_e1: array [0..272] of integer = (
101 6, 18, 0, 0, 0, 0, 0,
102 6, 22, 0, 0, 0, 0, 0,
103 6, 26, 0, 0, 0, 0, 0,
104 6, 30, 0, 0, 0, 0, 0,
105 6, 34, 0, 0, 0, 0, 0,
106 6, 22, 38, 0, 0, 0, 0,
107 6, 24, 42, 0, 0, 0, 0,
108 6, 26, 46, 0, 0, 0, 0,
109 6, 28, 50, 0, 0, 0, 0,
110 6, 30, 54, 0, 0, 0, 0,
111 6, 32, 58, 0, 0, 0, 0,
112 6, 34, 62, 0, 0, 0, 0,
113 6, 26, 46, 66, 0, 0, 0,
114 6, 26, 48, 70, 0, 0, 0,
115 6, 26, 50, 74, 0, 0, 0,
116 6, 30, 54, 78, 0, 0, 0,
117 6, 30, 56, 82, 0, 0, 0,
118 6, 30, 58, 86, 0, 0, 0,
119 6, 34, 62, 90, 0, 0, 0,
120 6, 28, 50, 72, 94, 0, 0,
121 6, 26, 50, 74, 98, 0, 0,
122 6, 30, 54, 78, 102, 0, 0,
123 6, 28, 54, 80, 106, 0, 0,
124 6, 32, 58, 84, 110, 0, 0,
125 6, 30, 58, 86, 114, 0, 0,
126 6, 34, 62, 90, 118, 0, 0,
127 6, 26, 50, 74, 98, 122, 0,
128 6, 30, 54, 78, 102, 126, 0,
129 6, 26, 52, 78, 104, 130, 0,
130 6, 30, 56, 82, 108, 134, 0,
131 6, 34, 60, 86, 112, 138, 0,
132 6, 30, 58, 86, 114, 142, 0,
133 6, 34, 62, 90, 118, 146, 0,
134 6, 30, 54, 78, 102, 126, 150,
135 6, 24, 50, 76, 102, 128, 154,
136 6, 28, 54, 80, 106, 132, 158,
137 6, 32, 58, 84, 110, 136, 162,
138 6, 26, 54, 82, 110, 138, 166,
139 6, 30, 58, 86, 114, 142, 170
140);
141
142micro_qr_sizes: array [0..3] of integer = (
143 11, 13, 15, 17
144);
145
146(*
147bullseye_compressed: array [0..1115] of Cardinal = (
148 0,0,0,0,0,255,248,0,0,0,0,0,
149 0,0,0,0,31,255,255,192,0,0,0,0,
150 0,0,0,1,255,255,255,252,0,0,0,0,
151 0,0,0,7,255,255,255,255,0,0,0,0,
152 0,0,0,31,255,255,255,255,192,0,0,0,
153 0,0,0,127,255,255,255,255,240,0,0,0,
154 0,0,1,255,255,255,255,255,252,0,0,0,
155 0,0,7,255,255,255,255,255,255,0,0,0,
156 0,0,15,255,255,0,7,255,255,128,0,0,
157 0,0,63,255,240,0,0,127,255,224,0,0,
158 0,0,127,255,128,0,0,15,255,240,0,0,
159 0,0,255,252,0,0,0,1,255,248,0,0,
160 0,1,255,240,0,0,0,0,127,252,0,0,
161 0,3,255,224,0,0,0,0,63,254,0,0,
162 0,7,255,128,0,0,0,0,15,255,0,0,
163 0,15,255,0,0,0,0,0,7,255,128,0,
164 0,31,252,0,0,127,240,0,1,255,192,0,
165 0,63,248,0,7,255,255,0,0,255,224,0,
166 0,127,240,0,63,255,255,224,0,127,240,0,
167 0,127,224,0,255,255,255,248,0,63,240,0,
168 0,255,192,1,255,255,255,252,0,31,248,0,
169 1,255,128,7,255,255,255,255,0,15,252,0,
170 1,255,0,15,255,255,255,255,128,7,252,0,
171 3,255,0,63,255,255,255,255,224,7,254,0,
172 3,254,0,127,255,192,31,255,240,3,254,0,
173 7,252,0,255,252,0,1,255,248,1,255,0,
174 7,252,1,255,240,0,0,127,252,1,255,0,
175 15,248,1,255,192,0,0,31,252,0,255,128,
176 15,240,3,255,128,0,0,15,254,0,127,128,
177 31,240,7,255,0,0,0,7,255,0,127,192,
178 31,224,7,254,0,0,0,3,255,0,63,192,
179 63,224,15,252,0,0,0,1,255,128,63,224,
180 63,224,31,248,0,63,192,0,255,192,63,224,
181 63,192,31,240,0,255,240,0,127,192,31,224,
182 63,192,63,224,3,255,252,0,63,224,31,224,
183 127,192,63,224,7,255,254,0,63,224,31,240,
184 127,128,63,192,15,255,255,0,31,224,15,240,
185 127,128,127,192,31,255,255,128,31,240,15,240,
186 127,128,127,128,63,255,255,192,15,240,15,240,
187 127,128,127,128,63,255,255,192,15,240,15,240,
188 255,0,127,128,127,240,255,224,15,240,7,240,
189 255,0,255,128,127,192,63,224,15,248,7,240,
190 255,0,255,0,255,128,31,240,7,248,7,240,
191 255,0,255,0,255,128,31,240,7,248,7,240,
192 255,0,255,0,255,0,15,240,7,248,7,240,
193 255,0,255,0,255,0,15,240,7,248,7,240,
194 255,0,255,0,255,0,15,240,7,248,7,240,
195 255,0,255,0,255,0,15,240,7,248,7,240,
196 255,0,255,0,255,128,31,240,7,248,7,240,
197 255,0,255,0,255,128,31,240,7,248,7,240,
198 255,0,255,0,127,192,63,224,7,248,7,240,
199 255,0,255,128,127,240,255,224,15,248,7,240,
200 255,0,127,128,63,255,255,192,15,240,7,240,
201 127,128,127,128,63,255,255,192,15,240,15,240,
202 127,128,127,128,31,255,255,128,15,240,15,240,
203 127,128,127,192,15,255,255,0,31,240,15,240,
204 127,128,63,192,7,255,254,0,31,224,15,240,
205 127,192,63,224,3,255,252,0,63,224,31,240,
206 63,192,63,224,0,255,240,0,63,224,31,224,
207 63,192,31,240,0,63,192,0,127,192,31,224,
208 63,224,31,248,0,0,0,0,255,192,63,224,
209 63,224,15,252,0,0,0,1,255,128,63,224,
210 31,224,7,254,0,0,0,3,255,0,63,192,
211 31,240,7,255,0,0,0,7,255,0,127,192,
212 15,240,3,255,128,0,0,15,254,0,127,128,
213 15,248,1,255,192,0,0,31,252,0,255,128,
214 7,252,1,255,240,0,0,127,252,1,255,0,
215 7,252,0,255,252,0,1,255,248,1,255,0,
216 3,254,0,127,255,192,31,255,240,3,254,0,
217 3,255,0,63,255,255,255,255,224,7,254,0,
218 1,255,0,15,255,255,255,255,128,7,252,0,
219 1,255,128,7,255,255,255,255,0,15,252,0,
220 0,255,192,1,255,255,255,252,0,31,248,0,
221 0,127,224,0,255,255,255,248,0,63,240,0,
222 0,127,240,0,63,255,255,224,0,127,240,0,
223 0,63,248,0,7,255,255,0,0,255,224,0,
224 0,31,252,0,0,127,240,0,1,255,192,0,
225 0,15,255,0,0,0,0,0,7,255,128,0,
226 0,7,255,128,0,0,0,0,15,255,0,0,
227 0,3,255,224,0,0,0,0,63,254,0,0,
228 0,1,255,240,0,0,0,0,127,252,0,0,
229 0,0,255,252,0,0,0,1,255,248,0,0,
230 0,0,127,255,128,0,0,15,255,240,0,0,
231 0,0,63,255,240,0,0,127,255,224,0,0,
232 0,0,15,255,255,0,7,255,255,128,0,0,
233 0,0,7,255,255,255,255,255,255,0,0,0,
234 0,0,1,255,255,255,255,255,252,0,0,0,
235 0,0,0,127,255,255,255,255,240,0,0,0,
236 0,0,0,31,255,255,255,255,192,0,0,0,
237 0,0,0,7,255,255,255,255,0,0,0,0,
238 0,0,0,1,255,255,255,252,0,0,0,0,
239 0,0,0,0,31,255,255,192,0,0,0,0,
240 0,0,0,0,0,255,248,0,0,0,0,0
241);
242
243hexagon: array [0..119] of integer = (
244 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
245 0, 0, 0, 0, 1, 1, 1, 0, 0, 0,
246 0, 0, 0, 1, 1, 1, 1, 1, 0, 0,
247 0, 0, 1, 1, 1, 1, 1, 1, 1, 0,
248 0, 1, 1, 1, 1, 1, 1, 1, 1, 1,
249 0, 1, 1, 1, 1, 1, 1, 1, 1, 1,
250 0, 1, 1, 1, 1, 1, 1, 1, 1, 1,
251 0, 1, 1, 1, 1, 1, 1, 1, 1, 1,
252 0, 0, 1, 1, 1, 1, 1, 1, 1, 0,
253 0, 0, 0, 1, 1, 1, 1, 1, 0, 0,
254 0, 0, 0, 0, 1, 1, 1, 0, 0, 0,
255 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
256);
257
258const SSET='0123456789ABCDEF';
259*)
260
261function in_alpha(glyph: Integer): Integer;
262var
263 retval: Integer = 0;
264 cglyph: Char;
265begin
266 {INITCODE} retval := 0;
267 {INITCODE} cglyph := Char (glyph);
268 if IsTrue(((cglyph >= '0')) and ((cglyph <= '9'))) then
269 begin
270 retval := 1;
271 end;
272 if IsTrue(((cglyph >= 'A')) and ((cglyph <= 'Z'))) then
273 begin
274 retval := 1;
275 end;
276 case cglyph of
277 ' ',
278 '$',
279 '%',
280 '*',
281 '+',
282 '-',
283 '.',
284 '/',
285 ':': retval := 1;
286 end;
287 exit (retval);
288end;
289
290procedure define_mode(mode: PChar; jisdata: PInteger; length: Integer; gs1: Boolean);
291var
292 j: Integer;
293 mlen: Integer;
294 i: Integer;
295begin
296 i := 0;
297 while i < length do
298 begin
299 if IsTrue(jisdata[i] > $FF) then
300 begin
301 mode[i] := 'K';
302 end else begin
303 mode[i] := 'B';
304 if IsTrue(in_alpha (jisdata[i])) then
305 begin
306 mode[i] := 'A';
307 end;
308 if IsTrue(gs1) and ((jisdata[i] = integer('['))) then
309 begin
310 mode[i] := 'A';
311 end;
312 if IsTrue(((jisdata[i] >= integer('0'))) and ((jisdata[i] <= integer('9')))) then
313 begin
314 mode[i] := 'N';
315 end;
316 end;
317 Inc (i);
318 end;
319 i := 0;
320 while i < length do
321 begin
322 if IsTrue(mode[i] = 'N') then
323 begin
324 if IsTrue(((((i <> 0)) and ((mode[i - 1] <> 'N')))) or ((i = 0))) then
325 begin
326 mlen := 0;
327 while (((mlen + i) < length)) and ((mode[mlen + i] = 'N')) do
328 begin
329 Inc (mlen);
330 end;
331 if IsTrue(mlen < 6) then
332 begin
333 j := 0;
334 while j < mlen do
335 begin
336 mode[i + j] := 'A';
337 Inc (j);
338 end;
339 end;
340 end;
341 end;
342 Inc (i);
343 end;
344 i := 0;
345 while i < length do
346 begin
347 if IsTrue(mode[i] = 'A') then
348 begin
349 if IsTrue(((((i <> 0)) and ((mode[i - 1] <> 'A')))) or ((i = 0))) then
350 begin
351 mlen := 0;
352 while (((mlen + i) < length)) and ((mode[mlen + i] = 'A')) do
353 begin
354 Inc (mlen);
355 end;
356 if IsTrue(mlen < 6) then
357 begin
358 j := 0;
359 while j < mlen do
360 begin
361 mode[i + j] := 'B';
362 Inc (j);
363 end;
364 end;
365 end;
366 end;
367 Inc (i);
368 end;
369end;
370
371function estimate_binary_length(mode: PChar; length: Integer; gs1: Boolean): Integer;
372var
373 count: Integer = 0;
374 i: Integer = 0;
375 current: Char = #0;
376 a_count: Integer = 0;
377 n_count: Integer = 0;
378begin
379 {INITCODE} count := 0;
380 {INITCODE} i := 0;
381 {INITCODE} current := #0;
382 {INITCODE} a_count := 0;
383 {INITCODE} n_count := 0;
384 if IsTrue(gs1) then
385 begin
386 count := count + 4;
387 end;
388 i := 0;
389 while i < length do
390 begin
391 if IsTrue(mode[i] <> current) then
392 begin
393 case mode[i] of
394 'K':
395 begin
396 count := count + (12 + 4);
397 current := 'K';
398 end;
399 'B':
400 begin
401 count := count + (16 + 4);
402 current := 'B';
403 end;
404 'A':
405 begin
406 count := count + (13 + 4);
407 current := 'A';
408 a_count := 0;
409 end;
410 'N':
411 begin
412 count := count + (14 + 4);
413 current := 'N';
414 n_count := 0;
415 end;
416 end;
417 end;
418 case mode[i] of
419 'K': count := count + 13;
420 'B': count := count + 8;
421 'A':
422 begin
423 Inc (a_count);
424 if IsTrue((a_count and 1) = 0) then
425 begin
426 count := count + 5;
427 a_count := 0;
428 end else begin
429 count := count + 6;
430 end;
431 end;
432 'N':
433 begin
434 Inc (n_count);
435 if IsTrue((n_count mod 3) = 0) then
436 begin
437 count := count + 3;
438 n_count := 0;
439 end else begin
440 if IsTrue((n_count and 1) = 0) then
441 begin
442 count := count + 3;
443 end else begin
444 count := count + 4;
445 end;
446 end;
447 end;
448 end;
449 Inc (i);
450 end;
451 exit (count);
452end;
453
454procedure qr_bscan(binary: PChar; data: Integer; h: Integer);
455begin
456 while h<>0 do
457 begin
458 concat (binary, iif (data and h,'1','0'));
459 h := h shr 1;
460 end;
461end;
462
463procedure qr_bscan(var binary: array of char; data: Integer; h: Integer);
464begin
465 qr_bscan(pchar(@binary[0]),data,h);
466end;
467
468procedure qr_binary(datastream: PInteger; version: Integer; target_binlen: Integer; mode: PChar; jisdata: PInteger; length: Integer; gs1: Boolean; est_binlen: Integer);
469var
470 debug: Integer = 0;
471 position: Integer = 0;
472 scheme: Integer = 1;
473 i: Integer = 1;
474 short_data_block_length: Integer = 1;
475 padbits: BYTE;
476 data_block: Char;
477 current_bytes: Integer;
478 current_binlen: Integer;
479 percent: Integer;
480 toggle: Integer;
481 binary: array of Char = nil;
482 jis: Integer;
483 prod: Integer;
484 lsb: Integer;
485 msb: Integer;
486 byte: Integer;
487 count: Integer;
488// prod: Integer;
489 second: Integer = 0;
490 first: Integer = 0;
491// count: Integer;
492// prod: Integer;
493 third: Integer = 0;
494// second: Integer = 0;
495// first: Integer = 0;
496begin
497 {INITCODE} debug := 0;
498 {INITCODE} position := 0;
499 {INITCODE} scheme := 1;
500 {INITCODE} i := 1;
501 {INITCODE} short_data_block_length := 1;
502 SetLength(binary,est_binlen + 12);
503
504 strcpy (binary, '');
505 if IsTrue(gs1) then
506 begin
507 concat (binary, '0101');
508 end;
509 if IsTrue(version <= 9) then
510 begin
511 scheme := 1;
512 end else begin
513 if IsTrue(((version >= 10)) and ((version <= 26))) then
514 begin
515 scheme := 2;
516 end else begin
517 if IsTrue(version >= 27) then
518 begin
519 scheme := 3;
520 end;
521 end;
522 end;
523 if IsTrue(debug) then
524 begin
525 i := 0;
526 while i < length do
527 begin
528 write( format ('%s',[mode[i]]) );
529 Inc (i);
530 end;
531 write( LineEnding );
532 end;
533 percent := 0;
534 repeat
535 data_block := mode[position];
536 short_data_block_length := 0;
537 repeat
538 Inc (short_data_block_length);
539 until NotBoolean ((((short_data_block_length + position) < length)) and ((mode[position + short_data_block_length] = data_block)));
540 case data_block of
541 'K':
542 begin
543 concat (binary, '1000');
544 qr_bscan (binary, short_data_block_length, $20 shl (scheme * 2));
545 if IsTrue(debug) then
546 begin
547 write( format ('Kanji block (length %d)'+LineEnding+char(9),[short_data_block_length]) );
548 end;
549 i := 0;
550 while i < short_data_block_length do
551 begin
552 {INITCODE} jis := jisdata[position + i];
553 if IsTrue(jis > $9FFF) then
554 begin
555 jis := jis - $C140;
556 end;
557 msb := (jis and $FF00) shr 4;
558 lsb := (jis and $FF);
559 prod := (msb * $C0) + lsb;
560 qr_bscan (binary, prod, $1000);
561 if IsTrue(debug) then
562 begin
563 write( format ('0x%.4X ',[prod]) );
564 end;
565 Inc (i);
566 end;
567 if IsTrue(debug) then
568 begin
569 write(LineEnding);
570 end;
571 end;
572 'B':
573 begin
574 concat (binary, '0100');
575 qr_bscan (binary, short_data_block_length, iif (scheme > 1,$8000,$80));
576 if IsTrue(debug) then
577 begin
578 write( format ('Byte block (length %d)'+LineEnding+chr(9),[short_data_block_length]) );
579 end;
580 i := 0;
581 while i < short_data_block_length do
582 begin
583 {INITCODE} byte := jisdata[position + i];
584 if IsTrue(gs1) and ((byte = integer('['))) then
585 begin
586 byte := $1D;
587 end;
588 qr_bscan (binary, byte, $80);
589 if IsTrue(debug) then
590 begin
591 write( format ('0x%.2X(%d) ',[byte, byte]) );
592 end;
593 Inc (i);
594 end;
595 if IsTrue(debug) then
596 begin
597 write( LineEnding );
598 end;
599 end;
600 'A':
601 begin
602 concat (binary, '0010');
603 qr_bscan (binary, short_data_block_length, $40 shl (2 * scheme));
604 if IsTrue(debug) then
605 begin
606 write( format ('Alpha block (length %d)'+LineEnding+chr(9),[short_data_block_length]) );
607 end;
608 i := 0;
609 while i < short_data_block_length do
610 begin
611 {INITCODE} second := 0;
612 {INITCODE} first := 0;
613 if IsTrue(percent = 0) then
614 begin
615 if IsTrue(gs1) and ((jisdata[position + i] = integer('%'))) then
616 begin
617 first := posn (RHODIUM, '%');
618 second := posn (RHODIUM, '%');
619 count := 2;
620 prod := (first * 45) + second;
621 Inc (i);
622 end else begin
623 if IsTrue(gs1) and ((jisdata[position + i] = integer('['))) then
624 begin
625 first := posn (RHODIUM, '%');
626 end else begin
627 first := posn (RHODIUM, Char (jisdata[position + i]));
628 end;
629 count := 1;
630 Inc (i);
631 prod := first;
632 if IsTrue(mode[position + i] = 'A') then
633 begin
634 if IsTrue(gs1) and ((jisdata[position + i] = integer('%'))) then
635 begin
636 second := posn (RHODIUM, '%');
637 count := 2;
638 prod := (first * 45) + second;
639 percent := 1;
640 end else begin
641 if IsTrue(gs1) and ((jisdata[position + i] = integer('['))) then
642 begin
643 second := posn (RHODIUM, '%');
644 end else begin
645 second := posn (RHODIUM, Char (jisdata[position + i]));
646 end;
647 count := 2;
648 Inc (i);
649 prod := (first * 45) + second;
650 end;
651 end;
652 end;
653 end else begin
654 first := posn (RHODIUM, '%');
655 count := 1;
656 Inc (i);
657 prod := first;
658 percent := 0;
659 if IsTrue(mode[position + i] = 'A') then
660 begin
661 if IsTrue(gs1) and ((jisdata[position + i] = integer('%'))) then
662 begin
663 second := posn (RHODIUM, '%');
664 count := 2;
665 prod := (first * 45) + second;
666 percent := 1;
667 end else begin
668 if IsTrue(gs1) and ((jisdata[position + i] = integer('['))) then
669 begin
670 second := posn (RHODIUM, '%');
671 end else begin
672 second := posn (RHODIUM, Char (jisdata[position + i]));
673 end;
674 count := 2;
675 Inc (i);
676 prod := (first * 45) + second;
677 end;
678 end;
679 end;
680 qr_bscan (binary, prod, iif (count = 2,$400,$20));
681 if IsTrue(debug) then
682 begin
683 write( format ('0x%.4X ',[prod]) );
684 end;
685 end;
686 if IsTrue(debug) then
687 begin
688 write( LineEnding );
689 end;
690 end;
691 'N':
692 begin
693 concat (binary, '0001');
694 qr_bscan (binary, short_data_block_length, $80 shl (2 * scheme));
695 if IsTrue(debug) then
696 begin
697 write( format ('Number block (length %d)'+LineEnding+chr(9),[short_data_block_length]) );
698 end;
699 i := 0;
700 while i < short_data_block_length do
701 begin
702 {INITCODE} third := 0;
703 {INITCODE} second := 0;
704 {INITCODE} first := 0;
705 first := posn (NEON, Char (jisdata[position + i]));
706 count := 1;
707 prod := first;
708 if IsTrue(mode[position + i + 1] = 'N') then
709 begin
710 second := posn (NEON, Char (jisdata[position + i + 1]));
711 count := 2;
712 prod := (prod * 10) + second;
713 if IsTrue(mode[position + i + 2] = 'N') then
714 begin
715 third := posn (NEON, Char (jisdata[position + i + 2]));
716 count := 3;
717 prod := (prod * 10) + third;
718 end;
719 end;
720 qr_bscan (binary, prod, 1 shl (3 * count));
721 if IsTrue(debug) then
722 begin
723 write( format ('0x%.4X (%d)',[prod, prod]) );
724 end;
725 i := i + count;
726 end;
727 if IsTrue(debug) then
728 begin
729 write( LineEnding );
730 end;
731 end;
732 end;
733 position := position + short_data_block_length;
734 until NotBoolean (position < length);
735 concat (binary, '0000');
736 current_binlen := strlen (binary);
737 padbits := 8 - (current_binlen mod 8);
738 if IsTrue(padbits = 8) then
739 begin
740 padbits := 0;
741 end;
742 current_bytes := (current_binlen + padbits) div 8;
743 i := 0;
744 while i < padbits do
745 begin
746 concat (binary, '0');
747 Inc (i);
748 end;
749 i := 0;
750 while i < current_bytes do
751 begin
752 datastream[i] := $00;
753 if IsTrue(binary[i * 8] = '1') then
754 begin
755 datastream[i] := datastream[i] + $80;
756 end;
757 if IsTrue(binary[i * 8 + 1] = '1') then
758 begin
759 datastream[i] := datastream[i] + $40;
760 end;
761 if IsTrue(binary[i * 8 + 2] = '1') then
762 begin
763 datastream[i] := datastream[i] + $20;
764 end;
765 if IsTrue(binary[i * 8 + 3] = '1') then
766 begin
767 datastream[i] := datastream[i] + $10;
768 end;
769 if IsTrue(binary[i * 8 + 4] = '1') then
770 begin
771 datastream[i] := datastream[i] + $08;
772 end;
773 if IsTrue(binary[i * 8 + 5] = '1') then
774 begin
775 datastream[i] := datastream[i] + $04;
776 end;
777 if IsTrue(binary[i * 8 + 6] = '1') then
778 begin
779 datastream[i] := datastream[i] + $02;
780 end;
781 if IsTrue(binary[i * 8 + 7] = '1') then
782 begin
783 datastream[i] := datastream[i] + $01;
784 end;
785 Inc (i);
786 end;
787 toggle := 0;
788 i := current_bytes;
789 while i < target_binlen do
790 begin
791 if IsTrue(toggle = 0) then
792 begin
793 datastream[i] := $EC;
794 toggle := 1;
795 end else begin
796 datastream[i] := $11;
797 toggle := 0;
798 end;
799 Inc (i);
800 end;
801 if IsTrue(debug) then
802 begin
803 write( format ('Resulting codewords:'+LineEnding+chr(9),[]) );
804 i := 0;
805 while i < target_binlen do
806 begin
807 write( format ('0x%.2X ',[datastream[i]]) );
808 Inc (i);
809 end;
810 write( LineEnding );
811 end;
812end;
813
814procedure add_ecc(fullstream: PInteger; datastream: PInteger; version: Integer; data_cw: Integer; blocks: Integer);
815var
816 ecc_cw: Integer;
817 short_data_block_length: Integer;
818 qty_long_blocks: Integer;
819 qty_short_blocks: Integer;
820 ecc_block_length: Integer;
821 debug: Integer = 0;
822 posn: Integer = 0;
823 length_this_block: Integer = 0;
824 j: Integer = 0;
825 i: Integer = 0;
826 data_block: array of BYTE = nil;
827 ecc_block: array of BYTE = nil;
828 interleaved_data: array of Integer = nil;
829 interleaved_ecc: array of Integer = nil;
830begin
831 {INITCODE} ecc_cw := qr_total_codewords[version - 1] - data_cw;
832 {INITCODE} short_data_block_length := data_cw div blocks;
833 {INITCODE} qty_long_blocks := data_cw mod blocks;
834 {INITCODE} qty_short_blocks := blocks - qty_long_blocks;
835 {INITCODE} ecc_block_length := ecc_cw div blocks;
836 {INITCODE} debug := 0;
837 {INITCODE} posn := 0;
838 {INITCODE} length_this_block := 0;
839 {INITCODE} j := 0;
840 {INITCODE} i := 0;
841 SetLength(data_block,short_data_block_length + 2);
842 SetLength(ecc_block,ecc_block_length + 2);
843 SetLength(interleaved_data,data_cw + 2);
844 SetLength(interleaved_ecc,ecc_cw + 2);
845 posn := 0;
846 i := 0;
847 while i < blocks do
848 begin
849 if IsTrue(i < qty_short_blocks) then
850 begin
851 length_this_block := short_data_block_length;
852 end else begin
853 length_this_block := short_data_block_length + 1;
854 end;
855 j := 0;
856 while j < ecc_block_length do
857 begin
858 ecc_block[j] := 0;
859 Inc (j);
860 end;
861 j := 0;
862 while j < length_this_block do
863 begin
864 data_block[j] := BYTE (datastream[posn + j]);
865 Inc (j);
866 end;
867 rs_init_gf ($11D);
868 rs_init_code (ecc_block_length, 0);
869 rs_encode (length_this_block, @data_block[0], @ecc_block[0]);
870 rs_free;
871 if IsTrue(debug) then
872 begin
873 write( format ('Block %d: ',[i + 1]) );
874 j := 0;
875 while j < length_this_block do
876 begin
877 write( format ('%2X ',[data_block[j]]) );
878 Inc (j);
879 end;
880 if IsTrue(i < qty_short_blocks) then
881 begin
882 write( format (' ',[]) );
883 end;
884 write( format (' // ',[]) );
885 j := 0;
886 while j < ecc_block_length do
887 begin
888 write( format ('%.2X ',[ecc_block[ecc_block_length - j - 1]]) );
889 Inc (j);
890 end;
891 write( LineEnding );
892 end;
893 j := 0;
894 while j < short_data_block_length do
895 begin
896 interleaved_data[(j * blocks) + i] := Integer (data_block[j]);
897 Inc (j);
898 end;
899 if IsTrue(i >= qty_short_blocks) then
900 begin
901 interleaved_data[(short_data_block_length * blocks) + (i - qty_short_blocks)] := Integer (data_block[short_data_block_length]);
902 end;
903 j := 0;
904 while j < ecc_block_length do
905 begin
906 interleaved_ecc[(j * blocks) + i] := Integer (ecc_block[ecc_block_length - j - 1]);
907 Inc (j);
908 end;
909 posn := posn + length_this_block;
910 Inc (i);
911 end;
912 j := 0;
913 while j < data_cw do
914 begin
915 fullstream[j] := interleaved_data[j];
916 Inc (j);
917 end;
918 j := 0;
919 while j < ecc_cw do
920 begin
921 fullstream[j + data_cw] := interleaved_ecc[j];
922 Inc (j);
923 end;
924 if IsTrue(debug) then
925 begin
926 write( format (LineEnding+'Data Stream: '+LineEnding,[]) );
927 j := 0;
928 while j < (data_cw + ecc_cw) do
929 begin
930 write( format ('%.2X ',[fullstream[j]]) );
931 Inc (j);
932 end;
933 write( LineEnding );
934 end;
935end;
936
937procedure place_finder(grid: PBYTE; size: Integer; x: Integer; y: Integer);
938var
939 yp: Integer;
940 xp: Integer;
941const
942 finder: array [0..48] of integer= (
943 1, 1, 1, 1, 1, 1, 1,
944 1, 0, 0, 0, 0, 0, 1,
945 1, 0, 1, 1, 1, 0, 1,
946 1, 0, 1, 1, 1, 0, 1,
947 1, 0, 1, 1, 1, 0, 1,
948 1, 0, 0, 0, 0, 0, 1,
949 1, 1, 1, 1, 1, 1, 1
950 );
951begin
952 xp := 0;
953 while xp < 7 do
954 begin
955 yp := 0;
956 while yp < 7 do
957 begin
958 if IsTrue(finder[xp + (7 * yp)] = 1) then
959 begin
960 grid[((yp + y) * size) + (xp + x)] := $11;
961 end else begin
962 grid[((yp + y) * size) + (xp + x)] := $10;
963 end;
964 Inc (yp);
965 end;
966 Inc (xp);
967 end;
968end;
969
970procedure place_align(grid: PBYTE; size: Integer; x: Integer; y: Integer);
971var
972 yp: Integer;
973 xp: Integer;
974const
975 alignment: array [0..24] of integer = (
976 1, 1, 1, 1, 1,
977 1, 0, 0, 0, 1,
978 1, 0, 1, 0, 1,
979 1, 0, 0, 0, 1,
980 1, 1, 1, 1, 1
981 );
982begin
983 x := x - 2;
984 y := y - 2;
985 xp := 0;
986 while xp < 5 do
987 begin
988 yp := 0;
989 while yp < 5 do
990 begin
991 if IsTrue(alignment[xp + (5 * yp)] = 1) then
992 begin
993 grid[((yp + y) * size) + (xp + x)] := $11;
994 end else begin
995 grid[((yp + y) * size) + (xp + x)] := $10;
996 end;
997 Inc (yp);
998 end;
999 Inc (xp);
1000 end;
1001end;
1002
1003procedure setup_grid(grid: PBYTE; size: Integer; version: Integer);
1004var
1005 toggle: Integer = 1;
1006 i: Integer = 1;
1007 ycoord: Integer;
1008 xcoord: Integer;
1009 y: Integer;
1010 x: Integer;
1011 loopsize: Integer;
1012begin
1013 {INITCODE} toggle := 1;
1014 {INITCODE} i := 1;
1015 i := 0;
1016 while i < size do
1017 begin
1018 if IsTrue(toggle = 1) then
1019 begin
1020 grid[(6 * size) + i] := $21;
1021 grid[(i * size) + 6] := $21;
1022 toggle := 0;
1023 end else begin
1024 grid[(6 * size) + i] := $20;
1025 grid[(i * size) + 6] := $20;
1026 toggle := 1;
1027 end;
1028 Inc (i);
1029 end;
1030 place_finder (grid, size, 0, 0);
1031 place_finder (grid, size, 0, size - 7);
1032 place_finder (grid, size, size - 7, 0);
1033 i := 0;
1034 while i < 7 do
1035 begin
1036 grid[(7 * size) + i] := $10;
1037 grid[(i * size) + 7] := $10;
1038 grid[(7 * size) + (size - 1 - i)] := $10;
1039 grid[(i * size) + (size - 8)] := $10;
1040 grid[((size - 8) * size) + i] := $10;
1041 grid[((size - 1 - i) * size) + 7] := $10;
1042 Inc (i);
1043 end;
1044 grid[(7 * size) + 7] := $10;
1045 grid[(7 * size) + (size - 8)] := $10;
1046 grid[((size - 8) * size) + 7] := $10;
1047 if IsTrue(version <> 1) then
1048 begin
1049 loopsize := qr_align_loopsize[version - 1];
1050 x := 0;
1051 while x < loopsize do
1052 begin
1053 y := 0;
1054 while y < loopsize do
1055 begin
1056 xcoord := qr_table_e1[((version - 2) * 7) + x];
1057 ycoord := qr_table_e1[((version - 2) * 7) + y];
1058 if not IsTrue((grid[(ycoord * size) + xcoord] and $10)) then
1059 begin
1060 place_align (grid, size, xcoord, ycoord);
1061 end;
1062 Inc (y);
1063 end;
1064 Inc (x);
1065 end;
1066 end;
1067 i := 0;
1068 while i < 8 do
1069 begin
1070 grid[(8 * size) + i] := grid[(8 * size) + i] + $20;
1071 grid[(i * size) + 8] := grid[(i * size) + 8] + $20;
1072 grid[(8 * size) + (size - 1 - i)] := $20;
1073 grid[((size - 1 - i) * size) + 8] := $20;
1074 Inc (i);
1075 end;
1076 grid[(8 * size) + 8] := grid[(8 * size) + 8] + 20;
1077 grid[((size - 1 - 7) * size) + 8] := $21;
1078 if IsTrue(version >= 7) then
1079 begin
1080 i := 0;
1081 while i < 6 do
1082 begin
1083 grid[((size - 9) * size) + i] := $20;
1084 grid[((size - 10) * size) + i] := $20;
1085 grid[((size - 11) * size) + i] := $20;
1086 grid[(i * size) + (size - 9)] := $20;
1087 grid[(i * size) + (size - 10)] := $20;
1088 grid[(i * size) + (size - 11)] := $20;
1089 Inc (i);
1090 end;
1091 end;
1092end;
1093
1094function cwbit(datastream: PInteger; i: Integer): Integer;
1095var
1096 word: Integer;
1097 bit: Integer;
1098 resultant: Integer = 0;
1099begin
1100 {INITCODE} word := i div 8;
1101 {INITCODE} bit := i mod 8;
1102 {INITCODE} resultant := 0;
1103 case bit of
1104 0:
1105 begin
1106 if IsTrue(datastream[word] and $80) then
1107 begin
1108 resultant := 1;
1109 end else begin
1110 resultant := 0;
1111 end;
1112 end;
1113 1:
1114 begin
1115 if IsTrue(datastream[word] and $40) then
1116 begin
1117 resultant := 1;
1118 end else begin
1119 resultant := 0;
1120 end;
1121 end;
1122 2:
1123 begin
1124 if IsTrue(datastream[word] and $20) then
1125 begin
1126 resultant := 1;
1127 end else begin
1128 resultant := 0;
1129 end;
1130 end;
1131 3:
1132 begin
1133 if IsTrue(datastream[word] and $10) then
1134 begin
1135 resultant := 1;
1136 end else begin
1137 resultant := 0;
1138 end;
1139 end;
1140 4:
1141 begin
1142 if IsTrue(datastream[word] and $08) then
1143 begin
1144 resultant := 1;
1145 end else begin
1146 resultant := 0;
1147 end;
1148 end;
1149 5:
1150 begin
1151 if IsTrue(datastream[word] and $04) then
1152 begin
1153 resultant := 1;
1154 end else begin
1155 resultant := 0;
1156 end;
1157 end;
1158 6:
1159 begin
1160 if IsTrue(datastream[word] and $02) then
1161 begin
1162 resultant := 1;
1163 end else begin
1164 resultant := 0;
1165 end;
1166 end;
1167 7:
1168 begin
1169 if IsTrue(datastream[word] and $01) then
1170 begin
1171 resultant := 1;
1172 end else begin
1173 resultant := 0;
1174 end;
1175 end;
1176 end;
1177 exit (resultant);
1178end;
1179
1180procedure populate_grid(grid: PBYTE; size: Integer; datastream: PInteger; cw: Integer);
1181var
1182 direction: Integer = 1;
1183 row: Integer = 0;
1184 y: Integer;
1185 x: Integer;
1186 n: Integer;
1187 i: Integer;
1188begin
1189 {INITCODE} direction := 1;
1190 {INITCODE} row := 0;
1191 n := cw * 8;
1192 y := size - 1;
1193 i := 0;
1194 repeat
1195 x := (size - 2) - (row * 2);
1196 if IsTrue(x < 6) then
1197 begin
1198 Dec (x);
1199 end;
1200 if not IsTrue((grid[(y * size) + (x + 1)] and $F0)) then
1201 begin
1202 if IsTrue(cwbit (datastream, i)) then
1203 begin
1204 grid[(y * size) + (x + 1)] := $01;
1205 end else begin
1206 grid[(y * size) + (x + 1)] := $00;
1207 end;
1208 Inc (i);
1209 end;
1210 if IsTrue(i < n) then
1211 begin
1212 if not IsTrue((grid[(y * size) + x] and $F0)) then
1213 begin
1214 if IsTrue(cwbit (datastream, i)) then
1215 begin
1216 grid[(y * size) + x] := $01;
1217 end else begin
1218 grid[(y * size) + x] := $00;
1219 end;
1220 Inc (i);
1221 end;
1222 end;
1223 if IsTrue(direction) then
1224 begin
1225 Dec (y);
1226 end else begin
1227 Inc (y);
1228 end;
1229 if IsTrue(y = -1) then
1230 begin
1231 Inc (row);
1232 y := 0;
1233 direction := 0;
1234 end;
1235 if IsTrue(y = size) then
1236 begin
1237 Inc (row);
1238 y := size - 1;
1239 direction := 1;
1240 end;
1241 until not (i < n);
1242end;
1243
1244function evaluate(grid: PBYTE; size: Integer; pattern: Integer): Integer;
1245var
1246 block: Integer;
1247 y: Integer;
1248 x: Integer;
1249 resultcode: Integer = 0;
1250 state: Char;
1251 p: Integer;
1252 dark_mods: Integer;
1253 k: Integer;
1254 percentage: Integer;
1255 local: array of Char = nil;
1256begin
1257 {INITCODE} resultcode := 0;
1258 SetLength(local,size * size);
1259 x := 0;
1260 while x < size do
1261 begin
1262 y := 0;
1263 while y < size do
1264 begin
1265 case pattern of
1266 0:
1267 begin
1268 if IsTrue(grid[(y * size) + x] and $01) then
1269 begin
1270 local[(y * size) + x] := '1';
1271 end else begin
1272 local[(y * size) + x] := '0';
1273 end;
1274 end;
1275 1:
1276 begin
1277 if IsTrue(grid[(y * size) + x] and $02) then
1278 begin
1279 local[(y * size) + x] := '1';
1280 end else begin
1281 local[(y * size) + x] := '0';
1282 end;
1283 end;
1284 2:
1285 begin
1286 if IsTrue(grid[(y * size) + x] and $04) then
1287 begin
1288 local[(y * size) + x] := '1';
1289 end else begin
1290 local[(y * size) + x] := '0';
1291 end;
1292 end;
1293 3:
1294 begin
1295 if IsTrue(grid[(y * size) + x] and $08) then
1296 begin
1297 local[(y * size) + x] := '1';
1298 end else begin
1299 local[(y * size) + x] := '0';
1300 end;
1301 end;
1302 4:
1303 begin
1304 if IsTrue(grid[(y * size) + x] and $10) then
1305 begin
1306 local[(y * size) + x] := '1';
1307 end else begin
1308 local[(y * size) + x] := '0';
1309 end;
1310 end;
1311 5:
1312 begin
1313 if IsTrue(grid[(y * size) + x] and $20) then
1314 begin
1315 local[(y * size) + x] := '1';
1316 end else begin
1317 local[(y * size) + x] := '0';
1318 end;
1319 end;
1320 6:
1321 begin
1322 if IsTrue(grid[(y * size) + x] and $40) then
1323 begin
1324 local[(y * size) + x] := '1';
1325 end else begin
1326 local[(y * size) + x] := '0';
1327 end;
1328 end;
1329 7:
1330 begin
1331 if IsTrue(grid[(y * size) + x] and $80) then
1332 begin
1333 local[(y * size) + x] := '1';
1334 end else begin
1335 local[(y * size) + x] := '0';
1336 end;
1337 end;
1338 end;
1339 Inc (y);
1340 end;
1341 Inc (x);
1342 end;
1343 x := 0;
1344 while x < size do
1345 begin
1346 state := local[x];
1347 block := 0;
1348 y := 0;
1349 while y < size do
1350 begin
1351 if IsTrue(local[(y * size) + x] = state) then
1352 begin
1353 Inc (block);
1354 end else begin
1355 if IsTrue(block > 5) then
1356 begin
1357 resultcode := resultcode + ((3 + block));
1358 end;
1359 block := 0;
1360 state := local[(y * size) + x];
1361 end;
1362 Inc (y);
1363 end;
1364 if IsTrue(block > 5) then
1365 begin
1366 resultcode := resultcode + ((3 + block));
1367 end;
1368 Inc (x);
1369 end;
1370 y := 0;
1371 while y < size do
1372 begin
1373 state := local[y * size];
1374 block := 0;
1375 x := 0;
1376 while x < size do
1377 begin
1378 if IsTrue(local[(y * size) + x] = state) then
1379 begin
1380 Inc (block);
1381 end else begin
1382 if IsTrue(block > 5) then
1383 begin
1384 resultcode := resultcode + ((3 + block));
1385 end;
1386 block := 0;
1387 state := local[(y * size) + x];
1388 end;
1389 Inc (x);
1390 end;
1391 if IsTrue(block > 5) then
1392 begin
1393 resultcode := resultcode + ((3 + block));
1394 end;
1395 Inc (y);
1396 end;
1397 x := 0;
1398 while x < size do
1399 begin
1400 y := 0;
1401 while y < (size - 7) do
1402 begin
1403 p := 0;
1404 if IsTrue(local[(y * size) + x] = '1') then
1405 begin
1406 p := p + $40;
1407 end;
1408 if IsTrue(local[((y + 1) * size) + x] = '1') then
1409 begin
1410 p := p + $20;
1411 end;
1412 if IsTrue(local[((y + 2) * size) + x] = '1') then
1413 begin
1414 p := p + $10;
1415 end;
1416 if IsTrue(local[((y + 3) * size) + x] = '1') then
1417 begin
1418 p := p + $08;
1419 end;
1420 if IsTrue(local[((y + 4) * size) + x] = '1') then
1421 begin
1422 p := p + $04;
1423 end;
1424 if IsTrue(local[((y + 5) * size) + x] = '1') then
1425 begin
1426 p := p + $02;
1427 end;
1428 if IsTrue(local[((y + 6) * size) + x] = '1') then
1429 begin
1430 p := p + $01;
1431 end;
1432 if IsTrue(p = $5D) then
1433 begin
1434 resultcode := resultcode + 40;
1435 end;
1436 Inc (y);
1437 end;
1438 Inc (x);
1439 end;
1440 y := 0;
1441 while y < size do
1442 begin
1443 x := 0;
1444 while x < (size - 7) do
1445 begin
1446 p := 0;
1447 if IsTrue(local[(y * size) + x] = '1') then
1448 begin
1449 p := p + $40;
1450 end;
1451 if IsTrue(local[(y * size) + x + 1] = '1') then
1452 begin
1453 p := p + $20;
1454 end;
1455 if IsTrue(local[(y * size) + x + 2] = '1') then
1456 begin
1457 p := p + $10;
1458 end;
1459 if IsTrue(local[(y * size) + x + 3] = '1') then
1460 begin
1461 p := p + $08;
1462 end;
1463 if IsTrue(local[(y * size) + x + 4] = '1') then
1464 begin
1465 p := p + $04;
1466 end;
1467 if IsTrue(local[(y * size) + x + 5] = '1') then
1468 begin
1469 p := p + $02;
1470 end;
1471 if IsTrue(local[(y * size) + x + 6] = '1') then
1472 begin
1473 p := p + $01;
1474 end;
1475 if IsTrue(p = $5D) then
1476 begin
1477 resultcode := resultcode + 40;
1478 end;
1479 Inc (x);
1480 end;
1481 Inc (y);
1482 end;
1483 dark_mods := 0;
1484 x := 0;
1485 while x < size do
1486 begin
1487 y := 0;
1488 while y < size do
1489 begin
1490 if IsTrue(local[(y * size) + x] = '1') then
1491 begin
1492 Inc (dark_mods);
1493 end;
1494 Inc (y);
1495 end;
1496 Inc (x);
1497 end;
1498 percentage := 100 * (dark_mods div (size * size));
1499 if IsTrue(percentage <= 50) then
1500 begin
1501 k := ((100 - percentage) - 50) div 5;
1502 end else begin
1503 k := (percentage - 50) div 5;
1504 end;
1505 resultcode := resultcode + (10 * k);
1506 exit (resultcode);
1507end;
1508
1509function apply_bitmask(grid: PBYTE; size: Integer): Integer;
1510var
1511 y: Integer;
1512 x: Integer;
1513 p: BYTE;
1514 penalty: array [0..8-1] of Integer;
1515 pattern: Integer;
1516 best_pattern: Integer;
1517 best_val: Integer;
1518 bit: Integer;
1519 mask: array of BYTE = nil;
1520 eval: array of BYTE = nil;
1521begin
1522 SetLength(mask,size * size);
1523 SetLength(eval,size * size);
1524 x := 0;
1525 while x < size do
1526 begin
1527 y := 0;
1528 while y < size do
1529 begin
1530 mask[(y * size) + x] := $00;
1531 if not IsTrue((grid[(y * size) + x] and $F0)) then
1532 begin
1533 if IsTrue(((y + x) and 1) = 0) then
1534 begin
1535 mask[(y * size) + x] := mask[(y * size) + x] + $01;
1536 end;
1537 if IsTrue((y and 1) = 0) then
1538 begin
1539 mask[(y * size) + x] := mask[(y * size) + x] + $02;
1540 end;
1541 if IsTrue((x mod 3) = 0) then
1542 begin
1543 mask[(y * size) + x] := mask[(y * size) + x] + $04;
1544 end;
1545 if IsTrue(((y + x) mod 3) = 0) then
1546 begin
1547 mask[(y * size) + x] := mask[(y * size) + x] + $08;
1548 end;
1549 if IsTrue((((y div 2) + (x div 3)) and 1) = 0) then
1550 begin
1551 mask[(y * size) + x] := mask[(y * size) + x] + $10;
1552 end;
1553 if IsTrue((((y * x) and 1) + ((y * x) mod 3)) = 0) then
1554 begin
1555 mask[(y * size) + x] := mask[(y * size) + x] + $20;
1556 end;
1557 if IsTrue(((((y * x) and 1) + ((y * x) mod 3)) and 1) = 0) then
1558 begin
1559 mask[(y * size) + x] := mask[(y * size) + x] + $40;
1560 end;
1561 if IsTrue(((((y + x) and 1) + ((y * x) mod 3)) and 1) = 0) then
1562 begin
1563 mask[(y * size) + x] := mask[(y * size) + x] + $80;
1564 end;
1565 end;
1566 Inc (y);
1567 end;
1568 Inc (x);
1569 end;
1570 x := 0;
1571 while x < size do
1572 begin
1573 y := 0;
1574 while y < size do
1575 begin
1576 if IsTrue(grid[(y * size) + x] and $01) then
1577 begin
1578 p := $FF;
1579 end else begin
1580 p := $00;
1581 end;
1582 eval[(y * size) + x] := mask[(y * size) + x] xor p;
1583 Inc (y);
1584 end;
1585 Inc (x);
1586 end;
1587 pattern := 0;
1588 while pattern < 8 do
1589 begin
1590 penalty[pattern] := evaluate (@eval[0], size, pattern);
1591 Inc (pattern);
1592 end;
1593 best_pattern := 0;
1594 best_val := penalty[0];
1595 pattern := 1;
1596 while pattern < 8 do
1597 begin
1598 if IsTrue(penalty[pattern] < best_val) then
1599 begin
1600 best_pattern := pattern;
1601 best_val := penalty[pattern];
1602 end;
1603 Inc (pattern);
1604 end;
1605 x := 0;
1606 while x < size do
1607 begin
1608 y := 0;
1609 while y < size do
1610 begin
1611 bit := 0;
1612 case best_pattern of
1613 0:
1614 begin
1615 if IsTrue(mask[(y * size) + x] and $01) then
1616 begin
1617 bit := 1;
1618 end;
1619 end;
1620 1:
1621 begin
1622 if IsTrue(mask[(y * size) + x] and $02) then
1623 begin
1624 bit := 1;
1625 end;
1626 end;
1627 2:
1628 begin
1629 if IsTrue(mask[(y * size) + x] and $04) then
1630 begin
1631 bit := 1;
1632 end;
1633 end;
1634 3:
1635 begin
1636 if IsTrue(mask[(y * size) + x] and $08) then
1637 begin
1638 bit := 1;
1639 end;
1640 end;
1641 4:
1642 begin
1643 if IsTrue(mask[(y * size) + x] and $10) then
1644 begin
1645 bit := 1;
1646 end;
1647 end;
1648 5:
1649 begin
1650 if IsTrue(mask[(y * size) + x] and $20) then
1651 begin
1652 bit := 1;
1653 end;
1654 end;
1655 6:
1656 begin
1657 if IsTrue(mask[(y * size) + x] and $40) then
1658 begin
1659 bit := 1;
1660 end;
1661 end;
1662 7:
1663 begin
1664 if IsTrue(mask[(y * size) + x] and $80) then
1665 begin
1666 bit := 1;
1667 end;
1668 end;
1669 end;
1670 if IsTrue(bit = 1) then
1671 begin
1672 if IsTrue(grid[(y * size) + x] and $01) then
1673 begin
1674 grid[(y * size) + x] := $00;
1675 end else begin
1676 grid[(y * size) + x] := $01;
1677 end;
1678 end;
1679 Inc (y);
1680 end;
1681 Inc (x);
1682 end;
1683 exit (best_pattern);
1684end;
1685
1686procedure add_format_info(grid: PBYTE; size: Integer; ecc_level: Integer; pattern: Integer);
1687var
1688 format: Integer;
1689 seq: Cardinal;
1690 i: Integer;
1691begin
1692 {INITCODE} format := pattern;
1693 case ecc_level of
1694 LEVEL_L: format := format + $08;
1695 LEVEL_Q: format := format + $18;
1696 LEVEL_H: format := format + $10;
1697 end;
1698 seq := qr_annex_c[format];
1699 i := 0;
1700 while i < 6 do
1701 begin
1702 grid[(i * size) + 8] := grid[(i * size) + 8] + ((seq shr i) and $01);
1703 Inc (i);
1704 end;
1705 i := 0;
1706 while i < 8 do
1707 begin
1708 grid[(8 * size) + (size - i - 1)] := grid[(8 * size) + (size - i - 1)] + ((seq shr i) and $01);
1709 Inc (i);
1710 end;
1711 i := 0;
1712 while i < 6 do
1713 begin
1714 grid[(8 * size) + (5 - i)] := grid[(8 * size) + (5 - i)] + ((seq shr (i + 9)) and $01);
1715 Inc (i);
1716 end;
1717 i := 0;
1718 while i < 7 do
1719 begin
1720 grid[(((size - 7) + i) * size) + 8] := grid[(((size - 7) + i) * size) + 8] + ((seq shr (i + 8)) and $01);
1721 Inc (i);
1722 end;
1723 grid[(7 * size) + 8] := grid[(7 * size) + 8] + ((seq shr 6) and $01);
1724 grid[(8 * size) + 8] := grid[(8 * size) + 8] + ((seq shr 7) and $01);
1725 grid[(8 * size) + 7] := grid[(8 * size) + 7] + ((seq shr 8) and $01);
1726end;
1727
1728procedure add_version_info(grid: PBYTE; size: Integer; version: Integer);
1729var
1730 i: Integer;
1731 version_data: cardinal;
1732begin
1733 {INITCODE} version_data := qr_annex_d[version - 7];
1734 i := 0;
1735 while i < 6 do
1736 begin
1737 grid[((size - 11) * size) + i] := grid[((size - 11) * size) + i] + ((version_data shr (i * 3)) and $01);
1738 grid[((size - 10) * size) + i] := grid[((size - 10) * size) + i] + ((version_data shr ((i * 3) + 1)) and $01);
1739 grid[((size - 9) * size) + i] := grid[((size - 9) * size) + i] + ((version_data shr ((i * 3) + 2)) and $01);
1740 grid[(i * size) + (size - 11)] := grid[(i * size) + (size - 11)] + ((version_data shr (i * 3)) and $01);
1741 grid[(i * size) + (size - 10)] := grid[(i * size) + (size - 10)] + ((version_data shr ((i * 3) + 1)) and $01);
1742 grid[(i * size) + (size - 9)] := grid[(i * size) + (size - 9)] + ((version_data shr ((i * 3) + 2)) and $01);
1743 Inc (i);
1744 end;
1745end;
1746
1747function qr_code(symbol: PointerTo_zint_symbol; source: PBYTE; length: Integer): Integer;
1748var
1749 est_binlen: Integer;
1750 glyph: Integer;
1751 j: Integer;
1752 i: Integer;
1753 error_number: Integer;
1754 size: Integer;
1755 blocks: Integer;
1756 target_binlen: Integer;
1757 max_cw: Integer;
1758 version: Integer;
1759 autosize: Integer;
1760 ecc_level: Integer;
1761 gs1: Boolean;
1762 bitmask: Integer;
1763 utfdata: array of Integer = nil;
1764 jisdata: array of Integer = nil;
1765 mode: array of Char = nil;
1766 datastream: array of Integer = nil;
1767 fullstream: array of Integer = nil;
1768 grid: array of BYTE = nil;
1769begin
1770 SetLength(utfdata,length + 1);
1771 SetLength(jisdata,length + 1);
1772 SetLength(mode,length + 1);
1773
1774 gs1 := (symbol^.input_mode = GS1_MODE);
1775 case symbol^.input_mode of
1776 DATA_MODE:
1777 begin
1778 i := 0;
1779 while i < length do
1780 begin
1781 jisdata[i] := Integer (source[i]);
1782 Inc (i);
1783 end;
1784 end;
1785 otherwise
1786 begin
1787 error_number := utf8toutf16 (symbol, source, @utfdata[0], @length);
1788 if IsTrue(error_number <> 0) then
1789 begin
1790 exit (error_number);
1791 end;
1792 i := 0;
1793 while i < length do
1794 begin
1795 if IsTrue(utfdata[i] <= $FF) then
1796 begin
1797 jisdata[i] := utfdata[i];
1798 end else begin
1799 j := 0;
1800 glyph := 0;
1801 repeat
1802 if IsTrue(sjis_lookup[j * 2] = utfdata[i]) then
1803 begin
1804 glyph := sjis_lookup[(j * 2) + 1];
1805 end;
1806 Inc (j);
1807 until NotBoolean (((j < 6843)) and ((glyph = 0)));
1808 if IsTrue(glyph = 0) then
1809 begin
1810 strcpy (symbol^.errtxt, 'Invalid character in input data');
1811 exit (ERROR_INVALID_DATA);
1812 end;
1813 jisdata[i] := glyph;
1814 end;
1815 Inc (i);
1816 end;
1817 end;
1818 end;
1819 define_mode (@mode[0], @jisdata[0], length, gs1);
1820 est_binlen := estimate_binary_length (@mode[0], length, gs1);
1821 ecc_level := LEVEL_L;
1822 max_cw := 2956;
1823 if IsTrue(((symbol^.option_1 >= 1)) and ((symbol^.option_1 <= 4))) then
1824 begin
1825 case symbol^.option_1 of
1826 1:
1827 begin
1828 ecc_level := LEVEL_L;
1829 max_cw := 2956;
1830 end;
1831 2:
1832 begin
1833 ecc_level := LEVEL_M;
1834 max_cw := 2334;
1835 end;
1836 3:
1837 begin
1838 ecc_level := LEVEL_Q;
1839 max_cw := 1666;
1840 end;
1841 4:
1842 begin
1843 ecc_level := LEVEL_H;
1844 max_cw := 1276;
1845 end;
1846 end;
1847 end;
1848 if IsTrue(est_binlen > (8 * max_cw)) then
1849 begin
1850 strcpy (symbol^.errtxt, 'Input too long for selected error correction level');
1851 exit (ERROR_TOO_LONG);
1852 end;
1853 autosize := 40;
1854 i := 39;
1855 while i >= 0 do
1856 begin
1857 case ecc_level of
1858 LEVEL_L:
1859 begin
1860 if IsTrue((8 * qr_data_codewords_L[i]) >= est_binlen) then
1861 begin
1862 autosize := i + 1;
1863 end;
1864 end;
1865 LEVEL_M:
1866 begin
1867 if IsTrue((8 * qr_data_codewords_M[i]) >= est_binlen) then
1868 begin
1869 autosize := i + 1;
1870 end;
1871 end;
1872 LEVEL_Q:
1873 begin
1874 if IsTrue((8 * qr_data_codewords_Q[i]) >= est_binlen) then
1875 begin
1876 autosize := i + 1;
1877 end;
1878 end;
1879 LEVEL_H:
1880 begin
1881 if IsTrue((8 * qr_data_codewords_H[i]) >= est_binlen) then
1882 begin
1883 autosize := i + 1;
1884 end;
1885 end;
1886 end;
1887 Dec (i);
1888 end;
1889 if IsTrue(((symbol^.option_2 >= 1)) and ((symbol^.option_2 <= 40))) then
1890 begin
1891 if IsTrue(symbol^.option_2 > autosize) then
1892 begin
1893 version := symbol^.option_2;
1894 end else begin
1895 version := autosize;
1896 end;
1897 end else begin
1898 version := autosize;
1899 end;
1900 if IsTrue(est_binlen <= qr_data_codewords_M[version - 1]) then
1901 begin
1902 ecc_level := LEVEL_M;
1903 end;
1904 if IsTrue(est_binlen <= qr_data_codewords_Q[version - 1]) then
1905 begin
1906 ecc_level := LEVEL_Q;
1907 end;
1908 if IsTrue(est_binlen <= qr_data_codewords_H[version - 1]) then
1909 begin
1910 ecc_level := LEVEL_H;
1911 end;
1912 target_binlen := qr_data_codewords_L[version - 1];
1913 SetLength(datastream,target_binlen + 1);
1914 blocks := qr_blocks_L[version - 1];
1915 case ecc_level of
1916 LEVEL_M:
1917 begin
1918 target_binlen := qr_data_codewords_M[version - 1];
1919 blocks := qr_blocks_M[version - 1];
1920 end;
1921 LEVEL_Q:
1922 begin
1923 target_binlen := qr_data_codewords_Q[version - 1];
1924 blocks := qr_blocks_Q[version - 1];
1925 end;
1926 LEVEL_H:
1927 begin
1928 target_binlen := qr_data_codewords_H[version - 1];
1929 blocks := qr_blocks_H[version - 1];
1930 end;
1931 end;
1932 SetLength(fullstream,qr_total_codewords[version - 1] + 1);
1933 qr_binary (@datastream[0], version, target_binlen, @mode[0], @jisdata[0], length, gs1, est_binlen);
1934 add_ecc (@fullstream[0], @datastream[0], version, target_binlen, blocks);
1935 size := qr_sizes[version - 1];
1936 SetLength(grid,size * size);
1937 i := 0;
1938 while i < size do
1939 begin
1940 j := 0;
1941 while j < size do
1942 begin
1943 grid[(i * size) + j] := 0;
1944 Inc (j);
1945 end;
1946 Inc (i);
1947 end;
1948 setup_grid (@grid[0], size, version);
1949 populate_grid (@grid[0], size, @fullstream[0], qr_total_codewords[version - 1]);
1950 bitmask := apply_bitmask (@grid[0], size);
1951 add_format_info (@grid[0], size, ecc_level, bitmask);
1952 if IsTrue(version >= 7) then
1953 begin
1954 add_version_info (@grid[0], size, version);
1955 end;
1956 symbol^.width := size;
1957 symbol^.rows := size;
1958 i := 0;
1959 while i < size do
1960 begin
1961 j := 0;
1962 while j < size do
1963 begin
1964 if IsTrue(grid[(i * size) + j] and $01) then
1965 begin
1966 set_module (symbol, i, j);
1967 end;
1968 Inc (j);
1969 end;
1970 symbol^.row_height[i] := 1;
1971 Inc (i);
1972 end;
1973 exit (0);
1974end;
1975
1976
1977function micro_qr_intermediate(binary: PChar; jisdata: PInteger; mode: PChar; length: Integer; kanji_used: PInteger; alphanum_used: PInteger; byte_used: PInteger): Integer;
1978var
1979 debug: Integer = 0;
1980 position: Integer = 0;
1981 i: Integer;
1982 short_data_block_length: Integer;
1983 data_block: Char;
1984 buffer: array [0..2-1] of Char;
1985 jis: Integer;
1986 prod: Integer;
1987 lsb: Integer;
1988 msb: Integer;
1989 byte: Integer;
1990 count: Integer;
1991// prod: Integer;
1992 second: Integer = 0;
1993 first: Integer = 0;
1994// count: Integer;
1995// prod: Integer;
1996 third: Integer = 0;
1997// second: Integer = 0;
1998// first: Integer = 0;
1999begin
2000 {INITCODE} debug := 0;
2001 {INITCODE} position := 0;
2002 strcpy (binary, '');
2003 if IsTrue(debug) then
2004 begin
2005 i := 0;
2006 while i < length do
2007 begin
2008 write( format ('%c',[mode[i]]) );
2009 Inc (i);
2010 end;
2011 write( LineEnding );
2012 end;
2013 repeat
2014 if IsTrue(sysutils.strlen (binary) > 128) then
2015 begin
2016 exit (ERROR_TOO_LONG);
2017 end;
2018 data_block := mode[position];
2019 short_data_block_length := 0;
2020 repeat
2021 Inc (short_data_block_length);
2022 until NotBoolean ((((short_data_block_length + position) < length)) and ((mode[position + short_data_block_length] = data_block)));
2023 case data_block of
2024 'K':
2025 begin
2026 concat (binary, 'K');
2027 kanji_used^ := 1;
2028 buffer[0] := char(short_data_block_length);
2029 buffer[1] := #0;
2030 concat (binary, buffer);
2031 if IsTrue(debug) then
2032 begin
2033 write( format ('Kanji block (length %d)'+LineEnding+chr(9),[short_data_block_length]) );
2034 end;
2035 i := 0;
2036 while i < short_data_block_length do
2037 begin
2038 {INITCODE} jis := jisdata[position + i];
2039 if IsTrue(jis > $9FFF) then
2040 begin
2041 jis := jis - $C140;
2042 end;
2043 msb := (jis and $FF00) shr 4;
2044 lsb := (jis and $FF);
2045 prod := (msb * $C0) + lsb;
2046 qr_bscan (binary, prod, $1000);
2047 if IsTrue(debug) then
2048 begin
2049 write( format ('0x%.4X ',[prod]) );
2050 end;
2051 if IsTrue(sysutils.strlen (binary) > 128) then
2052 begin
2053 exit (ERROR_TOO_LONG);
2054 end;
2055 Inc (i);
2056 end;
2057 if IsTrue(debug) then
2058 begin
2059 write( LineEnding );
2060 end;
2061 end;
2062 'B':
2063 begin
2064 concat (binary, 'B');
2065 byte_used^ := 1;
2066 buffer[0] := char(short_data_block_length);
2067 buffer[1] := #0;
2068 concat (binary, buffer);
2069 if IsTrue(debug) then
2070 begin
2071 write( format ('Byte block (length %d)'+LineEnding+chr(9),[short_data_block_length]) );
2072 end;
2073 i := 0;
2074 while i < short_data_block_length do
2075 begin
2076 {INITCODE} byte := jisdata[position + i];
2077 qr_bscan (binary, byte, $80);
2078 if IsTrue(debug) then
2079 begin
2080 write( format ('0x%.4X ',[byte]) );
2081 end;
2082 if IsTrue(sysutils.strlen (binary) > 128) then
2083 begin
2084 exit (ERROR_TOO_LONG);
2085 end;
2086 Inc (i);
2087 end;
2088 if IsTrue(debug) then
2089 begin
2090 write( LineEnding );
2091 end;
2092 end;
2093 'A':
2094 begin
2095 concat (binary, 'A');
2096 alphanum_used^ := 1;
2097 buffer[0] := char(short_data_block_length);
2098 buffer[1] := #0;
2099 concat (binary, buffer);
2100 if IsTrue(debug) then
2101 begin
2102 write( format ('Alpha block (length %d)'+LineEnding+chr(9),[short_data_block_length]) );
2103 end;
2104 i := 0;
2105 while i < short_data_block_length do
2106 begin
2107 {INITCODE} second := 0;
2108 {INITCODE} first := 0;
2109 first := posn (RHODIUM, Char (jisdata[position + i]));
2110 count := 1;
2111 prod := first;
2112 if IsTrue(mode[position + i + 1] = 'A') then
2113 begin
2114 second := posn (RHODIUM, Char (jisdata[position + i + 1]));
2115 count := 2;
2116 prod := (first * 45) + second;
2117 end;
2118 qr_bscan (binary, prod, 1 shl (5 * count));
2119 if IsTrue(debug) then
2120 begin
2121 write( format ('0x%.4X ',[prod]) );
2122 end;
2123 if IsTrue(sysutils.strlen (binary) > 128) then
2124 begin
2125 exit (ERROR_TOO_LONG);
2126 end;
2127 i := i + 2;
2128 end;
2129 if IsTrue(debug) then
2130 begin
2131 write( LineEnding );
2132 end;
2133 end;
2134 'N':
2135 begin
2136 concat (binary, 'N');
2137 buffer[0] := char(short_data_block_length);
2138 buffer[1] := #0;
2139 concat (binary, buffer);
2140 if IsTrue(debug) then
2141 begin
2142 write( format ('Number block (length %d)'+LineEnding+chr(9),[short_data_block_length]) );
2143 end;
2144 i := 0;
2145 while i < short_data_block_length do
2146 begin
2147 {INITCODE} third := 0;
2148 {INITCODE} second := 0;
2149 {INITCODE} first := 0;
2150 first := posn (NEON, Char (jisdata[position + i]));
2151 count := 1;
2152 prod := first;
2153 if IsTrue(mode[position + i + 1] = 'N') then
2154 begin
2155 second := posn (NEON, Char (jisdata[position + i + 1]));
2156 count := 2;
2157 prod := (prod * 10) + second;
2158 end;
2159 if IsTrue(mode[position + i + 2] = 'N') then
2160 begin
2161 third := posn (NEON, Char (jisdata[position + i + 2]));
2162 count := 3;
2163 prod := (prod * 10) + third;
2164 end;
2165 qr_bscan (binary, prod, 1 shl (3 * count));
2166 if IsTrue(debug) then
2167 begin
2168 write( format ('0x%.4X (%d)',[prod, prod]) );
2169 end;
2170 if IsTrue(sysutils.strlen (binary) > 128) then
2171 begin
2172 exit (ERROR_TOO_LONG);
2173 end;
2174 i := i + 3;
2175 end;
2176 if IsTrue(debug) then
2177 begin
2178 write( LineEnding );
2179 end;
2180 end;
2181 end;
2182 position := position + short_data_block_length;
2183 until not (position < length - 1);
2184 exit (0);
2185end;
2186
2187procedure get_bitlength(count: PInteger; stream: PChar);
2188var
2189 i: Integer;
2190 length: Integer;
2191begin
2192 length := sysutils.strlen (stream);
2193 i := 0;
2194 while i < 4 do
2195 begin
2196 count[i] := 0;
2197 Inc (i);
2198 end;
2199 i := 0;
2200 repeat
2201 if IsTrue(((stream[i] = '0')) or ((stream[i] = '1'))) then
2202 begin
2203 Inc (count[0]);
2204 Inc (count[1]);
2205 Inc (count[2]);
2206 Inc (count[3]);
2207 Inc (i);
2208 end else begin
2209 case stream[i] of
2210 'K':
2211 begin
2212 count[2] := count[2] + 5;
2213 count[3] := count[3] + 7;
2214 i := i + 2;
2215 end;
2216 'B':
2217 begin
2218 count[2] := count[2] + 6;
2219 count[3] := count[3] + 8;
2220 i := i + 2;
2221 end;
2222 'A':
2223 begin
2224 count[1] := count[1] + 4;
2225 count[2] := count[2] + 6;
2226 count[3] := count[3] + 8;
2227 i := i + 2;
2228 end;
2229 'N':
2230 begin
2231 count[0] := count[0] + 3;
2232 count[1] := count[1] + 5;
2233 count[2] := count[2] + 7;
2234 count[3] := count[3] + 9;
2235 i := i + 2;
2236 end;
2237 end;
2238 end;
2239 until not (i < length);
2240end;
2241
2242procedure microqr_expand_binary(binary_stream: PChar; full_stream: PChar; version: Integer);
2243var
2244 length: Integer;
2245 i: Integer;
2246begin
2247 length := sysutils.strlen (binary_stream);
2248 i := 0;
2249 repeat
2250 case binary_stream[i] of
2251 '1':
2252 begin
2253 concat (full_stream, '1');
2254 Inc (i);
2255 end;
2256 '0':
2257 begin
2258 concat (full_stream, '0');
2259 Inc (i);
2260 end;
2261 'N':
2262 begin
2263 case version of
2264 1: concat (full_stream, '0');
2265 2: concat (full_stream, '00');
2266 3: concat (full_stream, '000');
2267 end;
2268 qr_bscan (full_stream, integer(binary_stream[i + 1]), 4 shl version);
2269 i := i + 2;
2270 end;
2271 'A':
2272 begin
2273 case version of
2274 1: concat (full_stream, '1');
2275 2: concat (full_stream, '01');
2276 3: concat (full_stream, '001');
2277 end;
2278 qr_bscan (full_stream, integer(binary_stream[i + 1]), 2 shl version);
2279 i := i + 2;
2280 end;
2281 'B':
2282 begin
2283 case version of
2284 2: concat (full_stream, '10');
2285 3: concat (full_stream, '010');
2286 end;
2287 qr_bscan (full_stream, integer(binary_stream[i + 1]), 2 shl version);
2288 i := i + 2;
2289 end;
2290 'K':
2291 begin
2292 case version of
2293 2: concat (full_stream, '11');
2294 3: concat (full_stream, '011');
2295 end;
2296 qr_bscan (full_stream, integer(binary_stream[i + 1]), 1 shl version);
2297 i := i + 2;
2298 end;
2299 end;
2300 until not (i < length);
2301end;
2302
2303procedure micro_qr_m1(binary_data: PChar);
2304var
2305 latch: Integer;
2306 i: Integer;
2307 remainder: Integer;
2308 bits_left: Integer;
2309 bits_total: Integer;
2310 ecc_codewords: Integer;
2311 data_codewords: Integer;
2312 ecc_blocks: array [0..3-1] of BYTE;
2313 data_blocks: array [0..4-1] of BYTE;
2314begin
2315 bits_total := 20;
2316 latch := 0;
2317 bits_left := bits_total - sysutils.strlen (binary_data);
2318 if IsTrue(bits_left <= 3) then
2319 begin
2320 i := 0;
2321 while i < bits_left do
2322 begin
2323 concat (binary_data, '0');
2324 Inc (i);
2325 end;
2326 latch := 1;
2327 end else begin
2328 concat (binary_data, '000');
2329 end;
2330 if IsTrue(latch = 0) then
2331 begin
2332 bits_left := bits_total - sysutils.strlen (binary_data);
2333 if IsTrue(bits_left <= 4) then
2334 begin
2335 i := 0;
2336 while i < bits_left do
2337 begin
2338 concat (binary_data, '0');
2339 Inc (i);
2340 end;
2341 latch := 1;
2342 end;
2343 end;
2344 if IsTrue(latch = 0) then
2345 begin
2346 remainder := 8 - (sysutils.strlen (binary_data) mod 8);
2347 if IsTrue(remainder = 8) then
2348 begin
2349 remainder := 0;
2350 end;
2351 i := 0;
2352 while i < remainder do
2353 begin
2354 concat (binary_data, '0');
2355 Inc (i);
2356 end;
2357 bits_left := bits_total - sysutils.strlen (binary_data);
2358 if IsTrue(bits_left > 4) then
2359 begin
2360 remainder := (bits_left - 4) div 8;
2361 i := 0;
2362 while i < remainder do
2363 begin
2364 if IsTrue(i and 1) then begin
2365 concat (binary_data, '00010001');
2366 end else begin
2367 concat (binary_data, '11101100');
2368 end;
2369 Inc (i);
2370 end;
2371 end;
2372 concat (binary_data, '0000');
2373 end;
2374 data_codewords := 3;
2375 ecc_codewords := 2;
2376 i := 0;
2377 while i < (data_codewords - 1) do
2378 begin
2379 data_blocks[i] := 0;
2380 if IsTrue(binary_data[i * 8] = '1') then
2381 begin
2382 data_blocks[i] := data_blocks[i] + $80;
2383 end;
2384 if IsTrue(binary_data[(i * 8) + 1] = '1') then
2385 begin
2386 data_blocks[i] := data_blocks[i] + $40;
2387 end;
2388 if IsTrue(binary_data[(i * 8) + 2] = '1') then
2389 begin
2390 data_blocks[i] := data_blocks[i] + $20;
2391 end;
2392 if IsTrue(binary_data[(i * 8) + 3] = '1') then
2393 begin
2394 data_blocks[i] := data_blocks[i] + $10;
2395 end;
2396 if IsTrue(binary_data[(i * 8) + 4] = '1') then
2397 begin
2398 data_blocks[i] := data_blocks[i] + $08;
2399 end;
2400 if IsTrue(binary_data[(i * 8) + 5] = '1') then
2401 begin
2402 data_blocks[i] := data_blocks[i] + $04;
2403 end;
2404 if IsTrue(binary_data[(i * 8) + 6] = '1') then
2405 begin
2406 data_blocks[i] := data_blocks[i] + $02;
2407 end;
2408 if IsTrue(binary_data[(i * 8) + 7] = '1') then
2409 begin
2410 data_blocks[i] := data_blocks[i] + $01;
2411 end;
2412 Inc (i);
2413 end;
2414 data_blocks[2] := 0;
2415 if IsTrue(binary_data[16] = '1') then
2416 begin
2417 data_blocks[2] := data_blocks[2] + $08;
2418 end;
2419 if IsTrue(binary_data[17] = '1') then
2420 begin
2421 data_blocks[2] := data_blocks[2] + $04;
2422 end;
2423 if IsTrue(binary_data[18] = '1') then
2424 begin
2425 data_blocks[2] := data_blocks[2] + $02;
2426 end;
2427 if IsTrue(binary_data[19] = '1') then
2428 begin
2429 data_blocks[2] := data_blocks[2] + $01;
2430 end;
2431 rs_init_gf ($11D);
2432 rs_init_code (ecc_codewords, 0);
2433 rs_encode (data_codewords, data_blocks, ecc_blocks);
2434 rs_free;
2435 i := 0;
2436 while i < ecc_codewords do
2437 begin
2438 qr_bscan (binary_data, ecc_blocks[ecc_codewords - i - 1], $80);
2439 Inc (i);
2440 end;
2441end;
2442
2443procedure micro_qr_m2(binary_data: PChar; ecc_mode: Integer);
2444var
2445 latch: Integer;
2446 i: Integer;
2447 remainder: Integer;
2448 bits_left: Integer;
2449 bits_total: Integer;
2450 ecc_codewords: Integer;
2451 data_codewords: Integer;
2452 ecc_blocks: array [0..7-1] of BYTE;
2453 data_blocks: array [0..6-1] of BYTE;
2454begin
2455 latch := 0;
2456 if IsTrue(ecc_mode = LEVEL_L) then
2457 begin
2458 bits_total := 40;
2459 end;
2460 if IsTrue(ecc_mode = LEVEL_M) then
2461 begin
2462 bits_total := 32;
2463 end;
2464 bits_left := bits_total - sysutils.strlen (binary_data);
2465 if IsTrue(bits_left <= 5) then
2466 begin
2467 i := 0;
2468 while i < bits_left do
2469 begin
2470 concat (binary_data, '0');
2471 Inc (i);
2472 end;
2473 latch := 1;
2474 end else begin
2475 concat (binary_data, '00000');
2476 end;
2477 if IsTrue(latch = 0) then
2478 begin
2479 remainder := 8 - (sysutils.strlen (binary_data) mod 8);
2480 if IsTrue(remainder = 8) then
2481 begin
2482 remainder := 0;
2483 end;
2484 i := 0;
2485 while i < remainder do
2486 begin
2487 concat (binary_data, '0');
2488 Inc (i);
2489 end;
2490 bits_left := bits_total - sysutils.strlen (binary_data);
2491 remainder := bits_left div 8;
2492 i := 0;
2493 while i < remainder do
2494 begin
2495 concat (binary_data, iif (i and 1,'00010001','11101100'));
2496 Inc (i);
2497 end;
2498 end;
2499 if IsTrue(ecc_mode = LEVEL_L) then
2500 begin
2501 data_codewords := 5;
2502 ecc_codewords := 5;
2503 end;
2504 if IsTrue(ecc_mode = LEVEL_M) then
2505 begin
2506 data_codewords := 4;
2507 ecc_codewords := 6;
2508 end;
2509 i := 0;
2510 while i < data_codewords do
2511 begin
2512 data_blocks[i] := 0;
2513 if IsTrue(binary_data[i * 8] = '1') then
2514 begin
2515 data_blocks[i] := data_blocks[i] + $80;
2516 end;
2517 if IsTrue(binary_data[(i * 8) + 1] = '1') then
2518 begin
2519 data_blocks[i] := data_blocks[i] + $40;
2520 end;
2521 if IsTrue(binary_data[(i * 8) + 2] = '1') then
2522 begin
2523 data_blocks[i] := data_blocks[i] + $20;
2524 end;
2525 if IsTrue(binary_data[(i * 8) + 3] = '1') then
2526 begin
2527 data_blocks[i] := data_blocks[i] + $10;
2528 end;
2529 if IsTrue(binary_data[(i * 8) + 4] = '1') then
2530 begin
2531 data_blocks[i] := data_blocks[i] + $08;
2532 end;
2533 if IsTrue(binary_data[(i * 8) + 5] = '1') then
2534 begin
2535 data_blocks[i] := data_blocks[i] + $04;
2536 end;
2537 if IsTrue(binary_data[(i * 8) + 6] = '1') then
2538 begin
2539 data_blocks[i] := data_blocks[i] + $02;
2540 end;
2541 if IsTrue(binary_data[(i * 8) + 7] = '1') then
2542 begin
2543 data_blocks[i] := data_blocks[i] + $01;
2544 end;
2545 Inc (i);
2546 end;
2547 rs_init_gf ($11D);
2548 rs_init_code (ecc_codewords, 0);
2549 rs_encode (data_codewords, data_blocks, ecc_blocks);
2550 rs_free;
2551 i := 0;
2552 while i < ecc_codewords do
2553 begin
2554 qr_bscan (binary_data, ecc_blocks[ecc_codewords - i - 1], $80);
2555 Inc (i);
2556 end;
2557 exit;
2558end;
2559
2560procedure micro_qr_m3(binary_data: PChar; ecc_mode: Integer);
2561var
2562 latch: Integer;
2563 i: Integer;
2564 remainder: Integer;
2565 bits_left: Integer;
2566 bits_total: Integer;
2567 ecc_codewords: Integer;
2568 data_codewords: Integer;
2569 ecc_blocks: array [0..9-1] of BYTE;
2570 data_blocks: array [0..12-1] of BYTE;
2571begin
2572 latch := 0;
2573 if IsTrue(ecc_mode = LEVEL_L) then
2574 begin
2575 bits_total := 84;
2576 end;
2577 if IsTrue(ecc_mode = LEVEL_M) then
2578 begin
2579 bits_total := 68;
2580 end;
2581 bits_left := bits_total - sysutils.strlen (binary_data);
2582 if IsTrue(bits_left <= 7) then
2583 begin
2584 i := 0;
2585 while i < bits_left do
2586 begin
2587 concat (binary_data, '0');
2588 Inc (i);
2589 end;
2590 latch := 1;
2591 end else begin
2592 concat (binary_data, '0000000');
2593 end;
2594 if IsTrue(latch = 0) then
2595 begin
2596 bits_left := bits_total - sysutils.strlen (binary_data);
2597 if IsTrue(bits_left <= 4) then
2598 begin
2599 i := 0;
2600 while i < bits_left do
2601 begin
2602 concat (binary_data, '0');
2603 Inc (i);
2604 end;
2605 latch := 1;
2606 end;
2607 end;
2608 if IsTrue(latch = 0) then
2609 begin
2610 remainder := 8 - (sysutils.strlen (binary_data) mod 8);
2611 if IsTrue(remainder = 8) then
2612 begin
2613 remainder := 0;
2614 end;
2615 i := 0;
2616 while i < remainder do
2617 begin
2618 concat (binary_data, '0');
2619 Inc (i);
2620 end;
2621 bits_left := bits_total - sysutils.strlen (binary_data);
2622 if IsTrue(bits_left > 4) then
2623 begin
2624 remainder := (bits_left - 4) div 8;
2625 i := 0;
2626 while i < remainder do
2627 begin
2628 concat (binary_data, iif (i and 1,'00010001','11101100'));
2629 Inc (i);
2630 end;
2631 end;
2632 concat (binary_data, '0000');
2633 end;
2634 if IsTrue(ecc_mode = LEVEL_L) then
2635 begin
2636 data_codewords := 11;
2637 ecc_codewords := 6;
2638 end;
2639 if IsTrue(ecc_mode = LEVEL_M) then
2640 begin
2641 data_codewords := 9;
2642 ecc_codewords := 8;
2643 end;
2644 i := 0;
2645 while i < (data_codewords - 1) do
2646 begin
2647 data_blocks[i] := 0;
2648 if IsTrue(binary_data[i * 8] = '1') then
2649 begin
2650 data_blocks[i] := data_blocks[i] + $80;
2651 end;
2652 if IsTrue(binary_data[(i * 8) + 1] = '1') then
2653 begin
2654 data_blocks[i] := data_blocks[i] + $40;
2655 end;
2656 if IsTrue(binary_data[(i * 8) + 2] = '1') then
2657 begin
2658 data_blocks[i] := data_blocks[i] + $20;
2659 end;
2660 if IsTrue(binary_data[(i * 8) + 3] = '1') then
2661 begin
2662 data_blocks[i] := data_blocks[i] + $10;
2663 end;
2664 if IsTrue(binary_data[(i * 8) + 4] = '1') then
2665 begin
2666 data_blocks[i] := data_blocks[i] + $08;
2667 end;
2668 if IsTrue(binary_data[(i * 8) + 5] = '1') then
2669 begin
2670 data_blocks[i] := data_blocks[i] + $04;
2671 end;
2672 if IsTrue(binary_data[(i * 8) + 6] = '1') then
2673 begin
2674 data_blocks[i] := data_blocks[i] + $02;
2675 end;
2676 if IsTrue(binary_data[(i * 8) + 7] = '1') then
2677 begin
2678 data_blocks[i] := data_blocks[i] + $01;
2679 end;
2680 Inc (i);
2681 end;
2682 if IsTrue(ecc_mode = LEVEL_L) then
2683 begin
2684 data_blocks[11] := 0;
2685 if IsTrue(binary_data[80] = '1') then
2686 begin
2687 data_blocks[2] := data_blocks[2] + $08;
2688 end;
2689 if IsTrue(binary_data[81] = '1') then
2690 begin
2691 data_blocks[2] := data_blocks[2] + $04;
2692 end;
2693 if IsTrue(binary_data[82] = '1') then
2694 begin
2695 data_blocks[2] := data_blocks[2] + $02;
2696 end;
2697 if IsTrue(binary_data[83] = '1') then
2698 begin
2699 data_blocks[2] := data_blocks[2] + $01;
2700 end;
2701 end;
2702 if IsTrue(ecc_mode = LEVEL_M) then
2703 begin
2704 data_blocks[9] := 0;
2705 if IsTrue(binary_data[64] = '1') then
2706 begin
2707 data_blocks[2] := data_blocks[2] + $08;
2708 end;
2709 if IsTrue(binary_data[65] = '1') then
2710 begin
2711 data_blocks[2] := data_blocks[2] + $04;
2712 end;
2713 if IsTrue(binary_data[66] = '1') then
2714 begin
2715 data_blocks[2] := data_blocks[2] + $02;
2716 end;
2717 if IsTrue(binary_data[67] = '1') then
2718 begin
2719 data_blocks[2] := data_blocks[2] + $01;
2720 end;
2721 end;
2722 rs_init_gf ($11D);
2723 rs_init_code (ecc_codewords, 0);
2724 rs_encode (data_codewords, data_blocks, ecc_blocks);
2725 rs_free;
2726 i := 0;
2727 while i < ecc_codewords do
2728 begin
2729 qr_bscan (binary_data, ecc_blocks[ecc_codewords - i - 1], $80);
2730 Inc (i);
2731 end;
2732 exit;
2733end;
2734
2735procedure micro_qr_m4(binary_data: PChar; ecc_mode: Integer);
2736var
2737 latch: Integer;
2738 i: Integer;
2739 remainder: Integer;
2740 bits_left: Integer;
2741 bits_total: Integer;
2742 ecc_codewords: Integer;
2743 data_codewords: Integer;
2744 ecc_blocks: array [0..15-1] of BYTE;
2745 data_blocks: array [0..17-1] of BYTE;
2746begin
2747 latch := 0;
2748 if IsTrue(ecc_mode = LEVEL_L) then
2749 begin
2750 bits_total := 128;
2751 end;
2752 if IsTrue(ecc_mode = LEVEL_M) then
2753 begin
2754 bits_total := 112;
2755 end;
2756 if IsTrue(ecc_mode = LEVEL_Q) then
2757 begin
2758 bits_total := 80;
2759 end;
2760 bits_left := bits_total - sysutils.strlen (binary_data);
2761 if IsTrue(bits_left <= 9) then
2762 begin
2763 i := 0;
2764 while i < bits_left do
2765 begin
2766 concat (binary_data, '0');
2767 Inc (i);
2768 end;
2769 latch := 1;
2770 end else begin
2771 concat (binary_data, '000000000');
2772 end;
2773 if IsTrue(latch = 0) then
2774 begin
2775 remainder := 8 - (sysutils.strlen (binary_data) mod 8);
2776 if IsTrue(remainder = 8) then
2777 begin
2778 remainder := 0;
2779 end;
2780 i := 0;
2781 while i < remainder do
2782 begin
2783 concat (binary_data, '0');
2784 Inc (i);
2785 end;
2786 bits_left := bits_total - sysutils.strlen (binary_data);
2787 remainder := bits_left div 8;
2788 i := 0;
2789 while i < remainder do
2790 begin
2791 concat (binary_data, iif (i and 1,'00010001','11101100'));
2792 Inc (i);
2793 end;
2794 end;
2795 if IsTrue(ecc_mode = LEVEL_L) then
2796 begin
2797 data_codewords := 16;
2798 ecc_codewords := 8;
2799 end;
2800 if IsTrue(ecc_mode = LEVEL_M) then
2801 begin
2802 data_codewords := 14;
2803 ecc_codewords := 10;
2804 end;
2805 if IsTrue(ecc_mode = LEVEL_Q) then
2806 begin
2807 data_codewords := 10;
2808 ecc_codewords := 14;
2809 end;
2810 i := 0;
2811 while i < data_codewords do
2812 begin
2813 data_blocks[i] := 0;
2814 if IsTrue(binary_data[i * 8] = '1') then
2815 begin
2816 data_blocks[i] := data_blocks[i] + $80;
2817 end;
2818 if IsTrue(binary_data[(i * 8) + 1] = '1') then
2819 begin
2820 data_blocks[i] := data_blocks[i] + $40;
2821 end;
2822 if IsTrue(binary_data[(i * 8) + 2] = '1') then
2823 begin
2824 data_blocks[i] := data_blocks[i] + $20;
2825 end;
2826 if IsTrue(binary_data[(i * 8) + 3] = '1') then
2827 begin
2828 data_blocks[i] := data_blocks[i] + $10;
2829 end;
2830 if IsTrue(binary_data[(i * 8) + 4] = '1') then
2831 begin
2832 data_blocks[i] := data_blocks[i] + $08;
2833 end;
2834 if IsTrue(binary_data[(i * 8) + 5] = '1') then
2835 begin
2836 data_blocks[i] := data_blocks[i] + $04;
2837 end;
2838 if IsTrue(binary_data[(i * 8) + 6] = '1') then
2839 begin
2840 data_blocks[i] := data_blocks[i] + $02;
2841 end;
2842 if IsTrue(binary_data[(i * 8) + 7] = '1') then
2843 begin
2844 data_blocks[i] := data_blocks[i] + $01;
2845 end;
2846 Inc (i);
2847 end;
2848 rs_init_gf ($11D);
2849 rs_init_code (ecc_codewords, 0);
2850 rs_encode (data_codewords, data_blocks, ecc_blocks);
2851 rs_free;
2852 i := 0;
2853 while i < ecc_codewords do
2854 begin
2855 qr_bscan (binary_data, ecc_blocks[ecc_codewords - i - 1], $80);
2856 Inc (i);
2857 end;
2858end;
2859
2860procedure micro_setup_grid(grid: PBYTE; size: Integer);
2861var
2862 toggle: Integer = 1;
2863 i: Integer = 1;
2864begin
2865 {INITCODE} toggle := 1;
2866 {INITCODE} i := 1;
2867 i := 0;
2868 while i < size do
2869 begin
2870 if IsTrue(toggle = 1) then
2871 begin
2872 grid[i] := $21;
2873 grid[(i * size)] := $21;
2874 toggle := 0;
2875 end else begin
2876 grid[i] := $20;
2877 grid[(i * size)] := $20;
2878 toggle := 1;
2879 end;
2880 Inc (i);
2881 end;
2882 place_finder (grid, size, 0, 0);
2883 i := 0;
2884 while i < 7 do
2885 begin
2886 grid[(7 * size) + i] := $10;
2887 grid[(i * size) + 7] := $10;
2888 Inc (i);
2889 end;
2890 grid[(7 * size) + 7] := $10;
2891 i := 0;
2892 while i < 8 do
2893 begin
2894 grid[(8 * size) + i] := grid[(8 * size) + i] + $20;
2895 grid[(i * size) + 8] := grid[(i * size) + 8] + $20;
2896 Inc (i);
2897 end;
2898 grid[(8 * size) + 8] := grid[(8 * size) + 8] + 20;
2899end;
2900
2901procedure micro_populate_grid(grid: PBYTE; size: Integer; full_stream: PChar);
2902var
2903 direction: Integer = 1;
2904 row: Integer = 0;
2905 y: Integer;
2906 x: Integer;
2907 n: Integer;
2908 i: Integer;
2909begin
2910 {INITCODE} direction := 1;
2911 {INITCODE} row := 0;
2912 n := sysutils.strlen (full_stream);
2913 y := size - 1;
2914 i := 0;
2915 repeat
2916 x := (size - 2) - (row * 2);
2917 if not IsTrue((grid[(y * size) + (x + 1)] and $F0)) then
2918 begin
2919 if IsTrue(full_stream[i] = '1') then
2920 begin
2921 grid[(y * size) + (x + 1)] := $01;
2922 end else begin
2923 grid[(y * size) + (x + 1)] := $00;
2924 end;
2925 Inc (i);
2926 end;
2927 if IsTrue(i < n) then
2928 begin
2929 if not IsTrue((grid[(y * size) + x] and $F0)) then
2930 begin
2931 if IsTrue(full_stream[i] = '1') then
2932 begin
2933 grid[(y * size) + x] := $01;
2934 end else begin
2935 grid[(y * size) + x] := $00;
2936 end;
2937 Inc (i);
2938 end;
2939 end;
2940 if IsTrue(direction) then
2941 begin
2942 Dec (y);
2943 end else begin
2944 Inc (y);
2945 end;
2946 if IsTrue(y = 0) then
2947 begin
2948 Inc (row);
2949 y := 1;
2950 direction := 0;
2951 end;
2952 if IsTrue(y = size) then
2953 begin
2954 Inc (row);
2955 y := size - 1;
2956 direction := 1;
2957 end;
2958 until not (i < n);
2959end;
2960
2961function micro_evaluate(grid: PBYTE; size: Integer; pattern: Integer): Integer;
2962var
2963 retval: Integer;
2964 filter: Integer = 0;
2965 i: Integer = 0;
2966 sum2: Integer = 0;
2967 sum1: Integer = 0;
2968begin
2969 {INITCODE} filter := 0;
2970 {INITCODE} i := 0;
2971 {INITCODE} sum2 := 0;
2972 {INITCODE} sum1 := 0;
2973 case pattern of
2974 0: filter := $01;
2975 1: filter := $02;
2976 2: filter := $04;
2977 3: filter := $08;
2978 end;
2979 sum1 := 0;
2980 sum2 := 0;
2981 i := 1;
2982 while i < size do
2983 begin
2984 if IsTrue(grid[(i * size) + size - 1] and filter) then
2985 begin
2986 Inc (sum1);
2987 end;
2988 if IsTrue(grid[((size - 1) * size) + i] and filter) then
2989 begin
2990 Inc (sum2);
2991 end;
2992 Inc (i);
2993 end;
2994 if IsTrue(sum1 <= sum2) then
2995 begin
2996 retval := (sum1 * 16) + sum2;
2997 end else begin
2998 retval := (sum2 * 16) + sum1;
2999 end;
3000 exit (retval);
3001end;
3002
3003function micro_apply_bitmask(grid: PBYTE; size: Integer): Integer;
3004var
3005 y: Integer;
3006 x: Integer;
3007 p: BYTE;
3008 value: array [0..8-1] of Integer;
3009 pattern: Integer;
3010 best_pattern: Integer;
3011 best_val: Integer;
3012 bit: Integer;
3013 mask: array of BYTE = nil;
3014 eval: array of BYTE = nil;
3015begin
3016 SetLength(mask,size * size);
3017 SetLength(eval,size * size);
3018 x := 0;
3019 while x < size do
3020 begin
3021 y := 0;
3022 while y < size do
3023 begin
3024 mask[(y * size) + x] := $00;
3025 if not IsTrue((grid[(y * size) + x] and $F0)) then
3026 begin
3027 if IsTrue((y and 1) = 0) then
3028 begin
3029 mask[(y * size) + x] := mask[(y * size) + x] + $01;
3030 end;
3031 if IsTrue((((y div 2) + (x div 3)) and 1) = 0) then
3032 begin
3033 mask[(y * size) + x] := mask[(y * size) + x] + $02;
3034 end;
3035 if IsTrue(((((y * x) and 1) + ((y * x) mod 3)) and 1) = 0) then
3036 begin
3037 mask[(y * size) + x] := mask[(y * size) + x] + $04;
3038 end;
3039 if IsTrue(((((y + x) and 1) + ((y * x) mod 3)) and 1) = 0) then
3040 begin
3041 mask[(y * size) + x] := mask[(y * size) + x] + $08;
3042 end;
3043 end;
3044 Inc (y);
3045 end;
3046 Inc (x);
3047 end;
3048 x := 0;
3049 while x < size do
3050 begin
3051 y := 0;
3052 while y < size do
3053 begin
3054 if IsTrue(grid[(y * size) + x] and $01) then
3055 begin
3056 p := $FF;
3057 end else begin
3058 p := $00;
3059 end;
3060 eval[(y * size) + x] := mask[(y * size) + x] xor p;
3061 Inc (y);
3062 end;
3063 Inc (x);
3064 end;
3065 pattern := 0;
3066 while pattern < 8 do
3067 begin
3068 value[pattern] := micro_evaluate (@eval[0], size, pattern);
3069 Inc (pattern);
3070 end;
3071 best_pattern := 0;
3072 best_val := value[0];
3073 pattern := 1;
3074 while pattern < 4 do
3075 begin
3076 if IsTrue(value[pattern] > best_val) then
3077 begin
3078 best_pattern := pattern;
3079 best_val := value[pattern];
3080 end;
3081 Inc (pattern);
3082 end;
3083 x := 0;
3084 while x < size do
3085 begin
3086 y := 0;
3087 while y < size do
3088 begin
3089 bit := 0;
3090 case best_pattern of
3091 0:
3092 begin
3093 if IsTrue(mask[(y * size) + x] and $01) then
3094 begin
3095 bit := 1;
3096 end;
3097 end;
3098 1:
3099 begin
3100 if IsTrue(mask[(y * size) + x] and $02) then
3101 begin
3102 bit := 1;
3103 end;
3104 end;
3105 2:
3106 begin
3107 if IsTrue(mask[(y * size) + x] and $04) then
3108 begin
3109 bit := 1;
3110 end;
3111 end;
3112 3:
3113 begin
3114 if IsTrue(mask[(y * size) + x] and $08) then
3115 begin
3116 bit := 1;
3117 end;
3118 end;
3119 end;
3120 if IsTrue(bit = 1) then
3121 begin
3122 if IsTrue(grid[(y * size) + x] and $01) then
3123 begin
3124 grid[(y * size) + x] := $00;
3125 end else begin
3126 grid[(y * size) + x] := $01;
3127 end;
3128 end;
3129 Inc (y);
3130 end;
3131 Inc (x);
3132 end;
3133 exit (best_pattern);
3134end;
3135
3136function microqr(symbol: PointerTo_zint_symbol; source: PBYTE; length: Integer): Integer;
3137var
3138 size: Integer;
3139 glyph: Integer;
3140 j: Integer;
3141 i: Integer;
3142 binary_stream: array [0..200-1] of Char;
3143 full_stream: array [0..200-1] of Char;
3144 utfdata: array [0..40-1] of Integer;
3145 jisdata: array [0..40-1] of Integer;
3146 mode: array [0..40-1] of Char;
3147 byte_used: Integer = 0;
3148 alphanum_used: Integer = 0;
3149 kanji_used: Integer = 0;
3150 error_number: Integer = 0;
3151 version_valid: array [0..4-1] of Integer;
3152 binary_count: array [0..4-1] of Integer;
3153 version: Integer;
3154 autoversion: Integer;
3155 ecc_level: Integer;
3156 format_full: Integer;
3157 format: Integer;
3158 bitmask: Integer;
3159 a_count: Integer;
3160 n_count: Integer;
3161 grid: array of BYTE = nil;
3162begin
3163 {INITCODE} byte_used := 0;
3164 {INITCODE} alphanum_used := 0;
3165 {INITCODE} kanji_used := 0;
3166 {INITCODE} error_number := 0;
3167 if IsTrue(length > 35) then
3168 begin
3169 strcpy (symbol^.errtxt, 'Input data too long');
3170 exit (ERROR_TOO_LONG);
3171 end;
3172 i := 0;
3173 while i < 4 do
3174 begin
3175 version_valid[i] := 1;
3176 Inc (i);
3177 end;
3178 case symbol^.input_mode of
3179 DATA_MODE:
3180 begin
3181 i := 0;
3182 while i < length do
3183 begin
3184 jisdata[i] := Integer (source[i]);
3185 Inc (i);
3186 end;
3187 end;
3188 otherwise
3189 begin
3190 error_number := utf8toutf16 (symbol, source, utfdata, @length);
3191 if IsTrue(error_number <> 0) then
3192 begin
3193 exit (error_number);
3194 end;
3195 i := 0;
3196 while i < length do
3197 begin
3198 if IsTrue(utfdata[i] <= $FF) then
3199 begin
3200 jisdata[i] := utfdata[i];
3201 end else begin
3202 j := 0;
3203 glyph := 0;
3204 repeat
3205 if IsTrue(sjis_lookup[j * 2] = utfdata[i]) then
3206 begin
3207 glyph := sjis_lookup[(j * 2) + 1];
3208 end;
3209 Inc (j);
3210 until not (((j < 6843)) and ((glyph = 0)));
3211 if IsTrue(glyph = 0) then
3212 begin
3213 strcpy (symbol^.errtxt, 'Invalid character in input data');
3214 exit (ERROR_INVALID_DATA);
3215 end;
3216 jisdata[i] := glyph;
3217 end;
3218 Inc (i);
3219 end;
3220 end;
3221 end;
3222 define_mode (mode, jisdata, length, false);
3223 n_count := 0;
3224 a_count := 0;
3225 i := 0;
3226 while i < length do
3227 begin
3228 if IsTrue(((jisdata[i] >= integer('0'))) and ((jisdata[i] <= integer('9')))) then
3229 begin
3230 Inc (n_count);
3231 end;
3232 if IsTrue(in_alpha (jisdata[i])) then
3233 begin
3234 Inc (a_count);
3235 end;
3236 Inc (i);
3237 end;
3238 if IsTrue(a_count = length) then
3239 begin
3240 i := 0;
3241 while i < length do
3242 begin
3243 mode[i] := 'A';
3244 Inc (i);
3245 end;
3246 end;
3247 if IsTrue(n_count = length) then
3248 begin
3249 i := 0;
3250 while i < length do
3251 begin
3252 mode[i] := 'N';
3253 Inc (i);
3254 end;
3255 end;
3256 error_number := micro_qr_intermediate (binary_stream, jisdata, mode, length, @kanji_used, @alphanum_used, @byte_used);
3257 if IsTrue(error_number <> 0) then
3258 begin
3259 strcpy (symbol^.errtxt, 'Input data too long');
3260 exit (error_number);
3261 end;
3262 get_bitlength (binary_count, binary_stream);
3263 if IsTrue(byte_used) then
3264 begin
3265 version_valid[0] := 0;
3266 version_valid[1] := 0;
3267 end;
3268 if IsTrue(alphanum_used) then
3269 begin
3270 version_valid[0] := 0;
3271 end;
3272 if IsTrue(kanji_used) then
3273 begin
3274 version_valid[0] := 0;
3275 version_valid[1] := 0;
3276 end;
3277 if IsTrue(binary_count[0] > 20) then
3278 begin
3279 version_valid[0] := 0;
3280 end;
3281 if IsTrue(binary_count[1] > 40) then
3282 begin
3283 version_valid[1] := 0;
3284 end;
3285 if IsTrue(binary_count[2] > 84) then
3286 begin
3287 version_valid[2] := 0;
3288 end;
3289 if IsTrue(binary_count[3] > 128) then
3290 begin
3291 strcpy (symbol^.errtxt, 'Input data too long');
3292 exit (ERROR_TOO_LONG);
3293 end;
3294 ecc_level := LEVEL_L;
3295 if IsTrue(((symbol^.option_1 >= 1)) and ((symbol^.option_2 <= 4))) then
3296 begin
3297 ecc_level := symbol^.option_1;
3298 end;
3299 if IsTrue(ecc_level = LEVEL_H) then
3300 begin
3301 strcpy (symbol^.errtxt, 'Error correction level H not available');
3302 exit (ERROR_INVALID_OPTION);
3303 end;
3304 if IsTrue(ecc_level = LEVEL_Q) then
3305 begin
3306 version_valid[0] := 0;
3307 version_valid[1] := 0;
3308 version_valid[2] := 0;
3309 if IsTrue(binary_count[3] > 80) then
3310 begin
3311 strcpy (symbol^.errtxt, 'Input data too long');
3312 exit (ERROR_TOO_LONG);
3313 end;
3314 end;
3315 if IsTrue(ecc_level = LEVEL_M) then
3316 begin
3317 version_valid[0] := 0;
3318 if IsTrue(binary_count[1] > 32) then
3319 begin
3320 version_valid[1] := 0;
3321 end;
3322 if IsTrue(binary_count[2] > 68) then
3323 begin
3324 version_valid[2] := 0;
3325 end;
3326 if IsTrue(binary_count[3] > 112) then
3327 begin
3328 strcpy (symbol^.errtxt, 'Input data too long');
3329 exit (ERROR_TOO_LONG);
3330 end;
3331 end;
3332 autoversion := 3;
3333 if IsTrue(version_valid[2]) then
3334 begin
3335 autoversion := 2;
3336 end;
3337 if IsTrue(version_valid[1]) then
3338 begin
3339 autoversion := 1;
3340 end;
3341 if IsTrue(version_valid[0]) then
3342 begin
3343 autoversion := 0;
3344 end;
3345 version := autoversion;
3346 if IsTrue(((symbol^.option_2 >= 1)) and ((symbol^.option_2 <= 4))) then
3347 begin
3348 if IsTrue(symbol^.option_2 >= autoversion) then
3349 begin
3350 version := symbol^.option_2;
3351 end;
3352 end;
3353 if IsTrue(version = 3) then
3354 begin
3355 if IsTrue(binary_count[3] <= 112) then
3356 begin
3357 ecc_level := LEVEL_M;
3358 end;
3359 if IsTrue(binary_count[3] <= 80) then
3360 begin
3361 ecc_level := LEVEL_Q;
3362 end;
3363 end;
3364 if IsTrue(version = 2) then
3365 begin
3366 if IsTrue(binary_count[2] <= 68) then
3367 begin
3368 ecc_level := LEVEL_M;
3369 end;
3370 end;
3371 if IsTrue(version = 1) then
3372 begin
3373 if IsTrue(binary_count[1] <= 32) then
3374 begin
3375 ecc_level := LEVEL_M;
3376 end;
3377 end;
3378 full_stream[0]:=#0;
3379 strcpy (full_stream, '');
3380 microqr_expand_binary (binary_stream, full_stream, version);
3381 case version of
3382 0: micro_qr_m1 (full_stream);
3383 1: micro_qr_m2 (full_stream, ecc_level);
3384 2: micro_qr_m3 (full_stream, ecc_level);
3385 3: micro_qr_m4 (full_stream, ecc_level);
3386 end;
3387 size := micro_qr_sizes[version];
3388 SetLength(grid,size * size);
3389 i := 0;
3390 while i < size do
3391 begin
3392 j := 0;
3393 while j < size do
3394 begin
3395 grid[(i * size) + j] := 0;
3396 Inc (j);
3397 end;
3398 Inc (i);
3399 end;
3400 micro_setup_grid (@grid[0], size);
3401 micro_populate_grid (@grid[0], size, full_stream);
3402 bitmask := micro_apply_bitmask (@grid[0], size);
3403 format := 0;
3404 case version of
3405 1:
3406 begin
3407 case ecc_level of
3408 1: format := 1;
3409 2: format := 2;
3410 end;
3411 end;
3412 2:
3413 begin
3414 case ecc_level of
3415 1: format := 3;
3416 2: format := 4;
3417 end;
3418 end;
3419 3:
3420 begin
3421 case ecc_level of
3422 1: format := 5;
3423 2: format := 6;
3424 3: format := 7;
3425 end;
3426 end;
3427 end;
3428 format_full := qr_annex_c1[(format shl 2) + bitmask];
3429 if IsTrue(format_full and $4000) then
3430 begin
3431 grid[(8 * size) + 1] := grid[(8 * size) + 1] + $01;
3432 end;
3433 if IsTrue(format_full and $2000) then
3434 begin
3435 grid[(8 * size) + 2] := grid[(8 * size) + 2] + $01;
3436 end;
3437 if IsTrue(format_full and $1000) then
3438 begin
3439 grid[(8 * size) + 3] := grid[(8 * size) + 3] + $01;
3440 end;
3441 if IsTrue(format_full and $800) then
3442 begin
3443 grid[(8 * size) + 4] := grid[(8 * size) + 4] + $01;
3444 end;
3445 if IsTrue(format_full and $400) then
3446 begin
3447 grid[(8 * size) + 5] := grid[(8 * size) + 5] + $01;
3448 end;
3449 if IsTrue(format_full and $200) then
3450 begin
3451 grid[(8 * size) + 6] := grid[(8 * size) + 6] + $01;
3452 end;
3453 if IsTrue(format_full and $100) then
3454 begin
3455 grid[(8 * size) + 7] := grid[(8 * size) + 7] + $01;
3456 end;
3457 if IsTrue(format_full and $80) then
3458 begin
3459 grid[(8 * size) + 8] := grid[(8 * size) + 8] + $01;
3460 end;
3461 if IsTrue(format_full and $40) then
3462 begin
3463 grid[(7 * size) + 8] := grid[(7 * size) + 8] + $01;
3464 end;
3465 if IsTrue(format_full and $20) then
3466 begin
3467 grid[(6 * size) + 8] := grid[(6 * size) + 8] + $01;
3468 end;
3469 if IsTrue(format_full and $10) then
3470 begin
3471 grid[(5 * size) + 8] := grid[(5 * size) + 8] + $01;
3472 end;
3473 if IsTrue(format_full and $08) then
3474 begin
3475 grid[(4 * size) + 8] := grid[(4 * size) + 8] + $01;
3476 end;
3477 if IsTrue(format_full and $04) then
3478 begin
3479 grid[(3 * size) + 8] := grid[(3 * size) + 8] + $01;
3480 end;
3481 if IsTrue(format_full and $02) then
3482 begin
3483 grid[(2 * size) + 8] := grid[(2 * size) + 8] + $01;
3484 end;
3485 if IsTrue(format_full and $01) then
3486 begin
3487 grid[(1 * size) + 8] := grid[(1 * size) + 8] + $01;
3488 end;
3489 symbol^.width := size;
3490 symbol^.rows := size;
3491 i := 0;
3492 while i < size do
3493 begin
3494 j := 0;
3495 while j < size do
3496 begin
3497 if IsTrue(grid[(i * size) + j] and $01) then
3498 begin
3499 set_module (symbol, i, j);
3500 end;
3501 Inc (j);
3502 end;
3503 symbol^.row_height[i] := 1;
3504 Inc (i);
3505 end;
3506 exit (0);
3507end;
3508
3509end.
Note: See TracBrowser for help on using the repository browser.