pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity
Files
63d7776f8ccdaa0ae93c7b23c58eecaf44ab0624
lazarus-ccr/components/lazbarcodes/src/udatamatrix.pas
Joshy 1dae858558 First commit. Tested on Windows only. It provides 5 controls under the "Laz Barcodes 2D" tab. 
* QR code
* MicroQR
* Aztec
* Aztec Rune
* DataMatrix

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1758 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2011-07-22 18:48:22 +00:00

1330 lines
36 KiB
ObjectPascal
Raw Blame History

unit udatamatrix;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,uhelper,ureedsolomon,zint;
const
MAXBARCODE=3116;
function dmatrix(symbol: PointerTo_zint_symbol; source: PBYTE; length: Integer): Integer;
implementation
const
DM_ASCII =1;
DM_C40 =2;
DM_TEXT =3;
DM_X12 =4;
DM_EDIFACT=5;
DM_BASE256=6;
c40_shift: array [0..127] of integer = (
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,
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,
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,
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
);
c40_value: array [0..127] of integer = (
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,
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,
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,
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
);
text_shift: array [0..127] of integer = (
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,
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,
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,
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
);
text_value: array [0..127] of integer = (
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,
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,
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,
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
);
intsymbol: array [0..29] of integer = (
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
);
matrixH: array [0..29] of integer = (
10, 12, 8, 14, 8, 16, 12, 18, 20, 12, 22, 16, 24, 26, 16, 32, 36, 40, 44, 48,
52, 64, 72, 80, 88, 96, 104, 120, 132, 144
);
matrixW: array [0..29] of integer = (
10, 12, 18, 14, 32, 16, 26, 18, 20, 36, 22, 36, 24, 26, 48, 32, 36, 40, 44,
48, 52, 64, 72, 80, 88, 96, 104, 120, 132, 144
);
matrixFH: array [0..29] of integer = (
10, 12, 8, 14, 8, 16, 12, 18, 20, 12, 22, 16, 24, 26, 16, 16, 18, 20, 22, 24,
26, 16, 18, 20, 22, 24, 26, 20, 22, 24
);
matrixFW: array [0..29] of integer = (
10, 12, 18, 14, 16, 16, 26, 18, 20, 18, 22, 18, 24, 26, 24, 16, 18, 20, 22,
24, 26, 16, 18, 20, 22, 24, 26, 20, 22, 24
);
matrixbytes: array [0..29] of integer = (
3, 5, 5, 8, 10, 12, 16, 18, 22, 22, 30, 32, 36, 44, 49, 62, 86, 114, 144,
174, 204, 280, 368, 456, 576, 696, 816, 1050, 1304, 1558
);
matrixdatablock: array [0..29] of integer = (
3, 5, 5, 8, 10, 12, 16, 18, 22, 22, 30, 32, 36, 44, 49, 62, 86, 114, 144,
174, 102, 140, 92, 114, 144, 174, 136, 175, 163, 156
);
matrixrsblock: array [0..29] of integer = (
5, 7, 7, 10, 11, 12, 14, 14, 18, 18, 20, 24, 24, 28, 28, 36, 42, 48, 56, 68,
42, 56, 36, 48, 56, 68, 56, 68, 62, 62
);
procedure ecc200placementbit(parray: PInteger; NR: Integer; NC: Integer; r: Integer; c: Integer; p: Integer; b: BYTE);
begin
if IsTrue(r < 0) then
begin
r := r + NR;
c := c + (4 - ((NR + 4) mod 8));
end;
if IsTrue(c < 0) then
begin
c := c + NC;
r := r + (4 - ((NC + 4) mod 8));
end;
parray[r * NC + c] := (p shl 3) + b;
end;
procedure ecc200placementblock(parray: PInteger; NR: Integer; NC: Integer; r: Integer; c: Integer; p: Integer);
begin
ecc200placementbit (parray, NR, NC, r - 2, c - 2, p, 7);
ecc200placementbit (parray, NR, NC, r - 2, c - 1, p, 6);
ecc200placementbit (parray, NR, NC, r - 1, c - 2, p, 5);
ecc200placementbit (parray, NR, NC, r - 1, c - 1, p, 4);
ecc200placementbit (parray, NR, NC, r - 1, c - 0, p, 3);
ecc200placementbit (parray, NR, NC, r - 0, c - 2, p, 2);
ecc200placementbit (parray, NR, NC, r - 0, c - 1, p, 1);
ecc200placementbit (parray, NR, NC, r - 0, c - 0, p, 0);
end;
procedure ecc200placementcornerA(parray: PInteger; NR: Integer; NC: Integer; p: Integer);
begin
ecc200placementbit (parray, NR, NC, NR - 1, 0, p, 7);
ecc200placementbit (parray, NR, NC, NR - 1, 1, p, 6);
ecc200placementbit (parray, NR, NC, NR - 1, 2, p, 5);
ecc200placementbit (parray, NR, NC, 0, NC - 2, p, 4);
ecc200placementbit (parray, NR, NC, 0, NC - 1, p, 3);
ecc200placementbit (parray, NR, NC, 1, NC - 1, p, 2);
ecc200placementbit (parray, NR, NC, 2, NC - 1, p, 1);
ecc200placementbit (parray, NR, NC, 3, NC - 1, p, 0);
end;
procedure ecc200placementcornerB(parray: PInteger; NR: Integer; NC: Integer; p: Integer);
begin
ecc200placementbit (parray, NR, NC, NR - 3, 0, p, 7);
ecc200placementbit (parray, NR, NC, NR - 2, 0, p, 6);
ecc200placementbit (parray, NR, NC, NR - 1, 0, p, 5);
ecc200placementbit (parray, NR, NC, 0, NC - 4, p, 4);
ecc200placementbit (parray, NR, NC, 0, NC - 3, p, 3);
ecc200placementbit (parray, NR, NC, 0, NC - 2, p, 2);
ecc200placementbit (parray, NR, NC, 0, NC - 1, p, 1);
ecc200placementbit (parray, NR, NC, 1, NC - 1, p, 0);
end;
procedure ecc200placementcornerC(parray: PInteger; NR: Integer; NC: Integer; p: Integer);
begin
ecc200placementbit (parray, NR, NC, NR - 3, 0, p, 7);
ecc200placementbit (parray, NR, NC, NR - 2, 0, p, 6);
ecc200placementbit (parray, NR, NC, NR - 1, 0, p, 5);
ecc200placementbit (parray, NR, NC, 0, NC - 2, p, 4);
ecc200placementbit (parray, NR, NC, 0, NC - 1, p, 3);
ecc200placementbit (parray, NR, NC, 1, NC - 1, p, 2);
ecc200placementbit (parray, NR, NC, 2, NC - 1, p, 1);
ecc200placementbit (parray, NR, NC, 3, NC - 1, p, 0);
end;
procedure ecc200placementcornerD(parray: PInteger; NR: Integer; NC: Integer; p: Integer);
begin
ecc200placementbit (parray, NR, NC, NR - 1, 0, p, 7);
ecc200placementbit (parray, NR, NC, NR - 1, NC - 1, p, 6);
ecc200placementbit (parray, NR, NC, 0, NC - 3, p, 5);
ecc200placementbit (parray, NR, NC, 0, NC - 2, p, 4);
ecc200placementbit (parray, NR, NC, 0, NC - 1, p, 3);
ecc200placementbit (parray, NR, NC, 1, NC - 3, p, 2);
ecc200placementbit (parray, NR, NC, 1, NC - 2, p, 1);
ecc200placementbit (parray, NR, NC, 1, NC - 1, p, 0);
end;
procedure ecc200placement(parray: PInteger; NR: Integer; NC: Integer);
var
p: Integer;
c: Integer;
r: Integer;
begin
r := 0;
while r < NR do
begin
c := 0;
while c < NC do
begin
parray[r * NC + c] := 0;
Inc (c);
end;
Inc (r);
end;
p := 1;
r := 4;
c := 0;
repeat
if IsTrue(IsTrue(r = NR) AND IsTrue(BooleanNot (c))) then
begin
ecc200placementcornerA (parray, NR, NC, PostInc (p));
end;
if IsTrue(IsTrue(IsTrue(r = NR - 2) AND IsTrue(BooleanNot (c))) AND IsTrue(NC mod 4)) then
begin
ecc200placementcornerB (parray, NR, NC, PostInc (p));
end;
if IsTrue(IsTrue(IsTrue(r = NR - 2) AND IsTrue(BooleanNot (c))) AND IsTrue((NC mod 8) = 4)) then
begin
ecc200placementcornerC (parray, NR, NC, PostInc (p));
end;
if IsTrue(IsTrue(IsTrue(r = NR + 4) AND IsTrue(c = 2)) AND IsTrue(BooleanNot ((NC mod 8)))) then
begin
ecc200placementcornerD (parray, NR, NC, PostInc (p));
end;
repeat
if IsTrue(IsTrue(IsTrue(r < NR) AND IsTrue(c >= 0)) AND IsTrue(BooleanNot (parray[r * NC + c]))) then
begin
ecc200placementblock (parray, NR, NC, r, c, PostInc (p));
end;
r := r - 2;
c := c + 2;
until not (IsTrue(r >= 0) AND IsTrue(c < NC));
Inc (r);
c := c + 3;
repeat
if IsTrue(IsTrue(IsTrue(r >= 0) AND IsTrue(c < NC)) AND IsTrue(BooleanNot (parray[r * NC + c]))) then
begin
ecc200placementblock (parray, NR, NC, r, c, PostInc (p));
end;
r := r + 2;
c := c - 2;
until not (IsTrue(r < NR) AND IsTrue(c >= 0));
r := r + 3;
Inc (c);
until not (IsTrue(r < NR) OR IsTrue(c < NC));
if IsTrue(BooleanNot (parray[NR * NC - 1])) then
begin
parray[NR * NC - NC - 2] := 1;
parray[NR * NC - 1] := 1;
end;
end;
procedure ecc200(binary: PBYTE; bytes: Integer; datablock: Integer; rsblock: Integer; skew: Integer);
var
b: Integer;
blocks: Integer;
p: Integer;
n: Integer;
ecc: array [0..256-1] of BYTE;
buf: array [0..256-1] of BYTE;
begin
{INITCODE} blocks := (bytes + 2) div datablock;
rs_init_gf ($12D);
rs_init_code (rsblock, 1);
b := 0;
while b < blocks do
begin
p := 0;
n := b;
while n < bytes do
begin
buf[PostInc (p)] := binary[n];
n := n + blocks;
end;
rs_encode (p, buf, ecc);
p := rsblock - 1;
n := b;
while n < rsblock * blocks do
begin
if IsTrue(skew) then
begin
if IsTrue(b < 8) then
begin
binary[bytes + n + 2] := ecc[PostDec (p)];
end else begin
binary[bytes + n - 8] := ecc[PostDec (p)];
end;
end else begin
binary[bytes + n] := ecc[PostDec (p)];
end;
n := n + blocks;
end;
Inc (b);
end;
rs_free;
end;
function isx12(source: BYTE): Integer;
begin
if IsTrue(source = 13) then
begin
exit (1);
end;
if IsTrue(source = 42) then
begin
exit (1);
end;
if IsTrue(source = 62) then
begin
exit (1);
end;
if IsTrue(source = 32) then
begin
exit (1);
end;
if IsTrue(IsTrue((source >= BYTE('0'))) AND IsTrue((source <= BYTE('9')))) then
begin
exit (1);
end;
if IsTrue(IsTrue((source >= BYTE('A'))) AND IsTrue((source <= BYTE('Z')))) then
begin
exit (1);
end;
exit (0);
end;
procedure dminsert(binary_string: PChar; posn: Integer; newbit: Char);
var
lend: Integer;
i: Integer;
begin
lend := sysutils.strlen (binary_string);
i := lend;
while i > posn do
begin
binary_string[i] := binary_string[i - 1];
Dec (i);
end;
binary_string[posn] := newbit;
end;
procedure insert_value(binary_stream: PBYTE; posn: Integer; streamlen: Integer; newbit: BYTE);
var
i: Integer;
begin
i := streamlen;
while i > posn do
begin
binary_stream[i] := binary_stream[i - 1];
Dec (i);
end;
binary_stream[posn] := newbit;
end;
function look_ahead_test(source: PBYTE; sourcelen: Integer; position: Integer; current_mode: Integer; gs1: Integer): Integer;
var
best_count: Single;
b256_count: Single;
edf_count: Single;
x12_count: Single;
text_count: Single;
c40_count: Single;
ascii_count: Single;
best_scheme: Integer;
done: Integer;
sp: Integer;
reduced_char: Char;
begin
if IsTrue(current_mode = DM_ASCII) then
begin
ascii_count := 0.0;
c40_count := 1.0;
text_count := 1.0;
x12_count := 1.0;
edf_count := 1.0;
b256_count := 1.25;
end else begin
ascii_count := 1.0;
c40_count := 2.0;
text_count := 2.0;
x12_count := 2.0;
edf_count := 2.0;
b256_count := 2.25;
end;
case current_mode of
DM_C40: c40_count := 0.0;
DM_TEXT: text_count := 0.0;
DM_X12: x12_count := 0.0;
DM_EDIFACT: edf_count := 0.0;
DM_BASE256: b256_count := 0.0;
end;
sp := position;
while IsTrue((sp < sourcelen)) AND IsTrue((sp <= (position + 8))) do
begin
if IsTrue(source[sp] <= 127) then
begin
reduced_char := char(source[sp]);
end else begin
reduced_char := char(source[sp] - 127);
end;
if IsTrue(IsTrue((source[sp] >= BYTE('0'))) AND IsTrue((source[sp] <= BYTE('9')))) then
begin
ascii_count := ascii_count + 0.5;
end else begin
ascii_count := ascii_count + 1.0;
end;
if IsTrue(source[sp] > 127) then
begin
ascii_count := ascii_count + 1.0;
end;
done := 0;
if IsTrue(reduced_char = ' ') then
begin
c40_count := c40_count + ((2.0 / 3.0));
done := 1;
end;
if IsTrue(IsTrue((reduced_char >= '0')) AND IsTrue((reduced_char <= '9'))) then
begin
c40_count := c40_count + ((2.0 / 3.0));
done := 1;
end;
if IsTrue(IsTrue((reduced_char >= 'A')) AND IsTrue((reduced_char <= 'Z'))) then
begin
c40_count := c40_count + ((2.0 / 3.0));
done := 1;
end;
if IsTrue(source[sp] > 127) then
begin
c40_count := c40_count + ((4.0 / 3.0));
end;
if IsTrue(done = 0) then
begin
c40_count := c40_count + ((4.0 / 3.0));
end;
done := 0;
if IsTrue(reduced_char = ' ') then
begin
text_count := text_count + ((2.0 / 3.0));
done := 1;
end;
if IsTrue(IsTrue((reduced_char >= '0')) AND IsTrue((reduced_char <= '9'))) then
begin
text_count := text_count + ((2.0 / 3.0));
done := 1;
end;
if IsTrue(IsTrue((reduced_char >= 'a')) AND IsTrue((reduced_char <= 'z'))) then
begin
text_count := text_count + ((2.0 / 3.0));
done := 1;
end;
if IsTrue(source[sp] > 127) then
begin
text_count := text_count + ((4.0 / 3.0));
end;
if IsTrue(done = 0) then
begin
text_count := text_count + ((4.0 / 3.0));
end;
if IsTrue(isx12 (source[sp])) then
begin
x12_count := x12_count + ((2.0 / 3.0));
end else begin
x12_count := x12_count + 4.0;
end;
done := 0;
if IsTrue(IsTrue((source[sp] >= BYTE(' '))) AND IsTrue((source[sp] <= BYTE('^')))) then
begin
edf_count := edf_count + ((3.0 / 4.0));
end else begin
edf_count := edf_count + 6.0;
end;
if IsTrue(IsTrue(gs1) AND IsTrue((source[sp] = BYTE('[')))) then
begin
edf_count := edf_count + 6.0;
end;
if IsTrue(sp >= (sourcelen - 5)) then
begin
edf_count := edf_count + 6.0;
end;
if IsTrue(IsTrue(gs1) AND IsTrue((source[sp] = BYTE('[')))) then
begin
b256_count := b256_count + 4.0;
end else begin
b256_count := b256_count + 1.0;
end;
Inc (sp);
end;
best_count := ascii_count;
best_scheme := DM_ASCII;
if IsTrue(b256_count <= best_count) then
begin
best_count := b256_count;
best_scheme := DM_BASE256;
end;
if IsTrue(edf_count <= best_count) then
begin
best_count := edf_count;
best_scheme := DM_EDIFACT;
end;
if IsTrue(text_count <= best_count) then
begin
best_count := text_count;
best_scheme := DM_TEXT;
end;
if IsTrue(x12_count <= best_count) then
begin
best_count := x12_count;
best_scheme := DM_X12;
end;
if IsTrue(c40_count <= best_count) then
begin
best_count := c40_count;
best_scheme := DM_C40;
end;
exit (best_scheme);
end;
function dm200encode(symbol: PointerTo_zint_symbol; source: PBYTE; target: PBYTE; last_mode: PInteger; length: Integer): Integer;
var
gs1: Integer;
i: Integer;
tp: Integer;
sp: Integer;
next_mode: Integer;
current_mode: Integer;
inputlen: Integer;
c40_p: Integer;
c40_buffer: array [0..6-1] of Integer;
text_p: Integer;
text_buffer: array [0..6-1] of Integer;
x12_p: Integer;
x12_buffer: array [0..6-1] of Integer;
edifact_p: Integer;
edifact_buffer: array [0..8-1] of Integer;
debug: Integer = 0;
binary: array of Char;
value: Integer;
shift_set: Integer;
iv: Integer;
binary_count: Integer;
temp: Integer;
prn: Integer;
begin
{INITCODE} inputlen := length;
{INITCODE} debug := 0;
SetLength(binary,2 * inputlen-1);
sp := 0;
tp := 0;
memset (@c40_buffer[0], 0, 6);
c40_p := 0;
memset (@text_buffer[0], 0, 6);
text_p := 0;
memset (@x12_buffer[0], 0, 6);
x12_p := 0;
memset (@edifact_buffer[0], 0, 8);
edifact_p := 0;
strcpy (binary, '');
current_mode := DM_ASCII;
next_mode := DM_ASCII;
if IsTrue(symbol^.input_mode = GS1_MODE) then
begin
gs1 := 1;
end else begin
gs1 := 0;
end;
if IsTrue(gs1) then
begin
target[tp] := 232;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('FN1 ',[]) );
end;
end;
if IsTrue(symbol^.output_options and READER_INIT) then
begin
if IsTrue(gs1) then
begin
strcpy (symbol^.errtxt, 'Cannot encode in GS1 mode and Reader Initialisation at the same time');
exit (ERROR_INVALID_OPTION);
end else begin
target[tp] := 234;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('RP ',[]) );
end;
end;
end;
while sp < inputlen do
begin
current_mode := next_mode;
if IsTrue(current_mode = DM_ASCII) then
begin
next_mode := DM_ASCII;
if IsTrue(IsTrue(istwodigits (source, sp)) AND IsTrue(((sp + 1) <> inputlen))) then
begin
target[tp] := (10 * ctoi (source[sp])) + ctoi (source[sp + 1]) + 130;
if IsTrue(debug) then
begin
write( format ('N%d ',[target[tp] - 130]) );
end;
Inc (tp);
concat (binary, ' ');
sp := sp + 2;
end else begin
next_mode := look_ahead_test (source, inputlen, sp, current_mode, gs1);
if IsTrue(next_mode <> DM_ASCII) then
begin
case next_mode of
DM_C40:
begin
target[tp] := 230;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('C40 ',[]) );
end;
end;
DM_TEXT:
begin
target[tp] := 239;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('TEX ',[]) );
end;
end;
DM_X12:
begin
target[tp] := 238;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('X12 ',[]) );
end;
end;
DM_EDIFACT:
begin
target[tp] := 240;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('EDI ',[]) );
end;
end;
DM_BASE256:
begin
target[tp] := 231;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('BAS ',[]) );
end;
end;
end;
end else begin
if IsTrue(source[sp] > 127) then
begin
target[tp] := 235;
if IsTrue(debug) then
begin
write( format ('FN4 ',[]) );
end;
Inc (tp);
target[tp] := (source[sp] - 128) + 1;
if IsTrue(debug) then
begin
write( format ('A%02X ',[target[tp] - 1]) );
end;
Inc (tp);
concat (binary, ' ');
end else begin
if IsTrue(IsTrue(gs1) AND IsTrue((source[sp] = BYTE('[')))) then
begin
target[tp] := 232;
if IsTrue(debug) then
begin
write( format ('FN1 ',[]) );
end;
end else begin
target[tp] := source[sp] + 1;
if IsTrue(debug) then
begin
write( format ('A%02X ',[target[tp] - 1]) );
end;
end;
Inc (tp);
concat (binary, ' ');
end;
Inc (sp);
end;
end;
end;
if IsTrue(current_mode = DM_C40) then
begin
next_mode := DM_C40;
if IsTrue(c40_p = 0) then
begin
next_mode := look_ahead_test (source, inputlen, sp, current_mode, gs1);
end;
if IsTrue(next_mode <> DM_C40) then
begin
target[tp] := 254;
Inc (tp);
concat (binary, ' ');
next_mode := DM_ASCII;
if IsTrue(debug) then
begin
write( format ('ASC ',[]) );
end;
end else begin
if IsTrue(source[sp] > 127) then
begin
c40_buffer[c40_p] := 1;
Inc (c40_p);
c40_buffer[c40_p] := 30;
Inc (c40_p);
shift_set := c40_shift[source[sp] - 128];
value := c40_value[source[sp] - 128];
end else begin
shift_set := c40_shift[source[sp]];
value := c40_value[source[sp]];
end;
if IsTrue(IsTrue(gs1) AND IsTrue((source[sp] = BYTE('[')))) then
begin
shift_set := 2;
value := 27;
end;
if IsTrue(shift_set <> 0) then
begin
c40_buffer[c40_p] := shift_set - 1;
Inc (c40_p);
end;
c40_buffer[c40_p] := value;
Inc (c40_p);
if IsTrue(c40_p >= 3) then
begin
iv := (1600 * c40_buffer[0]) + (40 * c40_buffer[1]) + (c40_buffer[2]) + 1;
target[tp] := iv div 256;
Inc (tp);
target[tp] := iv mod 256;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('[%d %d %d] ',[c40_buffer[0], c40_buffer[1], c40_buffer[2]]) );
end;
c40_buffer[0] := c40_buffer[3];
c40_buffer[1] := c40_buffer[4];
c40_buffer[2] := c40_buffer[5];
c40_buffer[3] := 0;
c40_buffer[4] := 0;
c40_buffer[5] := 0;
c40_p := c40_p - 3;
end;
Inc (sp);
end;
end;
if IsTrue(current_mode = DM_TEXT) then
begin
next_mode := DM_TEXT;
if IsTrue(text_p = 0) then
begin
next_mode := look_ahead_test (source, inputlen, sp, current_mode, gs1);
end;
if IsTrue(next_mode <> DM_TEXT) then
begin
target[tp] := 254;
Inc (tp);
concat (binary, ' ');
next_mode := DM_ASCII;
if IsTrue(debug) then
begin
write( format ('ASC ',[]) );
end;
end else begin
if IsTrue(source[sp] > 127) then
begin
text_buffer[text_p] := 1;
Inc (text_p);
text_buffer[text_p] := 30;
Inc (text_p);
shift_set := text_shift[source[sp] - 128];
value := text_value[source[sp] - 128];
end else begin
shift_set := text_shift[source[sp]];
value := text_value[source[sp]];
end;
if IsTrue(IsTrue(gs1) AND IsTrue((source[sp] = BYTE('[')))) then
begin
shift_set := 2;
value := 27;
end;
if IsTrue(shift_set <> 0) then
begin
text_buffer[text_p] := shift_set - 1;
Inc (text_p);
end;
text_buffer[text_p] := value;
Inc (text_p);
if IsTrue(text_p >= 3) then
begin
iv := (1600 * text_buffer[0]) + (40 * text_buffer[1]) + (text_buffer[2]) + 1;
target[tp] := iv div 256;
Inc (tp);
target[tp] := iv mod 256;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('[%d %d %d] ',[text_buffer[0], text_buffer[1], text_buffer[2]]) );
end;
text_buffer[0] := text_buffer[3];
text_buffer[1] := text_buffer[4];
text_buffer[2] := text_buffer[5];
text_buffer[3] := 0;
text_buffer[4] := 0;
text_buffer[5] := 0;
text_p := text_p - 3;
end;
Inc (sp);
end;
end;
if IsTrue(current_mode = DM_X12) then
begin
{INITCODE} value := 0;
next_mode := DM_X12;
if IsTrue(text_p = 0) then
begin
next_mode := look_ahead_test (source, inputlen, sp, current_mode, gs1);
end;
if IsTrue(next_mode <> DM_X12) then
begin
target[tp] := 254;
Inc (tp);
concat (binary, ' ');
next_mode := DM_ASCII;
if IsTrue(debug) then
begin
write( format ('ASC ',[]) );
end;
end else begin
if IsTrue(source[sp] = 13) then
begin
value := 0;
end;
if IsTrue(source[sp] = BYTE('*')) then
begin
value := 1;
end;
if IsTrue(source[sp] = BYTE('>')) then
begin
value := 2;
end;
if IsTrue(source[sp] = BYTE(' ')) then
begin
value := 3;
end;
if IsTrue(IsTrue((source[sp] >= BYTE('0'))) AND IsTrue((source[sp] <= BYTE('9')))) then
begin
value := (source[sp] - BYTE('0')) + 4;
end;
if IsTrue(IsTrue((source[sp] >= BYTE('A'))) AND IsTrue((source[sp] <= BYTE('Z')))) then
begin
value := (source[sp] - BYTE('A')) + 14;
end;
x12_buffer[x12_p] := value;
Inc (x12_p);
if IsTrue(x12_p >= 3) then
begin
iv := (1600 * x12_buffer[0]) + (40 * x12_buffer[1]) + (x12_buffer[2]) + 1;
target[tp] := iv div 256;
Inc (tp);
target[tp] := iv mod 256;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('[%d %d %d] ',[x12_buffer[0], x12_buffer[1], x12_buffer[2]]) );
end;
x12_buffer[0] := x12_buffer[3];
x12_buffer[1] := x12_buffer[4];
x12_buffer[2] := x12_buffer[5];
x12_buffer[3] := 0;
x12_buffer[4] := 0;
x12_buffer[5] := 0;
x12_p := x12_p - 3;
end;
Inc (sp);
end;
end;
if IsTrue(current_mode = DM_EDIFACT) then
begin
{INITCODE} value := 0;
next_mode := DM_EDIFACT;
if IsTrue(edifact_p = 3) then
begin
next_mode := look_ahead_test (source, inputlen, sp, current_mode, gs1);
end;
if IsTrue(next_mode <> DM_EDIFACT) then
begin
edifact_buffer[edifact_p] := 31;
Inc (edifact_p);
next_mode := DM_ASCII;
end else begin
if IsTrue(IsTrue((source[sp] >= BYTE('@'))) AND IsTrue((source[sp] <= BYTE('^')))) then
begin
value := source[sp] - BYTE('@');
end;
if IsTrue(IsTrue((source[sp] >= BYTE(' '))) AND IsTrue((source[sp] <= BYTE('?')))) then
begin
value := source[sp];
end;
edifact_buffer[edifact_p] := value;
Inc (edifact_p);
Inc (sp);
end;
if IsTrue(edifact_p >= 4) then
begin
target[tp] := (edifact_buffer[0] shl 2) + ((edifact_buffer[1] and $30) shr 4);
Inc (tp);
target[tp] := ((edifact_buffer[1] and $0F) shl 4) + ((edifact_buffer[2] and $3C) shr 2);
Inc (tp);
target[tp] := ((edifact_buffer[2] and $03) shl 6) + edifact_buffer[3];
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('[%d %d %d %d] ',[edifact_buffer[0], edifact_buffer[1], edifact_buffer[2], edifact_buffer[3]]) );
end;
edifact_buffer[0] := edifact_buffer[4];
edifact_buffer[1] := edifact_buffer[5];
edifact_buffer[2] := edifact_buffer[6];
edifact_buffer[3] := edifact_buffer[7];
edifact_buffer[4] := 0;
edifact_buffer[5] := 0;
edifact_buffer[6] := 0;
edifact_buffer[7] := 0;
edifact_p := edifact_p - 4;
end;
end;
if IsTrue(current_mode = DM_BASE256) then
begin
next_mode := look_ahead_test (source, inputlen, sp, current_mode, gs1);
if IsTrue(next_mode = DM_BASE256) then
begin
target[tp] := source[sp];
if IsTrue(debug) then
begin
write( format ('B%02X ',[target[tp]]) );
end;
Inc (tp);
Inc (sp);
concat (binary, 'b');
end else begin
next_mode := DM_ASCII;
if IsTrue(debug) then
begin
write( format ('ASC ',[]) );
end;
end;
end;
if IsTrue(tp > 1558) then
begin
exit (0);
end;
end;
if IsTrue(c40_p = 2) then
begin
target[tp] := 254;
Inc (tp);
target[tp] := source[inputlen - 2] + 1;
Inc (tp);
target[tp] := source[inputlen - 1] + 1;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('ASC A%02X A%02X ',[target[tp - 2] - 1, target[tp - 1] - 1]) );
end;
current_mode := DM_ASCII;
end;
if IsTrue(c40_p = 1) then
begin
target[tp] := 254;
Inc (tp);
target[tp] := source[inputlen - 1] + 1;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('ASC A%02X ',[target[tp - 1] - 1]) );
end;
current_mode := DM_ASCII;
end;
if IsTrue(text_p = 2) then
begin
target[tp] := 254;
Inc (tp);
target[tp] := source[inputlen - 2] + 1;
Inc (tp);
target[tp] := source[inputlen - 1] + 1;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('ASC A%02X A%02X ',[target[tp - 2] - 1, target[tp - 1] - 1]) );
end;
current_mode := DM_ASCII;
end;
if IsTrue(text_p = 1) then
begin
target[tp] := 254;
Inc (tp);
target[tp] := source[inputlen - 1] + 1;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('ASC A%02X ',[target[tp - 1] - 1]) );
end;
current_mode := DM_ASCII;
end;
if IsTrue(x12_p = 2) then
begin
target[tp] := 254;
Inc (tp);
target[tp] := source[inputlen - 2] + 1;
Inc (tp);
target[tp] := source[inputlen - 1] + 1;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('ASC A%02X A%02X ',[target[tp - 2] - 1, target[tp - 1] - 1]) );
end;
current_mode := DM_ASCII;
end;
if IsTrue(x12_p = 1) then
begin
target[tp] := 254;
Inc (tp);
target[tp] := source[inputlen - 1] + 1;
Inc (tp);
concat (binary, ' ');
if IsTrue(debug) then
begin
write( format ('ASC A%02X ',[target[tp - 1] - 1]) );
end;
current_mode := DM_ASCII;
end;
i := 0;
while i < tp do
begin
if IsTrue(binary[i] = 'b') then
begin
if IsTrue(IsTrue((i = 0)) OR IsTrue((IsTrue((i <> 0)) AND IsTrue((binary[i - 1] <> 'b'))))) then
begin
binary_count := 0;
while binary[binary_count + i] = 'b' do
begin
Inc (binary_count);
end;
if IsTrue(binary_count <= 249) then
begin
dminsert (@binary[0], i, 'b');
insert_value (target, i, tp, binary_count);
Inc (tp);
end else begin
dminsert (@binary[0], i, 'b');
dminsert (@binary[0], i + 1, 'b');
insert_value (target, i, tp, (binary_count div 250) + 249);
Inc (tp);
insert_value (target, i + 1, tp, binary_count mod 250);
Inc (tp);
end;
end;
end;
Inc (i);
end;
i := 0;
while i < tp do
begin
if IsTrue(binary[i] = 'b') then
begin
prn := ((149 * (i + 1)) mod 255) + 1;
temp := target[i] + prn;
if IsTrue(temp <= 255) then
begin
target[i] := temp;
end else begin
target[i] := temp - 256;
end;
end;
Inc (i);
end;
if IsTrue(debug) then
begin
write( format ('\n\n',[]) );
i := 0;
while i < tp do
begin
write( format ('%02X ',[target[i]]) );
Inc (i);
end;
write( format ('\n',[]) );
end;
(last_mode)^ := current_mode;
exit (tp);
end;
procedure add_tail(target: PBYTE; tp: Integer; tail_length: Integer; last_mode: Integer);
var
temp: Integer;
prn: Integer;
i: Integer;
begin
case last_mode of
DM_C40,
DM_TEXT,
DM_X12:
begin
target[tp] := 254;
Inc (tp);
Dec (tail_length);
end;
{>WARNING< code without ending break}
end;
i := tail_length;
while i > 0 do
begin
if IsTrue(i = tail_length) then
begin
target[tp] := 129;
Inc (tp);
end else begin
prn := ((149 * (tp + 1)) mod 253) + 1;
temp := 129 + prn;
if IsTrue(temp <= 254) then
begin
target[tp] := temp;
Inc (tp);
end else begin
target[tp] := temp - 254;
Inc (tp);
end;
end;
Dec (i);
end;
end;
function data_matrix_200(symbol: PointerTo_zint_symbol; source: PBYTE; length: Integer): Integer;
var
skew: Integer = 0;
i: Integer = 0;
//inputlen: Integer = 0;
binary: array [0..2200-1] of BYTE;
binlen: Integer;
calcsize: Integer;
optionsize: Integer;
symbolsize: Integer;
error_number: Integer = 0;
taillength: Integer = 0;
rsblock: Integer;
bytes: Integer;
datablock: Integer;
FW: Integer;
FH: Integer;
W: Integer;
H: Integer;
last_mode: Integer;
grid: PBYTE;
places: PInteger;
NR: Integer;
NC: Integer;
y: Integer;
x: Integer;
v: Integer;
begin
{INITCODE} skew := 0;
{INITCODE} i := 0;
//{INITCODE} inputlen := 0;
{INITCODE} error_number := 0;
{INITCODE} taillength := 0;
{INITCODE} grid := nil;
//inputlen := length;
binlen := dm200encode (symbol, source, binary, @last_mode, length);
if IsTrue(binlen = 0) then
begin
strcpy (symbol^.errtxt, 'Data too long to fit in symbol');
exit (ERROR_TOO_LONG);
end;
if IsTrue(IsTrue((symbol^.option_2 >= 1)) AND IsTrue((symbol^.option_2 <= 30))) then
begin
optionsize := intsymbol[symbol^.option_2 - 1];
end else begin
optionsize := -1;
end;
calcsize := 29;
i := 29;
while i > -1 do
begin
if IsTrue(matrixbytes[i] >= binlen) then
begin
calcsize := i;
end;
Dec (i);
end;
if IsTrue(symbol^.option_3 = DM_SQUARE) then
begin
case calcsize of
2,
4,
6,
9,
11,
14: Inc (calcsize);
{>WARNING< code without ending break}
end;
end;
symbolsize := optionsize;
if IsTrue(calcsize > optionsize) then
begin
symbolsize := calcsize;
if IsTrue(optionsize <> -1) then
begin
error_number := WARN_INVALID_OPTION;
strcpy (symbol^.errtxt, 'Data does not fit in selected symbol size');
end;
end;
H := matrixH[symbolsize];
W := matrixW[symbolsize];
FH := matrixFH[symbolsize];
FW := matrixFW[symbolsize];
bytes := matrixbytes[symbolsize];
datablock := matrixdatablock[symbolsize];
rsblock := matrixrsblock[symbolsize];
taillength := bytes - binlen;
if IsTrue(taillength <> 0) then
begin
add_tail (binary, binlen, taillength, last_mode);
end;
if IsTrue(symbolsize = 29) then
begin
skew := 1;
end;
ecc200 (binary, bytes, datablock, rsblock, skew);
NC := W - 2 * (W div FW);
NR := H - 2 * (H div FH);
places := PInteger (GetMem (NC * NR * SizeOf (Integer)));
ecc200placement (places, NR, NC);
grid := PBYTE (GetMem (W * H));
memset (grid, 0, W * H);
y := 0;
while y < H do
begin
x := 0;
while x < W do
begin
grid[y * W + x] := 1;
Inc (x);
end;
x := 0;
while x < W do
begin
grid[(y + FH - 1) * W + x] := 1;
x := x + 2;
end;
y := y + FH;
end;
x := 0;
while x < W do
begin
y := 0;
while y < H do
begin
grid[y * W + x] := 1;
Inc (y);
end;
y := 0;
while y < H do
begin
grid[y * W + x + FW - 1] := 1;
y := y + 2;
end;
x := x + FW;
end;
y := 0;
while y < NR do
begin
x := 0;
while x < NC do
begin
{INITCODE} v := places[(NR - y - 1) * NC + x];
if IsTrue(IsTrue(v = 1) OR IsTrue((IsTrue(v > 7) AND IsTrue((binary[(v shr 3) - 1] and (1 shl (v and 7))))))) then
begin
grid[(1 + y + 2 * (y div (FH - 2))) * W + 1 + x + 2 * (x div (FW - 2))] := 1;
end;
Inc (x);
end;
Inc (y);
end;
y := H - 1;
while y >= 0 do
begin
x := 0;
while x < W do
begin
if IsTrue(grid[W * y + x]) then
begin
set_module (symbol, (H - y) - 1, x);
end;
Inc (x);
end;
symbol^.row_height[(H - y) - 1] := 1;
Dec (y);
end;
FreeMem (grid);
FreeMem (places);
symbol^.rows := H;
symbol^.width := W;
exit (error_number);
end;
function dmatrix(symbol: PointerTo_zint_symbol; source: PBYTE; length: Integer): Integer;
var
error_number: Integer;
begin
if IsTrue(symbol^.option_1 <= 1) then
begin
error_number := data_matrix_200 (symbol, source, length);
end else begin
strcpy (symbol^.errtxt, 'Older Data Matrix standards are no longer supported');
error_number := ERROR_INVALID_OPTION;
end;
exit (error_number);
end;
end.
Reference in New Issue View Git Blame Copy Permalink