Delphi/FastReport_2022_VCL
Delphi/FastReport_2022_VCL
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
master
FastReport_2022_VCL/Source/frxDelphiMaxiCode.pas

1142 lines
38 KiB
ObjectPascal
Raw Permalink Normal View History

Inicijalizacija
2024-01-01 16:13:08 +01:00
unit frxDelphiMaxiCode;
interface
{$I frx.inc}
uses
{$IFNDEF FPC}Windows,{$ENDIF} Graphics, SysUtils;
(* Copyright 2014-2015 Robin Stuart, Daniel Gredler
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implements MaxiCode according to ISO 16023:2000.
*
* MaxiCode employs a pattern of hexagons around a central 'bulls-eye'
* finder pattern. Encoding in several modes is supported, but encoding in
* Mode 2 and 3 require primary messages to be set. Input characters can be
* any from the ISO 8859-1 (Latin-1) character set.
*
* TODO: Add ECI functionality.
*
* @author <a href="mailto:rstuart114@gmail.com">Robin Stuart</a>
* @author Daniel Gredler
*)
type
TMaxicodeEncoder = class
private
FData: WideString;
FMode: Integer;
procedure SetData(const Value: WideString);
procedure SetMode(const Value: Integer);
function GetIsBlack(Row, Column: integer): Boolean;
protected
FBitmap: TBitmap;
procedure Update;
public
constructor Create;
destructor Destroy; override;
function Width: Integer;
function Height: Integer;
function GetScanLine(Column: Integer): PByteArray;
property IsBlack[Row, Column: integer]: Boolean read GetIsBlack;
property Data: WideString read FData write SetData;
property Mode: Integer read FMode write SetMode;
property Bitmap: TBitmap read FBitmap;
end;
implementation
uses
Math, Classes, Types, frxUnicodeUtils, frxClass, frxUtils;
const
INK_SPREAD = 0.9;
OFFSET_X: array[0..5] of Extended = (0.0, 0.866, 0.866, 0.0, -0.866, -0.866);
OFFSET_Y: array[0..5] of Extended = (1.0, 0.5, -0.5, -1.0, -0.5, 0.5);
type
TLongIntArray = array of LongInt;
TMaxiCodeImpl = class
private
FStructuredAppendPosition: LongInt;
FStructuredAppendTotal: LongInt;
FPrimaryData: AnsiString;
FHexagonCount: Integer;
procedure SetStructuredAppendPosition(const Value: Integer);
procedure SetStructuredAppendTotal(const Value: Integer);
function GetHexagonPoint(i, j: Integer): TfrxPoint;
function GetEllipceCount: Integer;
function GetEllipseRect(i: Integer): TfrxRect;
protected
FMode: Integer;
eciMode: LongInt;
FHexagonCenter: array[0..33 * 30] of TfrxPoint;
FEllipseRect: array[0..2] of TfrxRect;
codewords: TLongIntArray;
source: TLongIntArray;
sourcelen: Integer;
Fset: array[0..144-1] of LongInt;
character: array[0..144-1] of LongInt;
grid: array[0..33-1, 0..30-1] of Boolean;
function IsNumeral(str: AnsiString; i: Integer): Boolean;
function Substring(str: AnsiString; startIndex: Integer; len: Integer = -1): AnsiString;
function IndexOf(str, substr: AnsiString): integer;
function IntParse(str: AnsiString; startIndex: Integer = 0; len: Integer = -1): Integer;
function processText: Boolean;
function getPrimaryCodewords: TLongIntArray;
function getErrorCorrection(codewords: TLongIntArray; ecclen: Integer): TLongIntArray;
procedure plotSymbol;
function getMode2PrimaryCodewords(postcode: AnsiString; country, service: Integer): TLongIntArray;
function getMode3PrimaryCodewords(postcode: AnsiString; country, service: Integer): TLongIntArray;
function bestSurroundingSet(index, len: Integer; valid: array of Integer): Integer;
public
constructor Create;
function Encode(inputBytes: AnsiString; Mode: Integer): Boolean;
function HexagonCenter(Row, Col: Integer): TfrxPoint;
function HexagonPointByIndex(Center: TfrxPoint; Index: Integer): TfrxPoint;
property StructuredAppendPosition: LongInt read FStructuredAppendPosition write SetStructuredAppendPosition;
property StructuredAppendTotal: LongInt read FStructuredAppendTotal write SetStructuredAppendTotal;
property PrimaryData: AnsiString read FPrimaryData write FPrimaryData;
property HexagonCount: Integer read FHexagonCount;
property HexagonPoint[i, j: Integer]: TfrxPoint read GetHexagonPoint;
property EllipceCount: Integer read GetEllipceCount;
property EllipseRect[i: Integer]: TfrxRect read GetEllipseRect;
end;
TReedSolomon = class
private
logmod: LongInt;
rlen: LongInt;
logt: TLongIntArray;
alog: TLongIntArray;
rspoly: TLongIntArray;
public
res: TLongIntArray;
function getResult(count: LongInt): LongInt;
procedure init_gf(poly: LongInt);
procedure init_code(nsym, index: LongInt);
procedure encode(len: LongInt; data: TLongIntArray);
end;
const
//* MaxiCode module sequence, from ISO/IEC 16023 Figure 5 (30 x 33 data grid).
MAXICODE_GRID: array [0..990-1] of integer = (
122, 121, 128, 127, 134, 133, 140, 139, 146, 145, 152, 151, 158, 157, 164, 163, 170, 169, 176, 175, 182, 181, 188, 187, 194, 193, 200, 199, 0, 0,
124, 123, 130, 129, 136, 135, 142, 141, 148, 147, 154, 153, 160, 159, 166, 165, 172, 171, 178, 177, 184, 183, 190, 189, 196, 195, 202, 201, 817, 0,
126, 125, 132, 131, 138, 137, 144, 143, 150, 149, 156, 155, 162, 161, 168, 167, 174, 173, 180, 179, 186, 185, 192, 191, 198, 197, 204, 203, 819, 818,
284, 283, 278, 277, 272, 271, 266, 265, 260, 259, 254, 253, 248, 247, 242, 241, 236, 235, 230, 229, 224, 223, 218, 217, 212, 211, 206, 205, 820, 0,
286, 285, 280, 279, 274, 273, 268, 267, 262, 261, 256, 255, 250, 249, 244, 243, 238, 237, 232, 231, 226, 225, 220, 219, 214, 213, 208, 207, 822, 821,
288, 287, 282, 281, 276, 275, 270, 269, 264, 263, 258, 257, 252, 251, 246, 245, 240, 239, 234, 233, 228, 227, 222, 221, 216, 215, 210, 209, 823, 0,
290, 289, 296, 295, 302, 301, 308, 307, 314, 313, 320, 319, 326, 325, 332, 331, 338, 337, 344, 343, 350, 349, 356, 355, 362, 361, 368, 367, 825, 824,
292, 291, 298, 297, 304, 303, 310, 309, 316, 315, 322, 321, 328, 327, 334, 333, 340, 339, 346, 345, 352, 351, 358, 357, 364, 363, 370, 369, 826, 0,
294, 293, 300, 299, 306, 305, 312, 311, 318, 317, 324, 323, 330, 329, 336, 335, 342, 341, 348, 347, 354, 353, 360, 359, 366, 365, 372, 371, 828, 827,
410, 409, 404, 403, 398, 397, 392, 391, 80, 79, 0, 0, 14, 13, 38, 37, 3, 0, 45, 44, 110, 109, 386, 385, 380, 379, 374, 373, 829, 0,
412, 411, 406, 405, 400, 399, 394, 393, 82, 81, 41, 0, 16, 15, 40, 39, 4, 0, 0, 46, 112, 111, 388, 387, 382, 381, 376, 375, 831, 830,
414, 413, 408, 407, 402, 401, 396, 395, 84, 83, 42, 0, 0, 0, 0, 0, 6, 5, 48, 47, 114, 113, 390, 389, 384, 383, 378, 377, 832, 0,
416, 415, 422, 421, 428, 427, 104, 103, 56, 55, 17, 0, 0, 0, 0, 0, 0, 0, 21, 20, 86, 85, 434, 433, 440, 439, 446, 445, 834, 833,
418, 417, 424, 423, 430, 429, 106, 105, 58, 57, 0, 0, 0, 0, 0, 0, 0, 0, 23, 22, 88, 87, 436, 435, 442, 441, 448, 447, 835, 0,
420, 419, 426, 425, 432, 431, 108, 107, 60, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 24, 90, 89, 438, 437, 444, 443, 450, 449, 837, 836,
482, 481, 476, 475, 470, 469, 49, 0, 31, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 54, 53, 464, 463, 458, 457, 452, 451, 838, 0,
484, 483, 478, 477, 472, 471, 50, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 466, 465, 460, 459, 454, 453, 840, 839,
486, 485, 480, 479, 474, 473, 52, 51, 32, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 43, 468, 467, 462, 461, 456, 455, 841, 0,
488, 487, 494, 493, 500, 499, 98, 97, 62, 61, 0, 0, 0, 0, 0, 0, 0, 0, 0, 27, 92, 91, 506, 505, 512, 511, 518, 517, 843, 842,
490, 489, 496, 495, 502, 501, 100, 99, 64, 63, 0, 0, 0, 0, 0, 0, 0, 0, 29, 28, 94, 93, 508, 507, 514, 513, 520, 519, 844, 0,
492, 491, 498, 497, 504, 503, 102, 101, 66, 65, 18, 0, 0, 0, 0, 0, 0, 0, 19, 30, 96, 95, 510, 509, 516, 515, 522, 521, 846, 845,
560, 559, 554, 553, 548, 547, 542, 541, 74, 73, 33, 0, 0, 0, 0, 0, 0, 11, 68, 67, 116, 115, 536, 535, 530, 529, 524, 523, 847, 0,
562, 561, 556, 555, 550, 549, 544, 543, 76, 75, 0, 0, 8, 7, 36, 35, 12, 0, 70, 69, 118, 117, 538, 537, 532, 531, 526, 525, 849, 848,
564, 563, 558, 557, 552, 551, 546, 545, 78, 77, 0, 34, 10, 9, 26, 25, 0, 0, 72, 71, 120, 119, 540, 539, 534, 533, 528, 527, 850, 0,
566, 565, 572, 571, 578, 577, 584, 583, 590, 589, 596, 595, 602, 601, 608, 607, 614, 613, 620, 619, 626, 625, 632, 631, 638, 637, 644, 643, 852, 851,
568, 567, 574, 573, 580, 579, 586, 585, 592, 591, 598, 597, 604, 603, 610, 609, 616, 615, 622, 621, 628, 627, 634, 633, 640, 639, 646, 645, 853, 0,
570, 569, 576, 575, 582, 581, 588, 587, 594, 593, 600, 599, 606, 605, 612, 611, 618, 617, 624, 623, 630, 629, 636, 635, 642, 641, 648, 647, 855, 854,
728, 727, 722, 721, 716, 715, 710, 709, 704, 703, 698, 697, 692, 691, 686, 685, 680, 679, 674, 673, 668, 667, 662, 661, 656, 655, 650, 649, 856, 0,
730, 729, 724, 723, 718, 717, 712, 711, 706, 705, 700, 699, 694, 693, 688, 687, 682, 681, 676, 675, 670, 669, 664, 663, 658, 657, 652, 651, 858, 857,
732, 731, 726, 725, 720, 719, 714, 713, 708, 707, 702, 701, 696, 695, 690, 689, 684, 683, 678, 677, 672, 671, 666, 665, 660, 659, 654, 653, 859, 0,
734, 733, 740, 739, 746, 745, 752, 751, 758, 757, 764, 763, 770, 769, 776, 775, 782, 781, 788, 787, 794, 793, 800, 799, 806, 805, 812, 811, 861, 860,
736, 735, 742, 741, 748, 747, 754, 753, 760, 759, 766, 765, 772, 771, 778, 777, 784, 783, 790, 789, 796, 795, 802, 801, 808, 807, 814, 813, 862, 0,
738, 737, 744, 743, 750, 749, 756, 755, 762, 761, 768, 767, 774, 773, 780, 779, 786, 785, 792, 791, 798, 797, 804, 803, 810, 809, 816, 815, 864, 863
);
//* ASCII character to Code Set mapping, from ISO/IEC 16023 Appendix A.
//* 1 = Set A, 2 = Set B, 3 = Set C, 4 = Set D, 5 = Set E.
//* 0 refers to special characters that fit into more than one set (e.g. GS).
MAXICODE_SET: array [0..256-1] of integer = (
5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 0, 5, 5, 5, 5, 5, 5,
5, 5, 5, 5, 5, 5, 5, 5, 0, 0, 0, 5, 0, 2, 1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 0, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 2,
2, 2, 2, 2, 2, 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, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
5, 4, 5, 5, 5, 5, 5, 5, 4, 5, 3, 4, 3, 5, 5, 4, 4, 3, 3, 3,
4, 3, 5, 4, 4, 3, 3, 4, 3, 3, 3, 4, 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, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4
);
//* ASCII character to symbol value, from ISO/IEC 16023 Appendix A.
MAXICODE_SYMBOL_CHAR: array [0..256-1] 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, 30, 28, 29, 30, 35, 32, 53, 34, 35, 36, 37, 38, 39,
40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 37,
38, 39, 40, 41, 52, 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, 42, 43, 44, 45, 46, 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, 32, 54, 34, 35, 36, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 47, 48,
49, 50, 51, 52, 53, 54, 55, 56, 57, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 36,
37, 37, 38, 39, 40, 41, 42, 43, 38, 44, 37, 39, 38, 45, 46, 40, 41, 39, 40, 41,
42, 42, 47, 43, 44, 43, 44, 45, 45, 46, 47, 46, 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, 32,
33, 34, 35, 36, 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, 32, 33, 34, 35, 36
);
{ TMaxiCodeImpl }
function TMaxiCodeImpl.bestSurroundingSet(index, len: Integer;
valid: array of Integer): Integer;
function contains(values: array of Integer; value: integer): boolean;
var
i: Integer;
begin
Result := True;
for i := 0 to High(values) do
if values[i] = value then
Exit;
Result := False;
end;
var
option1, option2: Integer;
begin
option1 := Fset[index - 1];
if index + 1 < len then // we have two options to check
begin
option2 := Fset[index + 1];
if contains(valid, option1) and contains(valid, option2) then
Result := Min(option1, option2)
else if contains(valid, option1) then
Result := option1
else if contains(valid, option2) then
Result := option2
else
Result := valid[0];
end
else // we only have one option to check
begin
if contains(valid, option1) then
Result := option1
else
Result := valid[0];
end;
end;
constructor TMaxiCodeImpl.Create;
const
radii: array [0..2] of Extended = (9.91, 6.16, 2.37);
var
i: Integer;
begin
FMode := 4;
eciMode := 3;
structuredAppendPosition := 1;
structuredAppendTotal := 1;
PrimaryData := '';
FHexagonCount := 0;
for i := 0 to High(radii) do
FEllipseRect[i] := frxRect(35.76 - radii[i], 35.60 - radii[i],
35.76 + radii[i], 35.60 + radii[i]);
end;
function TMaxiCodeImpl.Encode(inputBytes: AnsiString; Mode: Integer): Boolean;
function insert(original: TLongIntArray; index: Integer; inserted: TLongIntArray): TLongIntArray;
function ArrayCopy(sourceArray: TLongIntArray; sourceIndex: Integer;
destinationArray: TLongIntArray; destinationIndex, len: Integer): TLongIntArray;
begin
Move(sourceArray[sourceIndex], destinationArray[destinationIndex],
len * SizeOf(sourceArray[0]));
end;
var
modified: TLongIntArray;
begin
SetLength(modified, Length(original) + Length(inserted));
ArrayCopy(original, 0, modified, 0, index);
ArrayCopy(inserted, 0, modified, index, Length(inserted));
ArrayCopy(original, index, modified, index + Length(inserted), Length(modified) - index - Length(inserted));
result := modified;
end;
var
i, j, index, secondaryMax, secondaryECMax, totalMax, block, bit: Integer;
_primary, flag, primary, primaryCheck, secondary, secondaryOdd, secondaryEven,
secondaryECOdd, secondaryECEven, bit_pattern: TLongIntArray;
begin
sourcelen := Length(inputBytes);
FMode := Mode;
SetLength(source, sourcelen);
for i := 0 to sourcelen - 1 do
source[i] := Ord(inputBytes[i + 1]); // i + 1: delphi string is 1-based
// mode 2 -> mode 3 if postal code isn't strictly numeric
if FMode = 2 then
for i := 0 to Min(9, Length(PrimaryData) - 1) do
if not IsNumeral(PrimaryData, i) then
begin
FMode := 3;
Break;
end;
// initialize the set and character arrays
if not processText then
raise Exception.Create('Input data too long');
// start building the codeword array, starting with a copy of the character data
// insert primary message if this is a structured carrier message; insert mode otherwise
SetLength(codewords, Length(character));
Move(character[0], codewords[0], Length(character) * SizeOf(character[0]));
if FMode in [2..3] then
begin
_primary := getPrimaryCodewords;
if Length(_primary) = 0 then
begin
Result := False;
Exit;
end;
codewords := insert(codewords, 0, _primary);
end
else
begin
SetLength(_primary, 1);
_primary[0] := FMode;
codewords := insert(codewords, 0, _primary);
end;
// insert structured append flag if necessary
if StructuredAppendTotal > 1 then
begin
SetLength(flag, 2);
flag[0] := 33; // padding
flag[1] := ((StructuredAppendTotal - 1) shl 3) or (structuredAppendTotal - 1); // position + total
if FMode in [2..3] then
index := 10 // first two data symbols in the secondary message
else
index := 1; // first two data symbols in the primary message (first symbol at index 0 isn't a data symbol)
codewords := insert(codewords, index, flag);
end;
if FMode = 5 then // 68 data codewords, 56 error corrections in secondary message
begin
secondaryMax := 68;
secondaryECMax := 56;
end
else // 84 data codewords, 40 error corrections in secondary message
begin
secondaryMax := 84;
secondaryECMax := 40;
end;
// truncate data codewords to maximum data space available
totalMax := secondaryMax + 10;
if (Length(codewords) > totalMax) then
SetLength(codewords, totalMax);
// insert primary error correction between primary message and secondary message (always EEC)
primary := Copy(codewords, 0, 10);
primaryCheck := getErrorCorrection(primary, 10);
codewords := insert(codewords, 10, primaryCheck);
// calculate secondary error correction
secondary := Copy(codewords, 20, Length(codewords) - 20);
SetLength(secondaryOdd, Length(secondary) div 2);
SetLength(secondaryEven, Length(secondary) div 2);
for i := 0 to Length(secondary) - 1 do
if Odd(i) then
secondaryOdd[(i - 1) div 2] := secondary[i]
else
secondaryEven[i div 2] := secondary[i];
secondaryECOdd := getErrorCorrection(secondaryOdd, secondaryECMax div 2);
secondaryECEven := getErrorCorrection(secondaryEven, secondaryECMax div 2);
// add secondary error correction after secondary message
SetLength(codewords, Length(codewords) + Length(secondaryECOdd) + Length(secondaryECEven));
for i := 0 to Length(secondaryECOdd) - 1 do
codewords[20 + secondaryMax + (2 * i) + 1] := secondaryECOdd[i];
for i := 0 to Length(secondaryECEven) - 1 do
codewords[20 + secondaryMax + (2 * i)] := secondaryECEven[i];
// copy data into symbol grid
SetLength(bit_pattern, 7);
for i := 0 to 33 - 1 do
for j := 0 to 30 - 1 do
begin
block := (MAXICODE_GRID[(i * 30) + j] + 5) div 6;
bit := (MAXICODE_GRID[(i * 30) + j] + 5) mod 6;
if block <> 0 then
begin
bit_pattern[0] := (codewords[block - 1] and $20) shr 5;
bit_pattern[1] := (codewords[block - 1] and $10) shr 4;
bit_pattern[2] := (codewords[block - 1] and $8) shr 3;
bit_pattern[3] := (codewords[block - 1] and $4) shr 2;
bit_pattern[4] := (codewords[block - 1] and $2) shr 1;
bit_pattern[5] := (codewords[block - 1] and $1);
grid[i, j] := bit_pattern[bit] <> 0;
end;
end;
// add orientation markings
grid[ 0, 28] := True; // top right filler
grid[ 0, 29] := True;
grid[ 9, 10] := True; // top left marker
grid[ 9, 11] := True;
grid[10, 11] := True;
grid[15, 7] := True; // left hand marker
grid[16, 8] := True;
grid[16, 20] := True; // right hand marker
grid[17, 20] := True;
grid[22, 10] := True; // bottom left marker
grid[23, 10] := True;
grid[22, 17] := True; // bottom right marker
grid[23, 17] := True;
plotSymbol;
Result := True;
end;
function TMaxiCodeImpl.GetEllipceCount: Integer;
begin
Result := 3;
end;
function TMaxiCodeImpl.GetEllipseRect(i: Integer): TfrxRect;
begin
Result := FEllipseRect[i];
end;
function TMaxiCodeImpl.getErrorCorrection(codewords: TLongIntArray;
ecclen: Integer): TLongIntArray;
var
results: TLongIntArray;
rs: TReedSolomon;
i: Integer;
begin
rs := TReedSolomon.Create;
rs.init_gf($43);
rs.init_code(ecclen, 1);
rs.encode(Length(codewords), codewords);
SetLength(results, ecclen);
for i := 0 to ecclen - 1 do
results[i] := rs.getResult(Length(results) - 1 - i);
Result := results;
rs.Free;
end;
function TMaxiCodeImpl.GetHexagonPoint(i, j: Integer): TfrxPoint;
begin
Result := HexagonPointByIndex(FHexagonCenter[i], j);
end;
function TMaxiCodeImpl.getMode2PrimaryCodewords(postcode: AnsiString; country,
service: Integer): TLongIntArray;
var
i, postcodeNum: LongInt;
primary: TLongIntArray;
begin
for i := 0 to Length(postcode) - 1 do
if not IsNumeral(postcode, i) then
begin
postcode := Substring(postcode, 0, i);
Break;
end;
postcodeNum := IntParse(postcode);
SetLength(primary, 10);
primary[0] := ((postcodeNum and $03) shl 4) or 2;
primary[1] := ((postcodeNum and $fc) shr 2);
primary[2] := ((postcodeNum and $3f00) shr 8);
primary[3] := ((postcodeNum and $fc000) shr 14);
primary[4] := ((postcodeNum and $3f00000) shr 20);
primary[5] := ((postcodeNum and $3c000000) shr 26) or ((Length(postcode) and $3) shl 4);
primary[6] := ((Length(postcode) and $3c) shr 2) or ((country and $3) shl 4);
primary[7] := (country and $fc) shr 2;
primary[8] := ((country and $300) shr 8) or ((service and $f) shl 2);
primary[9] := ((service and $3f0) shr 4);
Result := primary;
end;
function TMaxiCodeImpl.getMode3PrimaryCodewords(postcode: AnsiString; country,
service: Integer): TLongIntArray;
var
postcodeNums: TLongIntArray;
i: Integer;
primary: TLongIntArray;
begin
SetLength(postcodeNums, Length(postcode));
postcode := AnsiString(UpperCase(String(postcode)));
for i := 0 to Length(postcode) - 1 do
begin
postcodeNums[i] := Ord(postcode[i + 1]); // i + 1: delphi string is 1-based
if (postcode[i + 1] >= 'A') and (postcode[i + 1] <= 'Z') then
// (Capital) letters shifted to Code Set A values
postcodeNums[i] := postcodeNums[i] - 64;
if (postcodeNums[i] in [27, 31, 33]) or (postcodeNums[i] >= 59) then
// Not a valid postal code character, use space instead
postcodeNums[i] := 32;
// Input characters lower than 27 (NUL - SUB) in postal code are interpreted as capital
// letters in Code Set A (e.g. LF becomes 'J')
end;
SetLength(primary, 10);
primary[0] := ((postcodeNums[5] and $03) shl 4) or 3;
primary[1] := ((postcodeNums[4] and $03) shl 4) or ((postcodeNums[5] and $3c) shr 2);
primary[2] := ((postcodeNums[3] and $03) shl 4) or ((postcodeNums[4] and $3c) shr 2);
primary[3] := ((postcodeNums[2] and $03) shl 4) or ((postcodeNums[3] and $3c) shr 2);
primary[4] := ((postcodeNums[1] and $03) shl 4) or ((postcodeNums[2] and $3c) shr 2);
primary[5] := ((postcodeNums[0] and $03) shl 4) or ((postcodeNums[1] and $3c) shr 2);
primary[6] := ((postcodeNums[0] and $3c) shr 2) or ((country and $3) shl 4);
primary[7] := (country and $fc) shr 2;
primary[8] := ((country and $300) shr 8) or ((service and $f) shl 2);
primary[9] := ((service and $3f0) shr 4);
Result := primary;
end;
function TMaxiCodeImpl.getPrimaryCodewords: TLongIntArray;
var
i, index, country, service: Integer;
postcode: AnsiString;
begin
if Length(PrimaryData) <> 15 then
raise Exception.Create('Invalid Primary String');
for i := 9 to 15 do // check that country code and service are numeric
if not IsNumeral(PrimaryData, i) then
raise Exception.Create('Invalid Primary String');
if FMode = 2 then
begin
postcode := Substring(PrimaryData, 0, 9);
index := IndexOf(PrimaryData, ' ');
if index > -1 then
postcode := Substring(postcode, 0, index);
end
else // FMode = 3
postcode := Substring(PrimaryData, 0, 6);
country := IntParse(PrimaryData, 9, 3);
service := IntParse(PrimaryData, 12, 3);
if FMode = 2 then
Result := getMode2PrimaryCodewords(postcode, country, service)
else // Mode = 3
Result := getMode3PrimaryCodewords(postcode, country, service);
end;
function TMaxiCodeImpl.HexagonCenter(Row, Col: Integer): TfrxPoint;
begin
Result := frxPoint((2.46 * Col) + 1.23 + (Row and $1) * 1.23,
(2.135 * Row) + 1.43);
end;
function TMaxiCodeImpl.HexagonPointByIndex(Center: TfrxPoint;
Index: Integer): TfrxPoint;
begin
with Center do
begin
Result.X := X + OFFSET_X[Index] * INK_SPREAD;
Result.Y := Y + OFFSET_Y[Index] * INK_SPREAD;
end;
end;
function TMaxiCodeImpl.IndexOf(str, substr: AnsiString): integer;
begin
Result := Pos(substr, str) - 1; // zero based index
end;
function TMaxiCodeImpl.IntParse(str: AnsiString; startIndex: Integer = 0;
len: Integer = -1): Integer;
begin
Result := StrToInt(String(Substring(str, startIndex, len)));
end;
function TMaxiCodeImpl.IsNumeral(str: AnsiString; i: Integer): Boolean;
begin
Result := str[i + 1] in ['0'..'9']; // i + 1: delphi string is 1-based
end;
procedure TMaxiCodeImpl.plotSymbol;
var
row, col: Integer;
begin
// hexagons
FHexagonCount := 0;
for row := 0 to 33 - 1 do
for col := 0 to 30 - 1 do
if grid[row, col] then
begin
FHexagonCenter[FHexagonCount] := HexagonCenter(row, col);
FHexagonCount := FHexagonCount + 1;
end;
end;
function TMaxiCodeImpl.processText: Boolean;
procedure insert(position, c: Integer);
var
i: Integer;
begin
for i := 144 - 1 downto position + 1 do
begin
FSet[i] := FSet[i - 1];
character[i] := character[i - 1];
end;
character[position] := c;
end;
var
i, j, len, count, current_set: Integer;
value: LongInt;
begin
Result := False;
if sourcelen > 138 then
Exit;
len := sourcelen;
for i := 0 to 144 - 1 do
begin
Fset[i] := -1;
character[i] := 0;
end;
for i := 0 to len - 1 do
begin
// Look up characters in table from Appendix A - this gives
// value and code set for most characters
Fset[i] := MAXICODE_SET[source[i]];
character[i] := MAXICODE_SYMBOL_CHAR[source[i]];
end;
// If a character can be represented in more than one code set, pick which version to use.
if Fset[0] = 0 then
begin
if character[0] = 13 then
character[0] := 0;
Fset[0] := 1;
end;
for i := 1 to len - 1 do
if Fset[i] = 0 then
// Special character that can be represented in more than one code set.
if character[i] = 13 then // Carriage Return
begin
Fset[i] := bestSurroundingSet(i, len, [1, 5]);
if Fset[i] = 5 then character[i] := 13
else character[i] := 0;
end
else if character[i] = 28 then // FS
begin
Fset[i] := bestSurroundingSet(i, len, [1, 2, 3, 4, 5]);
if Fset[i] = 5 then character[i] := 32;
end
else if character[i] = 29 then // GS
begin
Fset[i] := bestSurroundingSet(i, len, [1, 2, 3, 4, 5]);
if Fset[i] = 5 then character[i] := 33;
end
else if character[i] = 30 then // RS
begin
Fset[i] := bestSurroundingSet(i, len, [1, 2, 3, 4, 5]);
if Fset[i] = 5 then character[i] := 34;
end
else if character[i] = 32 then // Space
begin
Fset[i] := bestSurroundingSet(i, len, [1, 2, 3, 4, 5]);
if Fset[i] = 1 then character[i] := 32
else if Fset[i] = 2 then character[i] := 47
else character[i] := 59;
end
else if character[i] = 44 then // Comma
begin
Fset[i] := bestSurroundingSet(i, len, [1, 2]);
if Fset[i] = 2 then character[i] := 48;
end
else if character[i] = 46 then // Full Stop
begin
Fset[i] := bestSurroundingSet(i, len, [1, 2]);
if Fset[i] = 2 then character[i] := 49;
end
else if character[i] = 47 then // Slash
begin
Fset[i] := bestSurroundingSet(i, len, [1, 2]);
if Fset[i] = 2 then character[i] := 50;
end
else if character[i] = 58 then // Colon
begin
Fset[i] := bestSurroundingSet(i, len, [1, 2]);
if Fset[i] = 2 then character[i] := 51;
end;
for i := len to Length(Fset) - 1 do // Add the padding
begin
if Fset[len - 1] = 2 then Fset[i] := 2
else Fset[i] := 1;
character[i] := 33;
end;
// Find candidates for number compression (not allowed in primary message in modes 2 and 3).
if FMode in [2, 3] then j := 9
else j := 0;
count := 0;
for i := j to 144 - 1 do
begin
if (Fset[i] = 1) and (character[i] in [48..57]) then // Character is a number
count := count + 1
else
count := 0;
if count = 9 then // Nine digits in a row can be compressed
begin
Fset[i] := 6; Fset[i - 1] := 6; Fset[i - 2] := 6;
Fset[i - 3] := 6; Fset[i - 4] := 6; Fset[i - 5] := 6;
Fset[i - 6] := 6; Fset[i - 7] := 6; Fset[i - 8] := 6;
count := 0;
end;
end;
// Add shift and latch characters
current_set := 1;
i := 0;
repeat
if (Fset[i] <> current_set) and (Fset[i] <> 6) then
begin
case Fset[i] of
1:
if (i + 1 < Length(Fset)) and (Fset[i + 1] = 1) then
begin
if (i + 2 < Length(Fset)) and (Fset[i + 2] = 1) then
begin
if (i + 3 < Length(Fset)) and (Fset[i + 3] = 1) then // Latch A
begin
insert(i, 63);
current_set := 1;
len := len + 1;
i := i + 3;
end
else // 3 Shift A
begin
insert(i, 57);
len := len + 1;
i := i + 2;
end;
end
else // 2 Shift A
begin
insert(i, 56);
len := len + 1;
i := i + 1;
end;
end
else // Shift A
begin
insert(i, 59);
len := len + 1;
end;
2:
if (i + 1 < Length(Fset)) and (Fset[i + 1] = 2) then //
begin
insert(i, 63);
current_set := 2;
len := len + 1;
i := i + 1;
end
else // Shift B
begin
insert(i, 59);
len := len + 1;
end;
3:
if (i + 3 < Length(Fset)) and
(Fset[i + 1] = 3) and (Fset[i + 2] = 3) and (Fset[i + 3] = 3) then // Lock In C
begin
insert(i, 60);
insert(i, 60);
current_set := 3;
len := len + 1;
i := i + 3;
end
else // Shift C
begin
insert(i, 60);
len := len + 1;
end;
4:
if (i + 3 < Length(Fset)) and
(Fset[i + 1] = 4) and (Fset[i + 2] = 4) and (Fset[i + 3] = 4) then // Lock In D
begin
insert(i, 61);
insert(i, 61);
current_set := 4;
len := len + 1;
i := i + 3;
end
else // Shift D
begin
insert(i, 61);
len := len + 1;
end;
5:
if (i + 3 < Length(Fset)) and
(Fset[i + 1] = 5) and (Fset[i + 2] = 5) and (Fset[i + 5] = 4) then // Lock In E
begin
insert(i, 62);
insert(i, 62);
current_set := 5;
len := len + 1;
i := i + 3;
end
else // Shift E
begin
insert(i, 62);
len := len + 1;
end;
else
raise Exception.Create('Unexpected set ' + IntToStr(Fset[i]) + ' at index ' + IntToStr(i));
end;
i := i + 1;
end;
i := i + 1;
until i >= Length(Fset);
// Number compression has not been forgotten! It's handled below.
i := 0;
repeat
if Fset[i] = 6 then // Number compression
begin
value := 0;
for j := 0 to 9 - 1 do
begin
value := value * 10;
value := value + (character[i + j] - Ord('0'));
end;
character[i] := 31; // NS
character[i + 1] := (value and $3f000000) shr 24;
character[i + 2] := (value and $fc0000) shr 18;
character[i + 3] := (value and $3f000) shr 12;
character[i + 4] := (value and $fc0) shr 6;
character[i + 5] := (value and $3f);
i := i + 6;
for j := i to 140 - 1 do
begin
Fset[j] := Fset[j + 3];
character[j] := character[j + 3];
end;
len := len - 3;
end
else
i := i + 1;
until i >= Length(Fset);
// Inject ECI codes to beginning of data, according to Table
if eciMode <> 3 then
begin
insert(0, 27); // ECI
if eciMode in [0..31] then
begin
insert(1, eciMode and $1F);
len := len + 2;
end;
if (eciMode >= 32) and (eciMode <= 1023) then
begin
insert(1, $20 + (eciMode shr 6));
insert(2, eciMode and $3F);
len := len + 3;
end;
if (eciMode >= 1024) and (eciMode <= 32767) then
begin
insert(1, $30 + (eciMode shr 12));
insert(2, (eciMode shr 6) and $3F);
insert(3, eciMode and $3F);
len := len + 4;
end;
if (eciMode >= 32768) and (eciMode <= 999999) then
begin
insert(1, $38 + (eciMode shr 18));
insert(2, (eciMode shr 12) and $3F);
insert(3, (eciMode shr 6) and $3F);
insert(4, eciMode and $3F);
len := len + 5;
end;
end;
if (FMode in [2, 3]) and (len > 84) or
(FMode in [4, 6]) and (len > 93) or
(FMode = 5) and (len > 77) then
Result := False
else
Result := True;
end;
procedure TMaxiCodeImpl.SetStructuredAppendPosition(const Value: Integer);
begin
if not (Value in [1..8]) then
raise Exception.Create('Invalid MaxiCode structured append position: ' + IntToStr(Value));
if FStructuredAppendPosition <> Value then
FStructuredAppendPosition := Value;
end;
procedure TMaxiCodeImpl.SetStructuredAppendTotal(const Value: Integer);
begin
if not (Value in [1..8]) then
raise Exception.Create('Invalid MaxiCode structured append total: ' + IntToStr(Value));
if FStructuredAppendTotal <> Value then
FStructuredAppendTotal := Value;
end;
function TMaxiCodeImpl.Substring(str: AnsiString; startIndex: Integer;
len: Integer = -1): AnsiString;
begin
if len = -1 then
len := Length(str);
Result := Copy(str, startIndex + 1, len); // i + 1: delphi string is 1-based
end;
{ TReedSolomon }
procedure TReedSolomon.encode(len: LongInt; data: TLongIntArray);
var
i, k, m: LongInt;
begin
SetLength(res, rlen);
for i := 0 to rlen - 1 do
res[i] := 0;
for i := 0 to len - 1 do
begin
m := res[rlen - 1] xor data[i];
for k := rlen - 1 downto 1 do
if (m <> 0) and (rspoly[k] <> 0) then
res[k] := res[k - 1] xor (alog[(logt[m] + logt[rspoly[k]]) mod logmod])
else
res[k] := res[k - 1];
if (m <> 0) and (rspoly[0] <> 0) then
res[0] := alog[(logt[m] + logt[rspoly[0]]) mod logmod]
else
res[0] := 0;
end;
end;
function TReedSolomon.getResult(count: LongInt): LongInt;
begin
Result := res[count];
end;
procedure TReedSolomon.init_code(nsym, index: LongInt);
var
i, k: LongInt;
begin
SetLength(rspoly, nsym + 1);
rlen := nsym;
rspoly[0] := 1;
for i := 1 to nsym do
begin
rspoly[i] := 1;
for k := i-1 downto 1 do
begin
if rspoly[k] <> 0 then
rspoly[k] := alog[(logt[rspoly[k]] + index) mod logmod];
rspoly[k] := rspoly[k] xor rspoly[k - 1];
end;
rspoly[0] := alog[(logt[rspoly[0]] + index) mod logmod];
index := index + 1;
end;
end;
procedure TReedSolomon.init_gf(poly: LongInt);
var
m, b, p, v: LongInt;
begin
// Find the top bit, and hence the symbol size
b := 1;
m := 0;
while b <= poly do
begin
b := b shl 1;
m := m + 1;
end;
b := b shr 1;
m := m - 1;
// Calculate the log/alog tables
logmod := (1 shl m) - 1;
SetLength(logt, logmod + 1);
SetLength(alog, logmod);
p := 1;
v := 0;
while v < logmod do
begin
alog[v] := p;
logt[p] := v;
p := p shl 1;
if (p and b) <> 0 then
p := p xor poly;
v := v + 1;
end;
end;
{ TMaxicodeEncoder }
const
FieldSizeFactor = 2.47;
PenSizeFactor = 4.5;
HalfPen = PenSizeFactor / 2;
constructor TMaxicodeEncoder.Create;
begin
FData := '';
FMode := 4;
FBitmap := TBitmap.Create;
{$IFNDEF Linux}
FBitmap.PixelFormat := pf1Bit;
{$ENDIF}
end;
destructor TMaxicodeEncoder.Destroy;
begin
FBitmap.Free;
inherited;
end;
function TMaxicodeEncoder.GetScanLine(Column: Integer): PByteArray;
begin
Result := PByteArray(FBitmap.ScanLine[Column]);
end;
function TMaxicodeEncoder.GetIsBlack(Row, Column: integer): Boolean;
begin
Result := FBitmap.Canvas.Pixels[Row, Column] = clBlack;
end;
function TMaxicodeEncoder.Height: Integer;
begin
Result := FBitmap.Height;
end;
procedure TMaxicodeEncoder.SetData(const Value: WideString);
begin
if FData <> Value then
begin
FData := Value;
Update;
end;
end;
procedure TMaxicodeEncoder.SetMode(const Value: Integer);
begin
if not (Value in [2..6]) then
raise Exception.Create('Invalid MaxiCode mode: ' + IntToStr(Value));
if FMode <> Value then
begin
FMode := Value;
Update;
end;
end;
procedure TMaxicodeEncoder.Update;
var
AnsiSt: AnsiString;
Encoder: TMaxiCodeImpl;
MaxSize: Extended;
i, j: Integer;
DrawPoints: array [0..5] of TPoint;
begin
{$IFDEF Delphi12}
AnsiSt := _UnicodeToAnsi(Data, DEFAULT_CHARSET);
{$ELSE}
AnsiSt := AnsiString(Data);
{$ENDIF}
Encoder := TMaxiCodeImpl.Create;
try
Encoder.Encode(AnsiSt, Mode);
// CalcBounds
MaxSize := 0;
for j := 0 to 5 do
with Encoder.HexagonPointByIndex(Encoder.HexagonCenter(33 - 1, 30 - 1), j) do
MaxSize := Max(MaxSize, Max(X, y));
FBitmap.Width := Round(FieldSizeFactor * MaxSize) + 1;
FBitmap.Height := FBitmap.Width;
FBitmap.Canvas.Brush.Color := clWhite;
FBitmap.Canvas.FillRect(FBitmap.Canvas.ClipRect);
// Draw
FBitmap.Canvas.Brush.Color := clBlack;
FBitmap.Canvas.Pen.Color := clBlack;
FBitmap.Canvas.Pen.Width := 1;
for i := 0 to Encoder.HexagonCount - 1 do
begin
for j := 0 to 5 do
with Encoder.HexagonPoint[i, j] do
DrawPoints[j] := Point(Round(FieldSizeFactor * X), Round(FieldSizeFactor * Y));
FBitmap.Canvas.Polygon(DrawPoints);
end;
FBitmap.Canvas.Brush.Color := clWhite;
FBitmap.Canvas.Pen.Width := Round(PenSizeFactor);
for i := 0 to Encoder.EllipceCount - 1 do
with Encoder.EllipseRect[i] do
FBitmap.Canvas.Ellipse(Round(FieldSizeFactor * Left ),
Round(FieldSizeFactor * Top ),
Round(FieldSizeFactor * Right ) + 1,
Round(FieldSizeFactor * Bottom) + 1);
finally
Encoder.Free;
end;
end;
function TMaxicodeEncoder.Width: Integer;
begin
Result := FBitmap.Width;
end;
end.
Reference in New Issue Copy Permalink