source: trunk/Packages/lazbarcodes/src/lbc_datamatrix.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: 35.8 KB
Line 
1unit lbc_datamatrix;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils,
9 lbc_helper, lbc_reedsolomon, zint;
10
11const
12 MAXBARCODE = 3116;
13
14function dmatrix(symbol: PointerTo_zint_symbol; source: PBYTE; length: Integer): Integer;
15
16implementation
17
18const
19
20DM_ASCII =1;
21DM_C40 =2;
22DM_TEXT =3;
23DM_X12 =4;
24DM_EDIFACT=5;
25DM_BASE256=6;
26
27c40_shift: array [0..127] of integer = (
28 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30 2, 2, 2, 2, 2, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3
32);
33
34c40_value: array [0..127] of integer = (
35 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,
36 3,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,4,5,6,7,8,9,10,11,12,13,
37 15,16,17,18,19,20,21,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,
38 22,23,24,25,26,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31
39);
40
41text_shift: array [0..127] of integer = (
42 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
43 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
44 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
45 2, 2, 2, 2, 2, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3
46);
47
48text_value: array [0..127] of integer = (
49 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,
50 3,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,4,5,6,7,8,9,10,11,12,13,
51 15,16,17,18,19,20,21,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,
52 22,23,24,25,26,0,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,27,28,29,30,31
53);
54
55intsymbol: array [0..29] of integer = (
56 0,1,3,5,7,8,10,12,13,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,2,4,6,9,11,14
57);
58
59matrixH: array [0..29] of integer = (
60 10, 12, 8, 14, 8, 16, 12, 18, 20, 12, 22, 16, 24, 26, 16, 32, 36, 40, 44, 48,
61 52, 64, 72, 80, 88, 96, 104, 120, 132, 144
62);
63
64matrixW: array [0..29] of integer = (
65 10, 12, 18, 14, 32, 16, 26, 18, 20, 36, 22, 36, 24, 26, 48, 32, 36, 40, 44,
66 48, 52, 64, 72, 80, 88, 96, 104, 120, 132, 144
67);
68
69matrixFH: array [0..29] of integer = (
70 10, 12, 8, 14, 8, 16, 12, 18, 20, 12, 22, 16, 24, 26, 16, 16, 18, 20, 22, 24,
71 26, 16, 18, 20, 22, 24, 26, 20, 22, 24
72);
73
74matrixFW: array [0..29] of integer = (
75 10, 12, 18, 14, 16, 16, 26, 18, 20, 18, 22, 18, 24, 26, 24, 16, 18, 20, 22,
76 24, 26, 16, 18, 20, 22, 24, 26, 20, 22, 24
77);
78
79matrixbytes: array [0..29] of integer = (
80 3, 5, 5, 8, 10, 12, 16, 18, 22, 22, 30, 32, 36, 44, 49, 62, 86, 114, 144,
81 174, 204, 280, 368, 456, 576, 696, 816, 1050, 1304, 1558
82);
83
84matrixdatablock: array [0..29] of integer = (
85 3, 5, 5, 8, 10, 12, 16, 18, 22, 22, 30, 32, 36, 44, 49, 62, 86, 114, 144,
86 174, 102, 140, 92, 114, 144, 174, 136, 175, 163, 156
87);
88
89matrixrsblock: array [0..29] of integer = (
90 5, 7, 7, 10, 11, 12, 14, 14, 18, 18, 20, 24, 24, 28, 28, 36, 42, 48, 56, 68,
91 42, 56, 36, 48, 56, 68, 56, 68, 62, 62
92);
93
94
95procedure ecc200placementbit(parray: PInteger; NR: Integer; NC: Integer; r: Integer; c: Integer; p: Integer; b: BYTE);
96begin
97 if IsTrue(r < 0) then
98 begin
99 r := r + NR;
100 c := c + (4 - ((NR + 4) mod 8));
101 end;
102 if IsTrue(c < 0) then
103 begin
104 c := c + NC;
105 r := r + (4 - ((NC + 4) mod 8));
106 end;
107 parray[r * NC + c] := (p shl 3) + b;
108end;
109
110procedure ecc200placementblock(parray: PInteger; NR: Integer; NC: Integer; r: Integer; c: Integer; p: Integer);
111begin
112 ecc200placementbit (parray, NR, NC, r - 2, c - 2, p, 7);
113 ecc200placementbit (parray, NR, NC, r - 2, c - 1, p, 6);
114 ecc200placementbit (parray, NR, NC, r - 1, c - 2, p, 5);
115 ecc200placementbit (parray, NR, NC, r - 1, c - 1, p, 4);
116 ecc200placementbit (parray, NR, NC, r - 1, c - 0, p, 3);
117 ecc200placementbit (parray, NR, NC, r - 0, c - 2, p, 2);
118 ecc200placementbit (parray, NR, NC, r - 0, c - 1, p, 1);
119 ecc200placementbit (parray, NR, NC, r - 0, c - 0, p, 0);
120end;
121
122procedure ecc200placementcornerA(parray: PInteger; NR: Integer; NC: Integer; p: Integer);
123begin
124 ecc200placementbit (parray, NR, NC, NR - 1, 0, p, 7);
125 ecc200placementbit (parray, NR, NC, NR - 1, 1, p, 6);
126 ecc200placementbit (parray, NR, NC, NR - 1, 2, p, 5);
127 ecc200placementbit (parray, NR, NC, 0, NC - 2, p, 4);
128 ecc200placementbit (parray, NR, NC, 0, NC - 1, p, 3);
129 ecc200placementbit (parray, NR, NC, 1, NC - 1, p, 2);
130 ecc200placementbit (parray, NR, NC, 2, NC - 1, p, 1);
131 ecc200placementbit (parray, NR, NC, 3, NC - 1, p, 0);
132end;
133
134procedure ecc200placementcornerB(parray: PInteger; NR: Integer; NC: Integer; p: Integer);
135begin
136 ecc200placementbit (parray, NR, NC, NR - 3, 0, p, 7);
137 ecc200placementbit (parray, NR, NC, NR - 2, 0, p, 6);
138 ecc200placementbit (parray, NR, NC, NR - 1, 0, p, 5);
139 ecc200placementbit (parray, NR, NC, 0, NC - 4, p, 4);
140 ecc200placementbit (parray, NR, NC, 0, NC - 3, p, 3);
141 ecc200placementbit (parray, NR, NC, 0, NC - 2, p, 2);
142 ecc200placementbit (parray, NR, NC, 0, NC - 1, p, 1);
143 ecc200placementbit (parray, NR, NC, 1, NC - 1, p, 0);
144end;
145
146procedure ecc200placementcornerC(parray: PInteger; NR: Integer; NC: Integer; p: Integer);
147begin
148 ecc200placementbit (parray, NR, NC, NR - 3, 0, p, 7);
149 ecc200placementbit (parray, NR, NC, NR - 2, 0, p, 6);
150 ecc200placementbit (parray, NR, NC, NR - 1, 0, p, 5);
151 ecc200placementbit (parray, NR, NC, 0, NC - 2, p, 4);
152 ecc200placementbit (parray, NR, NC, 0, NC - 1, p, 3);
153 ecc200placementbit (parray, NR, NC, 1, NC - 1, p, 2);
154 ecc200placementbit (parray, NR, NC, 2, NC - 1, p, 1);
155 ecc200placementbit (parray, NR, NC, 3, NC - 1, p, 0);
156end;
157
158procedure ecc200placementcornerD(parray: PInteger; NR: Integer; NC: Integer; p: Integer);
159begin
160 ecc200placementbit (parray, NR, NC, NR - 1, 0, p, 7);
161 ecc200placementbit (parray, NR, NC, NR - 1, NC - 1, p, 6);
162 ecc200placementbit (parray, NR, NC, 0, NC - 3, p, 5);
163 ecc200placementbit (parray, NR, NC, 0, NC - 2, p, 4);
164 ecc200placementbit (parray, NR, NC, 0, NC - 1, p, 3);
165 ecc200placementbit (parray, NR, NC, 1, NC - 3, p, 2);
166 ecc200placementbit (parray, NR, NC, 1, NC - 2, p, 1);
167 ecc200placementbit (parray, NR, NC, 1, NC - 1, p, 0);
168end;
169
170procedure ecc200placement(parray: PInteger; NR: Integer; NC: Integer);
171var
172 p: Integer;
173 c: Integer;
174 r: Integer;
175begin
176 r := 0;
177 while r < NR do
178 begin
179 c := 0;
180 while c < NC do
181 begin
182 parray[r * NC + c] := 0;
183 Inc (c);
184 end;
185 Inc (r);
186 end;
187 p := 1;
188 r := 4;
189 c := 0;
190 repeat
191 if IsTrue(IsTrue(r = NR) AND IsTrue(BooleanNot (c))) then
192 begin
193 ecc200placementcornerA (parray, NR, NC, PostInc (p));
194 end;
195 if IsTrue(IsTrue(IsTrue(r = NR - 2) AND IsTrue(BooleanNot (c))) AND IsTrue(NC mod 4)) then
196 begin
197 ecc200placementcornerB (parray, NR, NC, PostInc (p));
198 end;
199 if IsTrue(IsTrue(IsTrue(r = NR - 2) AND IsTrue(BooleanNot (c))) AND IsTrue((NC mod 8) = 4)) then
200 begin
201 ecc200placementcornerC (parray, NR, NC, PostInc (p));
202 end;
203 if IsTrue(IsTrue(IsTrue(r = NR + 4) AND IsTrue(c = 2)) AND IsTrue(BooleanNot ((NC mod 8)))) then
204 begin
205 ecc200placementcornerD (parray, NR, NC, PostInc (p));
206 end;
207 repeat
208 if IsTrue(IsTrue(IsTrue(r < NR) AND IsTrue(c >= 0)) AND IsTrue(BooleanNot (parray[r * NC + c]))) then
209 begin
210 ecc200placementblock (parray, NR, NC, r, c, PostInc (p));
211 end;
212 r := r - 2;
213 c := c + 2;
214 until not (IsTrue(r >= 0) AND IsTrue(c < NC));
215 Inc (r);
216 c := c + 3;
217 repeat
218 if IsTrue(IsTrue(IsTrue(r >= 0) AND IsTrue(c < NC)) AND IsTrue(BooleanNot (parray[r * NC + c]))) then
219 begin
220 ecc200placementblock (parray, NR, NC, r, c, PostInc (p));
221 end;
222 r := r + 2;
223 c := c - 2;
224 until not (IsTrue(r < NR) AND IsTrue(c >= 0));
225 r := r + 3;
226 Inc (c);
227 until not (IsTrue(r < NR) OR IsTrue(c < NC));
228 if IsTrue(BooleanNot (parray[NR * NC - 1])) then
229 begin
230 parray[NR * NC - NC - 2] := 1;
231 parray[NR * NC - 1] := 1;
232 end;
233end;
234
235procedure ecc200(binary: PBYTE; bytes: Integer; datablock: Integer; rsblock: Integer; skew: Integer);
236var
237 b: Integer;
238 blocks: Integer;
239 p: Integer;
240 n: Integer;
241 ecc: array [0..256-1] of BYTE;
242 buf: array [0..256-1] of BYTE;
243begin
244 {INITCODE} blocks := (bytes + 2) div datablock;
245 rs_init_gf ($12D);
246 rs_init_code (rsblock, 1);
247 b := 0;
248 while b < blocks do
249 begin
250 p := 0;
251 n := b;
252 while n < bytes do
253 begin
254 buf[PostInc (p)] := binary[n];
255 n := n + blocks;
256 end;
257 rs_encode (p, buf, ecc);
258 p := rsblock - 1;
259 n := b;
260 while n < rsblock * blocks do
261 begin
262 if IsTrue(skew) then
263 begin
264 if IsTrue(b < 8) then
265 begin
266 binary[bytes + n + 2] := ecc[PostDec (p)];
267 end else begin
268 binary[bytes + n - 8] := ecc[PostDec (p)];
269 end;
270 end else begin
271 binary[bytes + n] := ecc[PostDec (p)];
272 end;
273 n := n + blocks;
274 end;
275 Inc (b);
276 end;
277 rs_free;
278end;
279
280function isx12(source: BYTE): Integer;
281begin
282 if IsTrue(source = 13) then
283 begin
284 exit (1);
285 end;
286 if IsTrue(source = 42) then
287 begin
288 exit (1);
289 end;
290 if IsTrue(source = 62) then
291 begin
292 exit (1);
293 end;
294 if IsTrue(source = 32) then
295 begin
296 exit (1);
297 end;
298 if IsTrue(IsTrue((source >= BYTE('0'))) AND IsTrue((source <= BYTE('9')))) then
299 begin
300 exit (1);
301 end;
302 if IsTrue(IsTrue((source >= BYTE('A'))) AND IsTrue((source <= BYTE('Z')))) then
303 begin
304 exit (1);
305 end;
306 exit (0);
307end;
308
309procedure dminsert(binary_string: PChar; posn: Integer; newbit: Char);
310var
311 lend: Integer;
312 i: Integer;
313begin
314 lend := sysutils.strlen (binary_string);
315 i := lend;
316 while i > posn do
317 begin
318 binary_string[i] := binary_string[i - 1];
319 Dec (i);
320 end;
321 binary_string[posn] := newbit;
322end;
323
324procedure insert_value(binary_stream: PBYTE; posn: Integer; streamlen: Integer; newbit: BYTE);
325var
326 i: Integer;
327begin
328 i := streamlen;
329 while i > posn do
330 begin
331 binary_stream[i] := binary_stream[i - 1];
332 Dec (i);
333 end;
334 binary_stream[posn] := newbit;
335end;
336
337function look_ahead_test(source: PBYTE; sourcelen: Integer; position: Integer; current_mode: Integer; gs1: Integer): Integer;
338var
339 best_count: Single;
340 b256_count: Single;
341 edf_count: Single;
342 x12_count: Single;
343 text_count: Single;
344 c40_count: Single;
345 ascii_count: Single;
346 best_scheme: Integer;
347 done: Integer;
348 sp: Integer;
349 reduced_char: Char;
350begin
351 if IsTrue(current_mode = DM_ASCII) then
352 begin
353 ascii_count := 0.0;
354 c40_count := 1.0;
355 text_count := 1.0;
356 x12_count := 1.0;
357 edf_count := 1.0;
358 b256_count := 1.25;
359 end else begin
360 ascii_count := 1.0;
361 c40_count := 2.0;
362 text_count := 2.0;
363 x12_count := 2.0;
364 edf_count := 2.0;
365 b256_count := 2.25;
366 end;
367 case current_mode of
368 DM_C40: c40_count := 0.0;
369 DM_TEXT: text_count := 0.0;
370 DM_X12: x12_count := 0.0;
371 DM_EDIFACT: edf_count := 0.0;
372 DM_BASE256: b256_count := 0.0;
373 end;
374 sp := position;
375 while IsTrue((sp < sourcelen)) AND IsTrue((sp <= (position + 8))) do
376 begin
377 if IsTrue(source[sp] <= 127) then
378 begin
379 reduced_char := char(source[sp]);
380 end else begin
381 reduced_char := char(source[sp] - 127);
382 end;
383 if IsTrue(IsTrue((source[sp] >= BYTE('0'))) AND IsTrue((source[sp] <= BYTE('9')))) then
384 begin
385 ascii_count := ascii_count + 0.5;
386 end else begin
387 ascii_count := ascii_count + 1.0;
388 end;
389 if IsTrue(source[sp] > 127) then
390 begin
391 ascii_count := ascii_count + 1.0;
392 end;
393 done := 0;
394 if IsTrue(reduced_char = ' ') then
395 begin
396 c40_count := c40_count + ((2.0 / 3.0));
397 done := 1;
398 end;
399 if IsTrue(IsTrue((reduced_char >= '0')) AND IsTrue((reduced_char <= '9'))) then
400 begin
401 c40_count := c40_count + ((2.0 / 3.0));
402 done := 1;
403 end;
404 if IsTrue(IsTrue((reduced_char >= 'A')) AND IsTrue((reduced_char <= 'Z'))) then
405 begin
406 c40_count := c40_count + ((2.0 / 3.0));
407 done := 1;
408 end;
409 if IsTrue(source[sp] > 127) then
410 begin
411 c40_count := c40_count + ((4.0 / 3.0));
412 end;
413 if IsTrue(done = 0) then
414 begin
415 c40_count := c40_count + ((4.0 / 3.0));
416 end;
417 done := 0;
418 if IsTrue(reduced_char = ' ') then
419 begin
420 text_count := text_count + ((2.0 / 3.0));
421 done := 1;
422 end;
423 if IsTrue(IsTrue((reduced_char >= '0')) AND IsTrue((reduced_char <= '9'))) then
424 begin
425 text_count := text_count + ((2.0 / 3.0));
426 done := 1;
427 end;
428 if IsTrue(IsTrue((reduced_char >= 'a')) AND IsTrue((reduced_char <= 'z'))) then
429 begin
430 text_count := text_count + ((2.0 / 3.0));
431 done := 1;
432 end;
433 if IsTrue(source[sp] > 127) then
434 begin
435 text_count := text_count + ((4.0 / 3.0));
436 end;
437 if IsTrue(done = 0) then
438 begin
439 text_count := text_count + ((4.0 / 3.0));
440 end;
441 if IsTrue(isx12 (source[sp])) then
442 begin
443 x12_count := x12_count + ((2.0 / 3.0));
444 end else begin
445 x12_count := x12_count + 4.0;
446 end;
447 done := 0;
448 if IsTrue(IsTrue((source[sp] >= BYTE(' '))) AND IsTrue((source[sp] <= BYTE('^')))) then
449 begin
450 edf_count := edf_count + ((3.0 / 4.0));
451 end else begin
452 edf_count := edf_count + 6.0;
453 end;
454 if IsTrue(IsTrue(gs1) AND IsTrue((source[sp] = BYTE('[')))) then
455 begin
456 edf_count := edf_count + 6.0;
457 end;
458 if IsTrue(sp >= (sourcelen - 5)) then
459 begin
460 edf_count := edf_count + 6.0;
461 end;
462 if IsTrue(IsTrue(gs1) AND IsTrue((source[sp] = BYTE('[')))) then
463 begin
464 b256_count := b256_count + 4.0;
465 end else begin
466 b256_count := b256_count + 1.0;
467 end;
468 Inc (sp);
469 end;
470 best_count := ascii_count;
471 best_scheme := DM_ASCII;
472 if IsTrue(b256_count <= best_count) then
473 begin
474 best_count := b256_count;
475 best_scheme := DM_BASE256;
476 end;
477 if IsTrue(edf_count <= best_count) then
478 begin
479 best_count := edf_count;
480 best_scheme := DM_EDIFACT;
481 end;
482 if IsTrue(text_count <= best_count) then
483 begin
484 best_count := text_count;
485 best_scheme := DM_TEXT;
486 end;
487 if IsTrue(x12_count <= best_count) then
488 begin
489 best_count := x12_count;
490 best_scheme := DM_X12;
491 end;
492 if IsTrue(c40_count <= best_count) then
493 begin
494 best_count := c40_count;
495 best_scheme := DM_C40;
496 end;
497 exit (best_scheme);
498end;
499
500function dm200encode(symbol: PointerTo_zint_symbol; source: PBYTE; target: PBYTE; last_mode: PInteger; length: Integer): Integer;
501var
502 gs1: Integer;
503 i: Integer;
504 tp: Integer;
505 sp: Integer;
506 next_mode: Integer;
507 current_mode: Integer;
508 inputlen: Integer;
509 c40_p: Integer;
510 c40_buffer: array [0..6-1] of Integer;
511 text_p: Integer;
512 text_buffer: array [0..6-1] of Integer;
513 x12_p: Integer;
514 x12_buffer: array [0..6-1] of Integer;
515 edifact_p: Integer;
516 edifact_buffer: array [0..8-1] of Integer;
517 debug: Integer = 0;
518 binary: array of Char = nil;
519 value: Integer;
520 shift_set: Integer;
521 iv: Integer;
522 binary_count: Integer;
523 temp: Integer;
524 prn: Integer;
525begin
526 {INITCODE} inputlen := length;
527 {INITCODE} debug := 0;
528 SetLength(binary,2 * inputlen-1);
529 sp := 0;
530 tp := 0;
531 memset (@c40_buffer[0], 0, 6);
532 c40_p := 0;
533 memset (@text_buffer[0], 0, 6);
534 text_p := 0;
535 memset (@x12_buffer[0], 0, 6);
536 x12_p := 0;
537 memset (@edifact_buffer[0], 0, 8);
538 edifact_p := 0;
539 strcpy (binary, '');
540 current_mode := DM_ASCII;
541 next_mode := DM_ASCII;
542 if IsTrue(symbol^.input_mode = GS1_MODE) then
543 begin
544 gs1 := 1;
545 end else begin
546 gs1 := 0;
547 end;
548 if IsTrue(gs1) then
549 begin
550 target[tp] := 232;
551 Inc (tp);
552 concat (binary, ' ');
553 if IsTrue(debug) then
554 begin
555 write( format ('FN1 ',[]) );
556 end;
557 end;
558 if IsTrue(symbol^.output_options and READER_INIT) then
559 begin
560 if IsTrue(gs1) then
561 begin
562 strcpy (symbol^.errtxt, 'Cannot encode in GS1 mode and Reader Initialisation at the same time');
563 exit (ERROR_INVALID_OPTION);
564 end else begin
565 target[tp] := 234;
566 Inc (tp);
567 concat (binary, ' ');
568 if IsTrue(debug) then
569 begin
570 write( format ('RP ',[]) );
571 end;
572 end;
573 end;
574 while sp < inputlen do
575 begin
576 current_mode := next_mode;
577 if IsTrue(current_mode = DM_ASCII) then
578 begin
579 next_mode := DM_ASCII;
580 if IsTrue(IsTrue(istwodigits (source, sp)) AND IsTrue(((sp + 1) <> inputlen))) then
581 begin
582 target[tp] := (10 * ctoi (source[sp])) + ctoi (source[sp + 1]) + 130;
583 if IsTrue(debug) then
584 begin
585 write( format ('N%d ',[target[tp] - 130]) );
586 end;
587 Inc (tp);
588 concat (binary, ' ');
589 sp := sp + 2;
590 end else begin
591 next_mode := look_ahead_test (source, inputlen, sp, current_mode, gs1);
592 if IsTrue(next_mode <> DM_ASCII) then
593 begin
594 case next_mode of
595 DM_C40:
596 begin
597 target[tp] := 230;
598 Inc (tp);
599 concat (binary, ' ');
600 if IsTrue(debug) then
601 begin
602 write( format ('C40 ',[]) );
603 end;
604 end;
605 DM_TEXT:
606 begin
607 target[tp] := 239;
608 Inc (tp);
609 concat (binary, ' ');
610 if IsTrue(debug) then
611 begin
612 write( format ('TEX ',[]) );
613 end;
614 end;
615 DM_X12:
616 begin
617 target[tp] := 238;
618 Inc (tp);
619 concat (binary, ' ');
620 if IsTrue(debug) then
621 begin
622 write( format ('X12 ',[]) );
623 end;
624 end;
625 DM_EDIFACT:
626 begin
627 target[tp] := 240;
628 Inc (tp);
629 concat (binary, ' ');
630 if IsTrue(debug) then
631 begin
632 write( format ('EDI ',[]) );
633 end;
634 end;
635 DM_BASE256:
636 begin
637 target[tp] := 231;
638 Inc (tp);
639 concat (binary, ' ');
640 if IsTrue(debug) then
641 begin
642 write( format ('BAS ',[]) );
643 end;
644 end;
645 end;
646 end else begin
647 if IsTrue(source[sp] > 127) then
648 begin
649 target[tp] := 235;
650 if IsTrue(debug) then
651 begin
652 write( format ('FN4 ',[]) );
653 end;
654 Inc (tp);
655 target[tp] := (source[sp] - 128) + 1;
656 if IsTrue(debug) then
657 begin
658 write( format ('A%02X ',[target[tp] - 1]) );
659 end;
660 Inc (tp);
661 concat (binary, ' ');
662 end else begin
663 if IsTrue(IsTrue(gs1) AND IsTrue((source[sp] = BYTE('[')))) then
664 begin
665 target[tp] := 232;
666 if IsTrue(debug) then
667 begin
668 write( format ('FN1 ',[]) );
669 end;
670 end else begin
671 target[tp] := source[sp] + 1;
672 if IsTrue(debug) then
673 begin
674 write( format ('A%02X ',[target[tp] - 1]) );
675 end;
676 end;
677 Inc (tp);
678 concat (binary, ' ');
679 end;
680 Inc (sp);
681 end;
682 end;
683 end;
684 if IsTrue(current_mode = DM_C40) then
685 begin
686 next_mode := DM_C40;
687 if IsTrue(c40_p = 0) then
688 begin
689 next_mode := look_ahead_test (source, inputlen, sp, current_mode, gs1);
690 end;
691 if IsTrue(next_mode <> DM_C40) then
692 begin
693 target[tp] := 254;
694 Inc (tp);
695 concat (binary, ' ');
696 next_mode := DM_ASCII;
697 if IsTrue(debug) then
698 begin
699 write( format ('ASC ',[]) );
700 end;
701 end else begin
702 if IsTrue(source[sp] > 127) then
703 begin
704 c40_buffer[c40_p] := 1;
705 Inc (c40_p);
706 c40_buffer[c40_p] := 30;
707 Inc (c40_p);
708 shift_set := c40_shift[source[sp] - 128];
709 value := c40_value[source[sp] - 128];
710 end else begin
711 shift_set := c40_shift[source[sp]];
712 value := c40_value[source[sp]];
713 end;
714 if IsTrue(IsTrue(gs1) AND IsTrue((source[sp] = BYTE('[')))) then
715 begin
716 shift_set := 2;
717 value := 27;
718 end;
719 if IsTrue(shift_set <> 0) then
720 begin
721 c40_buffer[c40_p] := shift_set - 1;
722 Inc (c40_p);
723 end;
724 c40_buffer[c40_p] := value;
725 Inc (c40_p);
726 if IsTrue(c40_p >= 3) then
727 begin
728 iv := (1600 * c40_buffer[0]) + (40 * c40_buffer[1]) + (c40_buffer[2]) + 1;
729 target[tp] := iv div 256;
730 Inc (tp);
731 target[tp] := iv mod 256;
732 Inc (tp);
733 concat (binary, ' ');
734 if IsTrue(debug) then
735 begin
736 write( format ('[%d %d %d] ',[c40_buffer[0], c40_buffer[1], c40_buffer[2]]) );
737 end;
738 c40_buffer[0] := c40_buffer[3];
739 c40_buffer[1] := c40_buffer[4];
740 c40_buffer[2] := c40_buffer[5];
741 c40_buffer[3] := 0;
742 c40_buffer[4] := 0;
743 c40_buffer[5] := 0;
744 c40_p := c40_p - 3;
745 end;
746 Inc (sp);
747 end;
748 end;
749 if IsTrue(current_mode = DM_TEXT) then
750 begin
751 next_mode := DM_TEXT;
752 if IsTrue(text_p = 0) then
753 begin
754 next_mode := look_ahead_test (source, inputlen, sp, current_mode, gs1);
755 end;
756 if IsTrue(next_mode <> DM_TEXT) then
757 begin
758 target[tp] := 254;
759 Inc (tp);
760 concat (binary, ' ');
761 next_mode := DM_ASCII;
762 if IsTrue(debug) then
763 begin
764 write( format ('ASC ',[]) );
765 end;
766 end else begin
767 if IsTrue(source[sp] > 127) then
768 begin
769 text_buffer[text_p] := 1;
770 Inc (text_p);
771 text_buffer[text_p] := 30;
772 Inc (text_p);
773 shift_set := text_shift[source[sp] - 128];
774 value := text_value[source[sp] - 128];
775 end else begin
776 shift_set := text_shift[source[sp]];
777 value := text_value[source[sp]];
778 end;
779 if IsTrue(IsTrue(gs1) AND IsTrue((source[sp] = BYTE('[')))) then
780 begin
781 shift_set := 2;
782 value := 27;
783 end;
784 if IsTrue(shift_set <> 0) then
785 begin
786 text_buffer[text_p] := shift_set - 1;
787 Inc (text_p);
788 end;
789 text_buffer[text_p] := value;
790 Inc (text_p);
791 if IsTrue(text_p >= 3) then
792 begin
793 iv := (1600 * text_buffer[0]) + (40 * text_buffer[1]) + (text_buffer[2]) + 1;
794 target[tp] := iv div 256;
795 Inc (tp);
796 target[tp] := iv mod 256;
797 Inc (tp);
798 concat (binary, ' ');
799 if IsTrue(debug) then
800 begin
801 write( format ('[%d %d %d] ',[text_buffer[0], text_buffer[1], text_buffer[2]]) );
802 end;
803 text_buffer[0] := text_buffer[3];
804 text_buffer[1] := text_buffer[4];
805 text_buffer[2] := text_buffer[5];
806 text_buffer[3] := 0;
807 text_buffer[4] := 0;
808 text_buffer[5] := 0;
809 text_p := text_p - 3;
810 end;
811 Inc (sp);
812 end;
813 end;
814 if IsTrue(current_mode = DM_X12) then
815 begin
816 {INITCODE} value := 0;
817 next_mode := DM_X12;
818 if IsTrue(text_p = 0) then
819 begin
820 next_mode := look_ahead_test (source, inputlen, sp, current_mode, gs1);
821 end;
822 if IsTrue(next_mode <> DM_X12) then
823 begin
824 target[tp] := 254;
825 Inc (tp);
826 concat (binary, ' ');
827 next_mode := DM_ASCII;
828 if IsTrue(debug) then
829 begin
830 write( format ('ASC ',[]) );
831 end;
832 end else begin
833 if IsTrue(source[sp] = 13) then
834 begin
835 value := 0;
836 end;
837 if IsTrue(source[sp] = BYTE('*')) then
838 begin
839 value := 1;
840 end;
841 if IsTrue(source[sp] = BYTE('>')) then
842 begin
843 value := 2;
844 end;
845 if IsTrue(source[sp] = BYTE(' ')) then
846 begin
847 value := 3;
848 end;
849 if IsTrue(IsTrue((source[sp] >= BYTE('0'))) AND IsTrue((source[sp] <= BYTE('9')))) then
850 begin
851 value := (source[sp] - BYTE('0')) + 4;
852 end;
853 if IsTrue(IsTrue((source[sp] >= BYTE('A'))) AND IsTrue((source[sp] <= BYTE('Z')))) then
854 begin
855 value := (source[sp] - BYTE('A')) + 14;
856 end;
857 x12_buffer[x12_p] := value;
858 Inc (x12_p);
859 if IsTrue(x12_p >= 3) then
860 begin
861 iv := (1600 * x12_buffer[0]) + (40 * x12_buffer[1]) + (x12_buffer[2]) + 1;
862 target[tp] := iv div 256;
863 Inc (tp);
864 target[tp] := iv mod 256;
865 Inc (tp);
866 concat (binary, ' ');
867 if IsTrue(debug) then
868 begin
869 write( format ('[%d %d %d] ',[x12_buffer[0], x12_buffer[1], x12_buffer[2]]) );
870 end;
871 x12_buffer[0] := x12_buffer[3];
872 x12_buffer[1] := x12_buffer[4];
873 x12_buffer[2] := x12_buffer[5];
874 x12_buffer[3] := 0;
875 x12_buffer[4] := 0;
876 x12_buffer[5] := 0;
877 x12_p := x12_p - 3;
878 end;
879 Inc (sp);
880 end;
881 end;
882 if IsTrue(current_mode = DM_EDIFACT) then
883 begin
884 {INITCODE} value := 0;
885 next_mode := DM_EDIFACT;
886 if IsTrue(edifact_p = 3) then
887 begin
888 next_mode := look_ahead_test (source, inputlen, sp, current_mode, gs1);
889 end;
890 if IsTrue(next_mode <> DM_EDIFACT) then
891 begin
892 edifact_buffer[edifact_p] := 31;
893 Inc (edifact_p);
894 next_mode := DM_ASCII;
895 end else begin
896 if IsTrue(IsTrue((source[sp] >= BYTE('@'))) AND IsTrue((source[sp] <= BYTE('^')))) then
897 begin
898 value := source[sp] - BYTE('@');
899 end;
900 if IsTrue(IsTrue((source[sp] >= BYTE(' '))) AND IsTrue((source[sp] <= BYTE('?')))) then
901 begin
902 value := source[sp];
903 end;
904 edifact_buffer[edifact_p] := value;
905 Inc (edifact_p);
906 Inc (sp);
907 end;
908 if IsTrue(edifact_p >= 4) then
909 begin
910 target[tp] := (edifact_buffer[0] shl 2) + ((edifact_buffer[1] and $30) shr 4);
911 Inc (tp);
912 target[tp] := ((edifact_buffer[1] and $0F) shl 4) + ((edifact_buffer[2] and $3C) shr 2);
913 Inc (tp);
914 target[tp] := ((edifact_buffer[2] and $03) shl 6) + edifact_buffer[3];
915 Inc (tp);
916 concat (binary, ' ');
917 if IsTrue(debug) then
918 begin
919 write( format ('[%d %d %d %d] ',[edifact_buffer[0], edifact_buffer[1], edifact_buffer[2], edifact_buffer[3]]) );
920 end;
921 edifact_buffer[0] := edifact_buffer[4];
922 edifact_buffer[1] := edifact_buffer[5];
923 edifact_buffer[2] := edifact_buffer[6];
924 edifact_buffer[3] := edifact_buffer[7];
925 edifact_buffer[4] := 0;
926 edifact_buffer[5] := 0;
927 edifact_buffer[6] := 0;
928 edifact_buffer[7] := 0;
929 edifact_p := edifact_p - 4;
930 end;
931 end;
932 if IsTrue(current_mode = DM_BASE256) then
933 begin
934 next_mode := look_ahead_test (source, inputlen, sp, current_mode, gs1);
935 if IsTrue(next_mode = DM_BASE256) then
936 begin
937 target[tp] := source[sp];
938 if IsTrue(debug) then
939 begin
940 write( format ('B%02X ',[target[tp]]) );
941 end;
942 Inc (tp);
943 Inc (sp);
944 concat (binary, 'b');
945 end else begin
946 next_mode := DM_ASCII;
947 if IsTrue(debug) then
948 begin
949 write( format ('ASC ',[]) );
950 end;
951 end;
952 end;
953 if IsTrue(tp > 1558) then
954 begin
955 exit (0);
956 end;
957 end;
958 if IsTrue(c40_p = 2) then
959 begin
960 target[tp] := 254;
961 Inc (tp);
962 target[tp] := source[inputlen - 2] + 1;
963 Inc (tp);
964 target[tp] := source[inputlen - 1] + 1;
965 Inc (tp);
966 concat (binary, ' ');
967 if IsTrue(debug) then
968 begin
969 write( format ('ASC A%02X A%02X ',[target[tp - 2] - 1, target[tp - 1] - 1]) );
970 end;
971 current_mode := DM_ASCII;
972 end;
973 if IsTrue(c40_p = 1) then
974 begin
975 target[tp] := 254;
976 Inc (tp);
977 target[tp] := source[inputlen - 1] + 1;
978 Inc (tp);
979 concat (binary, ' ');
980 if IsTrue(debug) then
981 begin
982 write( format ('ASC A%02X ',[target[tp - 1] - 1]) );
983 end;
984 current_mode := DM_ASCII;
985 end;
986 if IsTrue(text_p = 2) then
987 begin
988 target[tp] := 254;
989 Inc (tp);
990 target[tp] := source[inputlen - 2] + 1;
991 Inc (tp);
992 target[tp] := source[inputlen - 1] + 1;
993 Inc (tp);
994 concat (binary, ' ');
995 if IsTrue(debug) then
996 begin
997 write( format ('ASC A%02X A%02X ',[target[tp - 2] - 1, target[tp - 1] - 1]) );
998 end;
999 current_mode := DM_ASCII;
1000 end;
1001 if IsTrue(text_p = 1) then
1002 begin
1003 target[tp] := 254;
1004 Inc (tp);
1005 target[tp] := source[inputlen - 1] + 1;
1006 Inc (tp);
1007 concat (binary, ' ');
1008 if IsTrue(debug) then
1009 begin
1010 write( format ('ASC A%02X ',[target[tp - 1] - 1]) );
1011 end;
1012 current_mode := DM_ASCII;
1013 end;
1014 if IsTrue(x12_p = 2) then
1015 begin
1016 target[tp] := 254;
1017 Inc (tp);
1018 target[tp] := source[inputlen - 2] + 1;
1019 Inc (tp);
1020 target[tp] := source[inputlen - 1] + 1;
1021 Inc (tp);
1022 concat (binary, ' ');
1023 if IsTrue(debug) then
1024 begin
1025 write( format ('ASC A%02X A%02X ',[target[tp - 2] - 1, target[tp - 1] - 1]) );
1026 end;
1027 current_mode := DM_ASCII;
1028 end;
1029 if IsTrue(x12_p = 1) then
1030 begin
1031 target[tp] := 254;
1032 Inc (tp);
1033 target[tp] := source[inputlen - 1] + 1;
1034 Inc (tp);
1035 concat (binary, ' ');
1036 if IsTrue(debug) then
1037 begin
1038 write( format ('ASC A%02X ',[target[tp - 1] - 1]) );
1039 end;
1040 current_mode := DM_ASCII;
1041 end;
1042 i := 0;
1043 while i < tp do
1044 begin
1045 if IsTrue(binary[i] = 'b') then
1046 begin
1047 if IsTrue(IsTrue((i = 0)) OR IsTrue((IsTrue((i <> 0)) AND IsTrue((binary[i - 1] <> 'b'))))) then
1048 begin
1049 binary_count := 0;
1050 while binary[binary_count + i] = 'b' do
1051 begin
1052 Inc (binary_count);
1053 end;
1054 if IsTrue(binary_count <= 249) then
1055 begin
1056 dminsert (@binary[0], i, 'b');
1057 insert_value (target, i, tp, binary_count);
1058 Inc (tp);
1059 end else begin
1060 dminsert (@binary[0], i, 'b');
1061 dminsert (@binary[0], i + 1, 'b');
1062 insert_value (target, i, tp, (binary_count div 250) + 249);
1063 Inc (tp);
1064 insert_value (target, i + 1, tp, binary_count mod 250);
1065 Inc (tp);
1066 end;
1067 end;
1068 end;
1069 Inc (i);
1070 end;
1071 i := 0;
1072 while i < tp do
1073 begin
1074 if IsTrue(binary[i] = 'b') then
1075 begin
1076 prn := ((149 * (i + 1)) mod 255) + 1;
1077 temp := target[i] + prn;
1078 if IsTrue(temp <= 255) then
1079 begin
1080 target[i] := temp;
1081 end else begin
1082 target[i] := temp - 256;
1083 end;
1084 end;
1085 Inc (i);
1086 end;
1087 if IsTrue(debug) then
1088 begin
1089 write( format ('\n\n',[]) );
1090 i := 0;
1091 while i < tp do
1092 begin
1093 write( format ('%02X ',[target[i]]) );
1094 Inc (i);
1095 end;
1096 write( format ('\n',[]) );
1097 end;
1098 (last_mode)^ := current_mode;
1099 exit (tp);
1100end;
1101
1102procedure add_tail(target: PBYTE; tp: Integer; tail_length: Integer; last_mode: Integer);
1103var
1104 temp: Integer;
1105 prn: Integer;
1106 i: Integer;
1107begin
1108 case last_mode of
1109 DM_C40,
1110 DM_TEXT,
1111 DM_X12:
1112 begin
1113 target[tp] := 254;
1114 Inc (tp);
1115 Dec (tail_length);
1116 end;
1117 {>WARNING< code without ending break}
1118 end;
1119 i := tail_length;
1120 while i > 0 do
1121 begin
1122 if IsTrue(i = tail_length) then
1123 begin
1124 target[tp] := 129;
1125 Inc (tp);
1126 end else begin
1127 prn := ((149 * (tp + 1)) mod 253) + 1;
1128 temp := 129 + prn;
1129 if IsTrue(temp <= 254) then
1130 begin
1131 target[tp] := temp;
1132 Inc (tp);
1133 end else begin
1134 target[tp] := temp - 254;
1135 Inc (tp);
1136 end;
1137 end;
1138 Dec (i);
1139 end;
1140end;
1141
1142function data_matrix_200(symbol: PointerTo_zint_symbol; source: PBYTE; length: Integer): Integer;
1143var
1144 skew: Integer = 0;
1145 i: Integer = 0;
1146 //inputlen: Integer = 0;
1147 binary: array [0..2200-1] of BYTE;
1148 binlen: Integer;
1149 calcsize: Integer;
1150 optionsize: Integer;
1151 symbolsize: Integer;
1152 error_number: Integer = 0;
1153 taillength: Integer = 0;
1154 rsblock: Integer;
1155 bytes: Integer;
1156 datablock: Integer;
1157 FW: Integer;
1158 FH: Integer;
1159 W: Integer;
1160 H: Integer;
1161 last_mode: Integer;
1162 grid: PBYTE;
1163 places: PInteger;
1164 NR: Integer;
1165 NC: Integer;
1166 y: Integer;
1167 x: Integer;
1168 v: Integer;
1169begin
1170 {INITCODE} skew := 0;
1171 {INITCODE} i := 0;
1172 //{INITCODE} inputlen := 0;
1173 {INITCODE} error_number := 0;
1174 {INITCODE} taillength := 0;
1175 {INITCODE} grid := nil;
1176 //inputlen := length;
1177 binlen := dm200encode (symbol, source, binary, @last_mode, length);
1178 if IsTrue(binlen = 0) then
1179 begin
1180 strcpy (symbol^.errtxt, 'Data too long to fit in symbol');
1181 exit (ERROR_TOO_LONG);
1182 end;
1183 if IsTrue(IsTrue((symbol^.option_2 >= 1)) AND IsTrue((symbol^.option_2 <= 30))) then
1184 begin
1185 optionsize := intsymbol[symbol^.option_2 - 1];
1186 end else begin
1187 optionsize := -1;
1188 end;
1189 calcsize := 29;
1190 i := 29;
1191 while i > -1 do
1192 begin
1193 if IsTrue(matrixbytes[i] >= binlen) then
1194 begin
1195 calcsize := i;
1196 end;
1197 Dec (i);
1198 end;
1199 if IsTrue(symbol^.option_3 = DM_SQUARE) then
1200 begin
1201 case calcsize of
1202 2,
1203 4,
1204 6,
1205 9,
1206 11,
1207 14: Inc (calcsize);
1208 {>WARNING< code without ending break}
1209 end;
1210 end;
1211 symbolsize := optionsize;
1212 if IsTrue(calcsize > optionsize) then
1213 begin
1214 symbolsize := calcsize;
1215 if IsTrue(optionsize <> -1) then
1216 begin
1217 error_number := WARN_INVALID_OPTION;
1218 strcpy (symbol^.errtxt, 'Data does not fit in selected symbol size');
1219 end;
1220 end;
1221 H := matrixH[symbolsize];
1222 W := matrixW[symbolsize];
1223 FH := matrixFH[symbolsize];
1224 FW := matrixFW[symbolsize];
1225 bytes := matrixbytes[symbolsize];
1226 datablock := matrixdatablock[symbolsize];
1227 rsblock := matrixrsblock[symbolsize];
1228 taillength := bytes - binlen;
1229 if IsTrue(taillength <> 0) then
1230 begin
1231 add_tail (binary, binlen, taillength, last_mode);
1232 end;
1233 if IsTrue(symbolsize = 29) then
1234 begin
1235 skew := 1;
1236 end;
1237 ecc200 (binary, bytes, datablock, rsblock, skew);
1238 NC := W - 2 * (W div FW);
1239 NR := H - 2 * (H div FH);
1240 places := PInteger (GetMem (NC * NR * SizeOf (Integer)));
1241 ecc200placement (places, NR, NC);
1242 grid := PBYTE (GetMem (W * H));
1243 memset (grid, 0, W * H);
1244 y := 0;
1245 while y < H do
1246 begin
1247 x := 0;
1248 while x < W do
1249 begin
1250 grid[y * W + x] := 1;
1251 Inc (x);
1252 end;
1253 x := 0;
1254 while x < W do
1255 begin
1256 grid[(y + FH - 1) * W + x] := 1;
1257 x := x + 2;
1258 end;
1259 y := y + FH;
1260 end;
1261 x := 0;
1262 while x < W do
1263 begin
1264 y := 0;
1265 while y < H do
1266 begin
1267 grid[y * W + x] := 1;
1268 Inc (y);
1269 end;
1270 y := 0;
1271 while y < H do
1272 begin
1273 grid[y * W + x + FW - 1] := 1;
1274 y := y + 2;
1275 end;
1276 x := x + FW;
1277 end;
1278 y := 0;
1279 while y < NR do
1280 begin
1281 x := 0;
1282 while x < NC do
1283 begin
1284 {INITCODE} v := places[(NR - y - 1) * NC + x];
1285 if IsTrue(IsTrue(v = 1) OR IsTrue((IsTrue(v > 7) AND IsTrue((binary[(v shr 3) - 1] and (1 shl (v and 7))))))) then
1286 begin
1287 grid[(1 + y + 2 * (y div (FH - 2))) * W + 1 + x + 2 * (x div (FW - 2))] := 1;
1288 end;
1289 Inc (x);
1290 end;
1291 Inc (y);
1292 end;
1293 y := H - 1;
1294 while y >= 0 do
1295 begin
1296 x := 0;
1297 while x < W do
1298 begin
1299 if IsTrue(grid[W * y + x]) then
1300 begin
1301 set_module (symbol, (H - y) - 1, x);
1302 end;
1303 Inc (x);
1304 end;
1305 symbol^.row_height[(H - y) - 1] := 1;
1306 Dec (y);
1307 end;
1308 FreeMem (grid);
1309 FreeMem (places);
1310 symbol^.rows := H;
1311 symbol^.width := W;
1312 exit (error_number);
1313end;
1314
1315function dmatrix(symbol: PointerTo_zint_symbol; source: PBYTE; length: Integer): Integer;
1316var
1317 error_number: Integer;
1318begin
1319 if IsTrue(symbol^.option_1 <= 1) then
1320 begin
1321 error_number := data_matrix_200 (symbol, source, length);
1322 end else begin
1323 strcpy (symbol^.errtxt, 'Older Data Matrix standards are no longer supported');
1324 error_number := ERROR_INVALID_OPTION;
1325 end;
1326 exit (error_number);
1327end;
1328
1329end.
1330
Note: See TracBrowser for help on using the repository browser.