Delphi xe7 FireMonkey / Mobile (Android, iOS)生成 QR Code完
发布时间：2020-12-15 09:53:35 所属栏目：大数据 来源：网络整理
导读：这个实例在windows、OS X、IOS和Android等平台运行正常。 本文参考这个网站提供的方法：http://zarko-gajic.iz.hr/firemonkey-mobile-android-ios-qr-code-generation-using-delphi-xe-5-delphizxingqrcode/ 代码中用到的DelphiZXingQRCode.Pas点这下载 1 un
|
这个实例在windows、OS X、IOS和Android等平台运行正常。 代码中用到的DelphiZXingQRCode.Pas点这下载
1 unit Unit3;
2
3 interface
4
5 uses
6 System.SysUtils,System.Types,System.UITypes,System.Classes,System.Variants,7 FMX.Types,FMX.Controls,FMX.Forms,FMX.Graphics,FMX.Dialogs,FMX.Objects,8 FMX.Controls.Presentation,FMX.Edit,FMX.StdCtrls,DelphiZXingQRCode,9 FMX.ListBox,system.math;
10
11 type
12 TForm3 = class(TForm)
13 Button1: TButton;
14 edtText: TEdit;
15 imgQRCode: TImage;
16 cmbEncoding: TComboBox;
17 edtQuietZone: TEdit;
18 procedure Button1Click(Sender: TObject);
19 private
20 { Private declarations }
21 BMP: TBitmap;
22 public
23 { Public declarations }
24 end;
25
26 var
27 Form3: TForm3;
28
29 implementation
30
31 {$R *.fmx}
32
33 procedure TForm3.Button1Click(Sender: TObject);
34 const
35 downsizeQuality: Integer = 2; // bigger value,better quality,slower rendering
36 var
37 QRCode: TDelphiZXingQRCode;
38 Row,Column: Integer;
39 pixelColor : TAlphaColor;
40 vBitMapData : TBitmapData;
41 pixelCount,y,x: Integer;
42 columnPixel,rowPixel: Integer;
43 function GetPixelCount(AWidth,AHeight: Single): Integer;
44 begin
45 if QRCode.Rows > 0 then
46 Result := Trunc(Min(AWidth,AHeight)) div QRCode.Rows
47 else
48 Result := 0;
49 end;
50 begin
51 QRCode := TDelphiZXingQRCode.Create;
52 try
53 QRCode.Data := edtText.Text;
54 QRCode.Encoding := TQRCodeEncoding(cmbEncoding.ItemIndex);
55 QRCode.QuietZone := StrToIntDef(edtQuietZone.Text,4);
56 pixelCount := GetPixelCount(imgQRCode.Width,imgQRCode.Height);
57 case imgQRCode.WrapMode of
58 TImageWrapMode.iwOriginal,TImageWrapMode.iwTile,TImageWrapMode.iwCenter:
59 begin
60 if pixelCount > 0 then
61 imgQRCode.Bitmap.SetSize(QRCode.Columns * pixelCount,62 QRCode.Rows * pixelCount);
63 end;
64 TImageWrapMode.iwFit:
65 begin
66 if pixelCount > 0 then
67 begin
68 imgQRCode.Bitmap.SetSize(QRCode.Columns * pixelCount * downsizeQuality,69 QRCode.Rows * pixelCount * downsizeQuality);
70 pixelCount := pixelCount * downsizeQuality;
71 end;
72 end;
73 TImageWrapMode.iwStretch:
74 raise Exception.Create(‘Not a good idea to stretch the QR Code‘);
75 end;
76// if imgQRCode.Bitmap.Canvas.BeginScene then
77// begin
78 try
79 imgQRCode.Bitmap.Canvas.Clear(TAlphaColors.White);
80 if pixelCount > 0 then
81 begin
82 if imgQRCode.Bitmap.Map(TMapAccess.maWrite,vBitMapData) then
83 begin
84 try
85 for Row := 0 to QRCode.Rows - 1 do
86 begin
87 for Column := 0 to QRCode.Columns - 1 do
88 begin
89 if (QRCode.IsBlack[Row,Column]) then
90 pixelColor := TAlphaColors.Black
91 else
92 pixelColor := TAlphaColors.White;
93 columnPixel := Column * pixelCount;
94 rowPixel := Row * pixelCount;
95 for x := 0 to pixelCount - 1 do
96 for y := 0 to pixelCount - 1 do
97 vBitMapData.SetPixel(columnPixel + x,98 rowPixel + y,pixelColor);
99 end;
100 end;
101 finally
102 imgQRCode.Bitmap.Unmap(vBitMapData);
103 end;
104 end;
105 end;
106 finally
107// imgQRCode.Bitmap.Canvas.EndScene;
108// end;
109 end;
110 finally
111 QRCode.Free;
112 end;
113 end;
114
115 end.
FMX：
1 object Form3: TForm3 2 Left = 0 3 Top = 0 4 Caption = ‘Form3‘ 5 ClientHeight = 487 6 ClientWidth = 328 7 FormFactor.Width = 320 8 FormFactor.Height = 480 9 FormFactor.Devices = [Desktop] 10 DesignerMasterStyle = 3 11 object Button1: TButton 12 Position.X = 32.000000000000000000 13 Position.Y = 104.000000000000000000 14 Size.Width = 89.000000000000000000 15 Size.Height = 44.000000000000000000 16 Size.PlatformDefault = False 17 TabOrder = 0 18 Text = ‘Button1‘ 19 OnClick = Button1Click 20 end 21 object edtText: TEdit 22 Touch.InteractiveGestures = [LongTap,DoubleTap] 23 TabOrder = 1 24 Position.X = 32.000000000000000000 25 Position.Y = 56.000000000000000000 26 Size.Width = 233.000000000000000000 27 Size.Height = 32.000000000000000000 28 Size.PlatformDefault = False 29 end 30 object imgQRCode: TImage 31 MultiResBitmap = < 32 item 33 end> 34 Anchors = [akLeft,akTop,akRight,akBottom] 35 MarginWrapMode = Center 36 Position.X = 32.000000000000000000 37 Position.Y = 192.000000000000000000 38 Size.Width = 250.000000000000000000 39 Size.Height = 250.000000000000000000 40 Size.PlatformDefault = False 41 end 42 object cmbEncoding: TComboBox 43 Items.Strings = ( 44 ‘Auto‘ 45 ‘Numeric‘ 46 ‘Alphanumeric‘ 47 ‘ISO-8859-1‘ 48 ‘UTF-8 without BOM‘ 49 ‘UTF-8 with BOM‘) 50 ItemIndex = 0 51 Position.X = 136.000000000000000000 52 Position.Y = 112.000000000000000000 53 Size.Width = 145.000000000000000000 54 Size.Height = 32.000000000000000000 55 Size.PlatformDefault = False 56 TabOrder = 3 57 end 58 object edtQuietZone: TEdit 59 Touch.InteractiveGestures = [LongTap,DoubleTap] 60 TabOrder = 4 61 Text = ‘4‘ 62 Position.X = 32.000000000000000000 63 Position.Y = 152.000000000000000000 64 Size.Width = 100.000000000000000000 65 Size.Height = 32.000000000000000000 66 Size.PlatformDefault = False 67 end 68 end
?
2015-02-13 新的demo，简化调用方式，要配合下面的DelphiZXIngQRCode.pas
? 新的DelphiZXIngQRCode.pas
unit DelphiZXIngQRCode;
// ZXing QRCode port to Delphi,by Debenu Pty Ltd
// www.debenu.com
// Original copyright notice
(*
* Copyright 2008 ZXing authors
*
* 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.
*)
interface
uses
System.UITypes,FMX.Types;
type
TQRCodeEncoding = (qrAuto,qrNumeric,qrAlphanumeric,qrISO88591,qrUTF8NoBOM,qrUTF8BOM);
T2DBooleanArray = array of array of Boolean;
TDelphiZXingQRCode = class
protected
FData: String;
FRows: Integer;
FColumns: Integer;
FEncoding: TQRCodeEncoding;
FQuietZone: Integer;
FElements: T2DBooleanArray;
procedure SetEncoding(NewEncoding: TQRCodeEncoding);
procedure SetData(const NewData: string);
procedure SetQuietZone(NewQuietZone: Integer);
function GetIsBlack(Row,Column: Integer): Boolean;
procedure Update;
public
constructor Create;
procedure DrawQrcode(imgQRCode: TImage; QRCode: TDelphiZXingQRCode);
property Data: string read FData write SetData;
property Encoding: TQRCodeEncoding read FEncoding write SetEncoding;
property QuietZone: Integer read FQuietZone write SetQuietZone;
property Rows: Integer read FRows;
property Columns: Integer read FColumns;
property IsBlack[Row,Column: Integer]: Boolean read GetIsBlack;
end;
implementation
uses
System.Generics.Collections,Math,Classes,System.SysUtils;
type
TByteArray = array of Byte;
T2DByteArray = array of array of Byte;
TIntegerArray = array of Integer;
const
NUM_MASK_PATTERNS = 8;
QUIET_ZONE_SIZE = 4;
ALPHANUMERIC_TABLE: array [0 .. 95] of Integer = (-1,-1,// 0x00-0x0f
-1,// 0x10-0x1f
36,37,38,39,40,41,42,43,// 0x20-0x2f
0,1,2,3,4,5,6,7,8,9,44,// 0x30-0x3f
-1,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,// 0x40-0x4f
25,26,27,28,29,30,31,32,33,34,35,-1 // 0x50-0x5f
);
DEFAULT_BYTE_MODE_ENCODING = ‘ISO-8859-1‘;
POSITION_DETECTION_PATTERN: array [0 .. 6,0 .. 6] of Integer =
((1,1),(1,1));
HORIZONTAL_SEPARATION_PATTERN: array [0 .. 0,0 .. 7] of Integer =
((0,0));
VERTICAL_SEPARATION_PATTERN: array [0 .. 6,0 .. 0] of Integer = ((0),(0),(0));
POSITION_ADJUSTMENT_PATTERN: array [0 .. 4,0 .. 4] of Integer =
((1,1));
// From Appendix E. Table 1,JIS0510X:2004 (p 71). The table was double-checked by komatsu.
POSITION_ADJUSTMENT_PATTERN_COORDINATE_TABLE: array [0 .. 39,0 .. 6]
of Integer = ((-1,-1),// Version 1
(6,// Version 2
(6,// Version 3
(6,// Version 4
(6,// Version 5
(6,// Version 6
(6,// Version 7
(6,// Version 8
(6,46,// Version 9
(6,50,// Version 10
(6,54,// Version 11
(6,58,// Version 12
(6,62,// Version 13
(6,66,// Version 14
(6,48,70,// Version 15
(6,74,// Version 16
(6,78,// Version 17
(6,56,82,// Version 18
(6,86,// Version 19
(6,90,// Version 20
(6,72,94,// Version 21
(6,98,// Version 22
(6,102,// Version 23
(6,80,106,// Version 24
(6,84,110,// Version 25
(6,114,// Version 26
(6,118,// Version 27
(6,122,// Version 28
(6,126,// Version 29
(6,52,104,130,// Version 30
(6,108,134,// Version 31
(6,60,112,138,// Version 32
(6,142,// Version 33
(6,146,// Version 34
(6,150),// Version 35
(6,76,128,154),// Version 36
(6,132,158),// Version 37
(6,136,162),// Version 38
(6,166),// Version 39
(6,170) // Version 40
);
// Type info cells at the left top corner.
TYPE_INFO_COORDINATES: array [0 .. 14,0 .. 1] of Integer = ((8,0),(8,2),3),4),5),7),8),(7,(5,(4,(3,(2,(0,8));
// From Appendix D in JISX0510:2004 (p. 67)
VERSION_INFO_POLY = $1F25; // 1 1111 0010 0101
// From Appendix C in JISX0510:2004 (p.65).
TYPE_INFO_POLY = $537;
TYPE_INFO_MASK_PATTERN = $5412;
VERSION_DECODE_INFO: array [0 .. 33] of Integer = (
$07C94,$085BC,$09A99,$0A4D3,$0BBF6,$0C762,$0D847,$0E60D,$0F928,$10B78,$1145D,$12A17,$13532,$149A6,$15683,$168C9,$177EC,$18EC4,$191E1,$1AFAB,$1B08E,$1CC1A,$1D33F,$1ED75,$1F250,$209D5,$216F0,$228BA,$2379F,$24B0B,$2542E,$26A64,$27541,$28C69);
type
TMode = (qmTerminator,qmNumeric,qmAlphanumeric,qmStructuredAppend,qmByte,qmECI,qmKanji,qmFNC1FirstPosition,qmFNC1SecondPosition,qmHanzi);
const
ModeCharacterCountBits: array [TMode] of array [0 .. 2] of Integer =
((0,(10,14),(9,13),16),12),12));
ModeBits: array [TMode] of Integer = (0,13);
type
TErrorCorrectionLevel = class
private
FBits: Integer;
public
procedure Assign(Source: TErrorCorrectionLevel);
function Ordinal: Integer;
property Bits: Integer read FBits;
end;
TECB = class
private
Count: Integer;
DataCodewords: Integer;
public
constructor Create(Count,DataCodewords: Integer);
function GetCount: Integer;
function GetDataCodewords: Integer;
end;
TECBArray = array of TECB;
TECBlocks = class
private
ECCodewordsPerBlock: Integer;
ECBlocks: TECBArray;
public
constructor Create(ECCodewordsPerBlock: Integer; ECBlocks: TECB); overload;
constructor Create(ECCodewordsPerBlock: Integer;
ECBlocks1,ECBlocks2: TECB); overload;
destructor Destroy; override;
function GetTotalECCodewords: Integer;
function GetNumBlocks: Integer;
function GetECCodewordsPerBlock: Integer;
function GetECBlocks: TECBArray;
end;
TByteMatrix = class
protected
Bytes: T2DByteArray;
FWidth: Integer;
FHeight: Integer;
public
constructor Create(Width,Height: Integer);
function Get(X,Y: Integer): Integer;
procedure SetBoolean(X,Y: Integer; Value: Boolean);
procedure SetInteger(X,Y: Integer; Value: Integer);
function GetArray: T2DByteArray;
procedure Assign(Source: TByteMatrix);
procedure Clear(Value: Byte);
function Hash: string;
property Width: Integer read FWidth;
property Height: Integer read FHeight;
end;
TBitArray = class
private
Bits: array of Integer;
Size: Integer;
procedure EnsureCapacity(Size: Integer);
public
constructor Create; overload;
constructor Create(Size: Integer); overload;
function GetSizeInBytes: Integer;
function GetSize: Integer;
function Get(I: Integer): Boolean;
procedure SetBit(Index: Integer);
procedure AppendBit(Bit: Boolean);
procedure AppendBits(Value,NumBits: Integer);
procedure AppendBitArray(NewBitArray: TBitArray);
procedure ToBytes(BitOffset: Integer; Source: TByteArray;
Offset,NumBytes: Integer);
procedure XorOperation(Other: TBitArray);
end;
TCharacterSetECI = class
end;
TVersion = class
private
VersionNumber: Integer;
AlignmentPatternCenters: array of Integer;
ECBlocks: array of TECBlocks;
TotalCodewords: Integer;
ECCodewords: Integer;
public
constructor Create(VersionNumber: Integer;
AlignmentPatternCenters: array of Integer;
ECBlocks1,ECBlocks2,ECBlocks3,ECBlocks4: TECBlocks);
destructor Destroy; override;
class function GetVersionForNumber(VersionNum: Integer): TVersion;
class function ChooseVersion(NumInputBits: Integer;
ecLevel: TErrorCorrectionLevel): TVersion;
function GetTotalCodewords: Integer;
function GetECBlocksForLevel(ecLevel: TErrorCorrectionLevel): TECBlocks;
function GetDimensionForVersion: Integer;
end;
TMaskUtil = class
public
function GetDataMaskBit(MaskPattern,X,Y: Integer): Boolean;
end;
TQRCode = class
private
FMode: TMode;
FECLevel: TErrorCorrectionLevel;
FVersion: Integer;
FMatrixWidth: Integer;
FMaskPattern: Integer;
FNumTotalBytes: Integer;
FNumDataBytes: Integer;
FNumECBytes: Integer;
FNumRSBlocks: Integer;
FMatrix: TByteMatrix;
FQRCodeError: Boolean;
public
constructor Create;
destructor Destroy; override;
function At(X,Y: Integer): Integer;
function IsValid: Boolean;
function IsValidMaskPattern(MaskPattern: Integer): Boolean;
procedure SetMatrix(NewMatrix: TByteMatrix);
procedure SetECLevel(NewECLevel: TErrorCorrectionLevel);
procedure SetAll(VersionNum,NumBytes,NumDataBytes,NumRSBlocks,NumECBytes,MatrixWidth: Integer);
property QRCodeError: Boolean read FQRCodeError;
property Mode: TMode read FMode write FMode;
property Version: Integer read FVersion write FVersion;
property NumDataBytes: Integer read FNumDataBytes;
property NumTotalBytes: Integer read FNumTotalBytes;
property NumRSBlocks: Integer read FNumRSBlocks;
property MatrixWidth: Integer read FMatrixWidth;
property MaskPattern: Integer read FMaskPattern write FMaskPattern;
property ecLevel: TErrorCorrectionLevel read FECLevel;
end;
TMatrixUtil = class
private
FMatrixUtilError: Boolean;
procedure ClearMatrix(Matrix: TByteMatrix);
procedure EmbedBasicPatterns(Version: Integer; Matrix: TByteMatrix);
procedure EmbedTypeInfo(ecLevel: TErrorCorrectionLevel;
MaskPattern: Integer; Matrix: TByteMatrix);
procedure MaybeEmbedVersionInfo(Version: Integer; Matrix: TByteMatrix);
procedure EmbedDataBits(DataBits: TBitArray; MaskPattern: Integer;
Matrix: TByteMatrix);
function FindMSBSet(Value: Integer): Integer;
function CalculateBCHCode(Value,Poly: Integer): Integer;
procedure MakeTypeInfoBits(ecLevel: TErrorCorrectionLevel;
MaskPattern: Integer; Bits: TBitArray);
procedure MakeVersionInfoBits(Version: Integer; Bits: TBitArray);
function IsEmpty(Value: Integer): Boolean;
procedure EmbedTimingPatterns(Matrix: TByteMatrix);
procedure EmbedDarkDotAtLeftBottomCorner(Matrix: TByteMatrix);
procedure EmbedHorizontalSeparationPattern(XStart,YStart: Integer;
Matrix: TByteMatrix);
procedure EmbedVerticalSeparationPattern(XStart,YStart: Integer;
Matrix: TByteMatrix);
procedure EmbedPositionAdjustmentPattern(XStart,YStart: Integer;
Matrix: TByteMatrix);
procedure EmbedPositionDetectionPattern(XStart,YStart: Integer;
Matrix: TByteMatrix);
procedure EmbedPositionDetectionPatternsAndSeparators(Matrix: TByteMatrix);
procedure MaybeEmbedPositionAdjustmentPatterns(Version: Integer;
Matrix: TByteMatrix);
public
constructor Create;
property MatrixUtilError: Boolean read FMatrixUtilError;
procedure BuildMatrix(DataBits: TBitArray; ecLevel: TErrorCorrectionLevel;
Version,MaskPattern: Integer; Matrix: TByteMatrix);
end;
function GetModeBits(Mode: TMode): Integer;
begin
Result := ModeBits[Mode];
end;
function GetModeCharacterCountBits(Mode: TMode; Version: TVersion): Integer;
var
Number: Integer;
Offset: Integer;
begin
Number := Version.VersionNumber;
if (Number <= 9) then
begin
Offset := 0;
end
else if (Number <= 26) then
begin
Offset := 1;
end
else
begin
Offset := 2;
end;
Result := ModeCharacterCountBits[Mode][Offset];
end;
type
TBlockPair = class
private
FDataBytes: TByteArray;
FErrorCorrectionBytes: TByteArray;
public
constructor Create(BA1,BA2: TByteArray);
function GetDataBytes: TByteArray;
function GetErrorCorrectionBytes: TByteArray;
end;
TGenericGFPoly = class;
TGenericGF = class
private
FExpTable: TIntegerArray;
FLogTable: TIntegerArray;
FZero: TGenericGFPoly;
FOne: TGenericGFPoly;
FSize: Integer;
FPrimitive: Integer;
FGeneratorBase: Integer;
FInitialized: Boolean;
FPolyList: array of TGenericGFPoly;
procedure CheckInit;
procedure Initialize;
public
class function CreateQRCodeField256: TGenericGF;
class function AddOrSubtract(A,B: Integer): Integer;
constructor Create(Primitive,Size,B: Integer);
destructor Destroy; override;
function GetZero: TGenericGFPoly;
function Exp(A: Integer): Integer;
function GetGeneratorBase: Integer;
function Inverse(A: Integer): Integer;
function Multiply(A,B: Integer): Integer;
function BuildMonomial(Degree,Coefficient: Integer): TGenericGFPoly;
end;
TGenericGFPolyArray = array of TGenericGFPoly;
TGenericGFPoly = class
private
FField: TGenericGF;
FCoefficients: TIntegerArray;
public
constructor Create(AField: TGenericGF; ACoefficients: TIntegerArray);
destructor Destroy; override;
function Coefficients: TIntegerArray;
function Multiply(Other: TGenericGFPoly): TGenericGFPoly;
function MultiplyByMonomial(Degree,Coefficient: Integer): TGenericGFPoly;
function Divide(Other: TGenericGFPoly): TGenericGFPolyArray;
function GetCoefficients: TIntegerArray;
function IsZero: Boolean;
function GetCoefficient(Degree: Integer): Integer;
function GetDegree: Integer;
function AddOrSubtract(Other: TGenericGFPoly): TGenericGFPoly;
end;
TReedSolomonEncoder = class
private
FField: TGenericGF;
FCachedGenerators: TObjectList<TGenericGFPoly>;
public
constructor Create(AField: TGenericGF);
destructor Destroy; override;
procedure Encode(ToEncode: TIntegerArray; ECBytes: Integer);
function BuildGenerator(Degree: Integer): TGenericGFPoly;
end;
TEncoder = class
private
FEncoderError: Boolean;
function ApplyMaskPenaltyRule1Internal(Matrix: TByteMatrix;
IsHorizontal: Boolean): Integer;
function ChooseMode(const Content: string; var EncodeOptions: Integer)
: TMode; overload;
function FilterContent(const Content: string; Mode: TMode;
EncodeOptions: Integer): string;
procedure Append8BitBytes(const Content: string; Bits: TBitArray;
EncodeOptions: Integer);
procedure AppendAlphanumericBytes(const Content: string; Bits: TBitArray);
procedure AppendBytes(const Content: string; Mode: TMode; Bits: TBitArray;
EncodeOptions: Integer);
procedure AppendKanjiBytes(const Content: string; Bits: TBitArray);
procedure AppendLengthInfo(NumLetters,VersionNum: Integer; Mode: TMode;
Bits: TBitArray);
procedure AppendModeInfo(Mode: TMode; Bits: TBitArray);
procedure AppendNumericBytes(const Content: string; Bits: TBitArray);
function ChooseMaskPattern(Bits: TBitArray; ecLevel: TErrorCorrectionLevel;
Version: Integer; Matrix: TByteMatrix): Integer;
function GenerateECBytes(DataBytes: TByteArray;
NumECBytesInBlock: Integer): TByteArray;
function GetAlphanumericCode(Code: Integer): Integer;
procedure GetNumDataBytesAndNumECBytesForBlockID(NumTotalBytes,BlockID: Integer;
var NumDataBytesInBlock: TIntegerArray;
var NumECBytesInBlock: TIntegerArray);
procedure InterleaveWithECBytes(Bits: TBitArray;
NumTotalBytes,NumRSBlocks: Integer; var Result: TBitArray);
// function IsOnlyDoubleByteKanji(const Content: string): Boolean;
procedure TerminateBits(NumDataBytes: Integer; var Bits: TBitArray);
function CalculateMaskPenalty(Matrix: TByteMatrix): Integer;
function ApplyMaskPenaltyRule1(Matrix: TByteMatrix): Integer;
function ApplyMaskPenaltyRule2(Matrix: TByteMatrix): Integer;
function ApplyMaskPenaltyRule3(Matrix: TByteMatrix): Integer;
function ApplyMaskPenaltyRule4(Matrix: TByteMatrix): Integer;
// procedure Encode(const Content: string; ECLevel: TErrorCorrectionLevel; QRCode: TQRCode); overload;
procedure Encode(const Content: string; EncodeOptions: Integer;
ecLevel: TErrorCorrectionLevel; QRCode: TQRCode);
public
constructor Create;
property EncoderError: Boolean read FEncoderError;
end;
function TEncoder.ApplyMaskPenaltyRule1(Matrix: TByteMatrix): Integer;
begin
Result := ApplyMaskPenaltyRule1Internal(Matrix,True) +
ApplyMaskPenaltyRule1Internal(Matrix,False);
end;
// Apply mask penalty rule 2 and return the penalty. Find 2x2 blocks with the same color and give
// penalty to them.
function TEncoder.ApplyMaskPenaltyRule2(Matrix: TByteMatrix): Integer;
var
Penalty: Integer;
TheArray: T2DByteArray;
Width: Integer;
Height: Integer;
X: Integer;
Y: Integer;
Value: Integer;
begin
Penalty := 0;
TheArray := Matrix.GetArray;
Width := Matrix.Width;
Height := Matrix.Height;
for Y := 0 to Height - 2 do
begin
for X := 0 to Width - 2 do
begin
Value := TheArray[Y][X];
if ((Value = TheArray[Y][X + 1]) and (Value = TheArray[Y + 1][X]) and
(Value = TheArray[Y + 1][X + 1])) then
begin
Inc(Penalty,3);
end;
end;
end;
Result := Penalty;
end;
// Apply mask penalty rule 3 and return the penalty. Find consecutive cells of 00001011101 or
// 10111010000,and give penalty to them. If we find patterns like 000010111010000,we give
// penalties twice (i.e. 40 * 2).
function TEncoder.ApplyMaskPenaltyRule3(Matrix: TByteMatrix): Integer;
var
Penalty: Integer;
TheArray: T2DByteArray;
Width: Integer;
Height: Integer;
X: Integer;
Y: Integer;
begin
Penalty := 0;
TheArray := Matrix.GetArray;
Width := Matrix.Width;
Height := Matrix.Height;
for Y := 0 to Height - 1 do
begin
for X := 0 to Width - 1 do
begin
if ((X + 6 < Width) and (TheArray[Y][X] = 1) and (TheArray[Y][X + 1] = 0)
and (TheArray[Y][X + 2] = 1) and (TheArray[Y][X + 3] = 1) and
(TheArray[Y][X + 4] = 1) and (TheArray[Y][X + 5] = 0) and
(TheArray[Y][X + 6] = 1) and
(((X + 10 < Width) and (TheArray[Y][X + 7] = 0) and
(TheArray[Y][X + 8] = 0) and (TheArray[Y][X + 9] = 0) and
(TheArray[Y][X + 10] = 0)) or ((X - 4 >= 0) and (TheArray[Y][X - 1] = 0)
and (TheArray[Y][X - 2] = 0) and (TheArray[Y][X - 3] = 0) and
(TheArray[Y][X - 4] = 0)))) then
begin
Inc(Penalty,40);
end;
if ((Y + 6 < Height) and (TheArray[Y][X] = 1) and (TheArray[Y + 1][X] = 0)
and (TheArray[Y + 2][X] = 1) and (TheArray[Y + 3][X] = 1) and
(TheArray[Y + 4][X] = 1) and (TheArray[Y + 5][X] = 0) and
(TheArray[Y + 6][X] = 1) and
(((Y + 10 < Height) and (TheArray[Y + 7][X] = 0) and
(TheArray[Y + 8][X] = 0) and (TheArray[Y + 9][X] = 0) and
(TheArray[Y + 10][X] = 0)) or ((Y - 4 >= 0) and (TheArray[Y - 1][X] = 0)
and (TheArray[Y - 2][X] = 0) and (TheArray[Y - 3][X] = 0) and
(TheArray[Y - 4][X] = 0)))) then
begin
Inc(Penalty,40);
end;
end;
end;
Result := Penalty;
end;
// Apply mask penalty rule 4 and return the penalty. Calculate the ratio of dark cells and give
// penalty if the ratio is far from 50%. It gives 10 penalty for 5% distance. Examples:
// - 0% => 100
// - 40% => 20
// - 45% => 10
// - 50% => 0
// - 55% => 10
// - 55% => 20
// - 100% => 100
function TEncoder.ApplyMaskPenaltyRule4(Matrix: TByteMatrix): Integer;
var
NumDarkCells: Integer;
TheArray: T2DByteArray;
Width: Integer;
Height: Integer;
NumTotalCells: Integer;
DarkRatio: Double;
X: Integer;
Y: Integer;
begin
NumDarkCells := 0;
TheArray := Matrix.GetArray;
Width := Matrix.Width;
Height := Matrix.Height;
for Y := 0 to Height - 1 do
begin
for X := 0 to Width - 1 do
begin
if (TheArray[Y][X] = 1) then
begin
Inc(NumDarkCells);
end;
end;
end;
NumTotalCells := Matrix.Height * Matrix.Width;
DarkRatio := NumDarkCells / NumTotalCells;
Result := Round(Abs((DarkRatio * 100 - 50)) / 50);
end;
// Helper function for applyMaskPenaltyRule1. We need this for doing this calculation in both
// vertical and horizontal orders respectively.
function TEncoder.ApplyMaskPenaltyRule1Internal(Matrix: TByteMatrix;
IsHorizontal: Boolean): Integer;
var
Penalty: Integer;
NumSameBitCells: Integer;
PrevBit: Integer;
TheArray: T2DByteArray;
I: Integer;
J: Integer;
Bit: Integer;
ILimit: Integer;
JLimit: Integer;
begin
Penalty := 0;
NumSameBitCells := 0;
PrevBit := -1;
// Horizontal mode:
// for (int i = 0; i < matrix.height(); ++i) {
// for (int j = 0; j < matrix.width(); ++j) {
// int bit = matrix.get(i,j);
// Vertical mode:
// for (int i = 0; i < matrix.width(); ++i) {
// for (int j = 0; j < matrix.height(); ++j) {
// int bit = matrix.get(j,i);
if (IsHorizontal) then
begin
ILimit := Matrix.Height;
JLimit := Matrix.Width;
end
else
begin
ILimit := Matrix.Width;
JLimit := Matrix.Height;
end;
TheArray := Matrix.GetArray;
for I := 0 to ILimit - 1 do
begin
for J := 0 to JLimit - 1 do
begin
if (IsHorizontal) then
begin
Bit := TheArray[I][J];
end
else
begin
Bit := TheArray[J][I];
end;
if (Bit = PrevBit) then
begin
Inc(NumSameBitCells);
// Found five repetitive cells with the same color (bit).
// We‘ll give penalty of 3.
if (NumSameBitCells = 5) then
begin
Inc(Penalty,3);
end
else if (NumSameBitCells > 5) then
begin
// After five repetitive cells,we‘ll add the penalty one
// by one.
Inc(Penalty,1);;
end;
end
else
begin
NumSameBitCells := 1; // Include the cell itself.
PrevBit := Bit;
end;
end;
NumSameBitCells := 0; // Clear at each row/column.
end;
Result := Penalty;
end;
{ TQRCode }
constructor TQRCode.Create;
begin
FMode := qmTerminator;
FQRCodeError := False;
FECLevel := nil;
FVersion := -1;
FMatrixWidth := -1;
FMaskPattern := -1;
FNumTotalBytes := -1;
FNumDataBytes := -1;
FNumECBytes := -1;
FNumRSBlocks := -1;
FMatrix := nil;
end;
destructor TQRCode.Destroy;
begin
if (Assigned(FECLevel)) then
begin
FECLevel.Free;
end;
if (Assigned(FMatrix)) then
begin
FMatrix.Free;
end;
inherited;
end;
function TQRCode.At(X,Y: Integer): Integer;
var
Value: Integer;
begin
// The value must be zero or one.
Value := FMatrix.Get(X,Y);
if (not((Value = 0) or (Value = 1))) then
begin
FQRCodeError := True;
end;
Result := Value;
end;
function TQRCode.IsValid: Boolean;
begin
Result :=
// First check if all version are not uninitialized.
((FECLevel <> nil) and (FVersion <> -1) and (FMatrixWidth <> -1) and
(FMaskPattern <> -1) and (FNumTotalBytes <> -1) and (FNumDataBytes <> -1)
and (FNumECBytes <> -1) and (FNumRSBlocks <> -1) and
// Then check them in other ways..
IsValidMaskPattern(FMaskPattern) and (FNumTotalBytes = FNumDataBytes +
FNumECBytes) and
// ByteMatrix stuff.
(Assigned(FMatrix)) and (FMatrixWidth = FMatrix.Width) and
// See 7.3.1 of JISX0510:2004 (Fp.5).
(FMatrix.Width = FMatrix.Height)); // Must be square.
end;
function TQRCode.IsValidMaskPattern(MaskPattern: Integer): Boolean;
begin
Result := (MaskPattern >= 0) and (MaskPattern < NUM_MASK_PATTERNS);
end;
procedure TQRCode.SetMatrix(NewMatrix: TByteMatrix);
begin
if (Assigned(FMatrix)) then
begin
FMatrix.Free;
FMatrix := nil;
end;
FMatrix := NewMatrix;
end;
procedure TQRCode.SetAll(VersionNum,MatrixWidth: Integer);
begin
FVersion := VersionNum;
FNumTotalBytes := NumBytes;
FNumDataBytes := NumDataBytes;
FNumRSBlocks := NumRSBlocks;
FNumECBytes := NumECBytes;
FMatrixWidth := MatrixWidth;
end;
procedure TQRCode.SetECLevel(NewECLevel: TErrorCorrectionLevel);
begin
if (Assigned(FECLevel)) then
begin
FECLevel.Free;
end;
FECLevel := TErrorCorrectionLevel.Create;
FECLevel.Assign(NewECLevel);
end;
{ TByteMatrix }
procedure TByteMatrix.Clear(Value: Byte);
var
X,Y: Integer;
begin
for Y := 0 to FHeight - 1 do
begin
for X := 0 to FWidth - 1 do
begin
Bytes[Y][X] := Value;
end;
end;
end;
constructor TByteMatrix.Create(Width,Height: Integer);
var
Y: Integer;
X: Integer;
begin
FWidth := Width;
FHeight := Height;
SetLength(Bytes,Height);
for Y := 0 to Height - 1 do
begin
SetLength(Bytes[Y],Width);
for X := 0 to Width - 1 do
begin
Bytes[Y][X] := 0;
end;
end;
end;
function TByteMatrix.Get(X,Y: Integer): Integer;
begin
if (Bytes[Y][X] = 255) then
Result := -1
else
Result := Bytes[Y][X];
end;
function TByteMatrix.GetArray: T2DByteArray;
begin
Result := Bytes;
end;
function TByteMatrix.Hash: string;
var
X,Y: Integer;
Counter: Integer;
CC: Integer;
begin
Result := ‘‘;
for Y := 0 to FHeight - 1 do
begin
Counter := 0;
for X := 0 to FWidth - 1 do
begin
CC := Get(X,Y);
if (CC = -1) then
CC := 255;
Counter := Counter + CC;
end;
Result := Result + Char((Counter mod 26) + 65);
end;
end;
procedure TByteMatrix.SetBoolean(X,Y: Integer; Value: Boolean);
begin
Bytes[Y][X] := Byte(Value) and $FF;
end;
procedure TByteMatrix.SetInteger(X,Y,Value: Integer);
begin
Bytes[Y][X] := Value and $FF;
end;
procedure TByteMatrix.Assign(Source: TByteMatrix);
var
SourceLength: Integer;
begin
SourceLength := Length(Source.Bytes);
SetLength(Bytes,SourceLength);
if (SourceLength > 0) then
begin
Move(Source.Bytes[0],Bytes[0],SourceLength);
end;
FWidth := Source.Width;
FHeight := Source.Height;
end;
{ TEncoder }
function TEncoder.CalculateMaskPenalty(Matrix: TByteMatrix): Integer;
var
Penalty: Integer;
begin
Penalty := 0;
Inc(Penalty,ApplyMaskPenaltyRule1(Matrix));
Inc(Penalty,ApplyMaskPenaltyRule2(Matrix));
Inc(Penalty,ApplyMaskPenaltyRule3(Matrix));
Inc(Penalty,ApplyMaskPenaltyRule4(Matrix));
Result := Penalty;
end;
{ procedure TEncoder.Encode(const Content: string; ECLevel: TErrorCorrectionLevel; QRCode: TQRCode);
begin
Encode(Content,ECLevel,nil,QRCode);
end; }
procedure TEncoder.Encode(const Content: string; EncodeOptions: Integer;
ecLevel: TErrorCorrectionLevel; QRCode: TQRCode);
var
Mode: TMode;
DataBits: TBitArray;
FinalBits: TBitArray;
HeaderBits: TBitArray;
HeaderAndDataBits: TBitArray;
Matrix: TByteMatrix;
NumLetters: Integer;
MatrixUtil: TMatrixUtil;
BitsNeeded: Integer;
ProvisionalBitsNeeded: Integer;
ProvisionalVersion: TVersion;
Version: TVersion;
ECBlocks: TECBlocks;
NumDataBytes: Integer;
Dimension: Integer;
FilteredContent: string;
begin
DataBits := TBitArray.Create;
HeaderBits := TBitArray.Create;
// Pick an encoding mode appropriate for the content. Note that this will not attempt to use
// multiple modes / segments even if that were more efficient. Twould be nice.
// Collect data within the main segment,separately,to count its size if needed. Don‘t add it to
// main payload yet.
Mode := ChooseMode(Content,EncodeOptions);
FilteredContent := FilterContent(Content,Mode,EncodeOptions);
AppendBytes(FilteredContent,DataBits,EncodeOptions);
// (With ECI in place,) Write the mode marker
AppendModeInfo(Mode,HeaderBits);
// Hard part: need to know version to know how many bits length takes. But need to know how many
// bits it takes to know version. First we take a guess at version by assuming version will be
// the minimum,1:
ProvisionalVersion := TVersion.GetVersionForNumber(1);
try
ProvisionalBitsNeeded := HeaderBits.GetSize + GetModeCharacterCountBits
(Mode,ProvisionalVersion) + DataBits.GetSize;
finally
ProvisionalVersion.Free;
end;
ProvisionalVersion := TVersion.ChooseVersion(ProvisionalBitsNeeded,ecLevel);
try
// Use that guess to calculate the right version. I am still not sure this works in 100% of cases.
BitsNeeded := HeaderBits.GetSize + GetModeCharacterCountBits(Mode,ProvisionalVersion) + DataBits.GetSize;
Version := TVersion.ChooseVersion(BitsNeeded,ecLevel);
finally
ProvisionalVersion.Free;
end;
HeaderAndDataBits := TBitArray.Create;
FinalBits := TBitArray.Create;
try
HeaderAndDataBits.AppendBitArray(HeaderBits);
// Find "length" of main segment and write it
if (Mode = qmByte) then
begin
NumLetters := DataBits.GetSizeInBytes;
end
else
begin
NumLetters := Length(FilteredContent);
end;
AppendLengthInfo(NumLetters,Version.VersionNumber,HeaderAndDataBits);
// Put data together into the overall payload
HeaderAndDataBits.AppendBitArray(DataBits);
ECBlocks := Version.GetECBlocksForLevel(ecLevel);
NumDataBytes := Version.GetTotalCodewords - ECBlocks.GetTotalECCodewords;
// Terminate the bits properly.
TerminateBits(NumDataBytes,HeaderAndDataBits);
// Interleave data bits with error correction code.
InterleaveWithECBytes(HeaderAndDataBits,Version.GetTotalCodewords,ECBlocks.GetNumBlocks,FinalBits);
// QRCode qrCode = new QRCode(); // This is passed in
QRCode.SetECLevel(ecLevel);
QRCode.Mode := Mode;
QRCode.Version := Version.VersionNumber;
// Choose the mask pattern and set to "qrCode".
Dimension := Version.GetDimensionForVersion;
Matrix := TByteMatrix.Create(Dimension,Dimension);
QRCode.MaskPattern := ChooseMaskPattern(FinalBits,ecLevel,Matrix);
Matrix.Free;
Matrix := TByteMatrix.Create(Dimension,Dimension);
// Build the matrix and set it to "qrCode".
MatrixUtil := TMatrixUtil.Create;
try
MatrixUtil.BuildMatrix(FinalBits,QRCode.ecLevel,QRCode.Version,QRCode.MaskPattern,Matrix);
finally
MatrixUtil.Free;
end;
QRCode.SetMatrix(Matrix); // QRCode will free the matrix
finally
DataBits.Free;
HeaderAndDataBits.Free;
FinalBits.Free;
HeaderBits.Free;
Version.Free;
end;
end;
function TEncoder.FilterContent(const Content: string; Mode: TMode;
EncodeOptions: Integer): string;
var
X: Integer;
CanAdd: Boolean;
begin
Result := ‘‘;
// for X := 1 to Length(Content) do
for X := Low(Content) to High(Content) do // 2015-02-04，edited by vclclx。
begin
CanAdd := False;
if (Mode = qmNumeric) then
begin
CanAdd := (Content[X] >= ‘0‘) and (Content[X] <= ‘9‘);
end
else if (Mode = qmAlphanumeric) then
begin
CanAdd := GetAlphanumericCode(Ord(Content[X])) > 0;
end
else if (Mode = qmByte) then
begin
if (EncodeOptions = 3) then
begin
CanAdd := Ord(Content[X]) <= $FF;
end
else if ((EncodeOptions = 4) or (EncodeOptions = 5)) then
begin
CanAdd := True;
end;
end;
if (CanAdd) then
begin
Result := Result + Content[X];
end;
end;
end;
// Return the code point of the table used in alphanumeric mode or
// -1 if there is no corresponding code in the table.
function TEncoder.GetAlphanumericCode(Code: Integer): Integer;
begin
if (Code < Length(ALPHANUMERIC_TABLE)) then
begin
Result := ALPHANUMERIC_TABLE[Code];
end
else
begin
Result := -1;
end;
end;
// Choose the mode based on the content
function TEncoder.ChooseMode(const Content: string;
var EncodeOptions: Integer): TMode;
var
AllNumeric: Boolean;
AllAlphanumeric: Boolean;
AllISO: Boolean;
I: Integer;
C: WideChar;
begin
if (EncodeOptions = 0) then
begin
AllNumeric := Length(Content) > 0;
// I := 1;
// while (I <= Length(Content)) and (AllNumeric) do
I := Low(Content); // 2015-02-04，edited by vclclx。
while (I <= High(Content)) and (AllNumeric) do
// 2015-02-04，edited by vclclx。
begin
C := Content[I];
if ((C < ‘0‘) or (C > ‘9‘)) then
begin
AllNumeric := False;
end
else
begin
Inc(I);
end;
end;
if (not AllNumeric) then
begin
AllAlphanumeric := Length(Content) > 0;
// I := 1;
// while (I <= Length(Content)) and (AllAlphanumeric) do
I := Low(Content); // 2015-02-04，edited by vclclx。
while (I <= High(Content)) and (AllAlphanumeric) do
// 2015-02-04，edited by vclclx。
begin
C := Content[I];
if (GetAlphanumericCode(Ord(C)) < 0) then
begin
AllAlphanumeric := False;
end
else
begin
Inc(I);
end;
end;
end
else
begin
AllAlphanumeric := False;
end;
if (not AllAlphanumeric) then
begin
AllISO := Length(Content) > 0;
// I := 1;
// while (I <= Length(Content)) and (AllISO) do
I := Low(Content); // 2015-02-04，edited by vclclx。
while (I <= High(Content)) and (AllISO) do // 2015-02-04，edited by vclclx。
begin
C := Content[I];
if (Ord(C) > $FF) then
begin
AllISO := False;
end
else
begin
Inc(I);
end;
end;
end
else
begin
AllISO := False;
end;
if (AllNumeric) then
begin
Result := qmNumeric;
end
else if (AllAlphanumeric) then
begin
Result := qmAlphanumeric;
end
else if (AllISO) then
begin
Result := qmByte;
EncodeOptions := 3;
end
else
begin
Result := qmByte;
EncodeOptions := 4;
end;
end
else if (EncodeOptions = 1) then
begin
Result := qmNumeric;
end
else if (EncodeOptions = 2) then
begin
Result := qmAlphanumeric;
end
else
begin
Result := qmByte;
end;
end;
constructor TEncoder.Create;
begin
FEncoderError := False;
end;
{ function TEncoder.IsOnlyDoubleByteKanji(const Content: string): Boolean;
var
I: Integer;
Char1: Integer;
begin
Result := True;
I := 0;
while ((I < Length(Content)) and Result) do
begin
Char1 := Ord(Content[I + 1]);
if (((Char1 < $81) or (Char1 > $9F)) and ((Char1 < $E0) or (Char1 > $EB))) then
begin
Result := False;
end;
end;
end; }
function TEncoder.ChooseMaskPattern(Bits: TBitArray;
ecLevel: TErrorCorrectionLevel; Version: Integer;
Matrix: TByteMatrix): Integer;
var
MinPenalty: Integer;
BestMaskPattern: Integer;
MaskPattern: Integer;
MatrixUtil: TMatrixUtil;
Penalty: Integer;
begin
MinPenalty := MaxInt;
BestMaskPattern := -1;
// We try all mask patterns to choose the best one.
for MaskPattern := 0 to NUM_MASK_PATTERNS - 1 do
begin
MatrixUtil := TMatrixUtil.Create;
try
MatrixUtil.BuildMatrix(Bits,Version,MaskPattern,Matrix);
finally
MatrixUtil.Free;
end;
Penalty := CalculateMaskPenalty(Matrix);
if (Penalty < MinPenalty) then
begin
MinPenalty := Penalty;
BestMaskPattern := MaskPattern;
end;
end;
Result := BestMaskPattern;
end;
// Terminate bits as described in 8.4.8 and 8.4.9 of JISX0510:2004 (p.24).
procedure TEncoder.TerminateBits(NumDataBytes: Integer; var Bits: TBitArray);
var
Capacity: Integer;
I: Integer;
NumBitsInLastByte: Integer;
NumPaddingBytes: Integer;
begin
Capacity := NumDataBytes shl 3;
if (Bits.GetSize > Capacity) then
begin
FEncoderError := True;
Exit;
end;
I := 0;
while ((I < 4) and (Bits.GetSize < Capacity)) do
begin
Bits.AppendBit(False);
Inc(I);
end;
// Append termination bits. See 8.4.8 of JISX0510:2004 (p.24) for details.
// If the last byte isn‘t 8-bit aligned,we‘ll add padding bits.
NumBitsInLastByte := Bits.GetSize and $07;
if (NumBitsInLastByte > 0) then
begin
for I := NumBitsInLastByte to 7 do
begin
Bits.AppendBit(False);
end;
end;
// If we have more space,we‘ll fill the space with padding patterns defined in 8.4.9 (p.24).
NumPaddingBytes := NumDataBytes - Bits.GetSizeInBytes;
for I := 0 to NumPaddingBytes - 1 do
begin
if ((I and $01) = 0) then
begin
Bits.AppendBits($EC,8);
end
else
begin
Bits.AppendBits($11,8);
end;
end;
if (Bits.GetSize <> Capacity) then
begin
FEncoderError := True;
end;
end;
// Get number of data bytes and number of error correction bytes for block id "blockID". Store
// the result in "numDataBytesInBlock",and "numECBytesInBlock". See table 12 in 8.5.1 of
// JISX0510:2004 (p.30)
procedure TEncoder.GetNumDataBytesAndNumECBytesForBlockID(NumTotalBytes,BlockID: Integer;
var NumDataBytesInBlock: TIntegerArray; var NumECBytesInBlock: TIntegerArray);
var
NumRSBlocksInGroup1: Integer;
NumRSBlocksInGroup2: Integer;
NumTotalBytesInGroup1: Integer;
NumTotalBytesInGroup2: Integer;
NumDataBytesInGroup1: Integer;
NumDataBytesInGroup2: Integer;
NumECBytesInGroup1: Integer;
NumECBytesInGroup2: Integer;
begin
if (BlockID >= NumRSBlocks) then
begin
FEncoderError := True;
Exit;
end;
// numRsBlocksInGroup2 = 196 % 5 = 1
NumRSBlocksInGroup2 := NumTotalBytes mod NumRSBlocks;
// numRsBlocksInGroup1 = 5 - 1 = 4
NumRSBlocksInGroup1 := NumRSBlocks - NumRSBlocksInGroup2;
// numTotalBytesInGroup1 = 196 / 5 = 39
NumTotalBytesInGroup1 := NumTotalBytes div NumRSBlocks;
// numTotalBytesInGroup2 = 39 + 1 = 40
NumTotalBytesInGroup2 := NumTotalBytesInGroup1 + 1;
// numDataBytesInGroup1 = 66 / 5 = 13
NumDataBytesInGroup1 := NumDataBytes div NumRSBlocks;
// numDataBytesInGroup2 = 13 + 1 = 14
NumDataBytesInGroup2 := NumDataBytesInGroup1 + 1;
// numEcBytesInGroup1 = 39 - 13 = 26
NumECBytesInGroup1 := NumTotalBytesInGroup1 - NumDataBytesInGroup1;
// numEcBytesInGroup2 = 40 - 14 = 26
NumECBytesInGroup2 := NumTotalBytesInGroup2 - NumDataBytesInGroup2;
// Sanity checks.
// 26 = 26
if (NumECBytesInGroup1 <> NumECBytesInGroup2) then
begin
FEncoderError := True;
Exit;
end;
// 5 = 4 + 1.
if (NumRSBlocks <> (NumRSBlocksInGroup1 + NumRSBlocksInGroup2)) then
begin
FEncoderError := True;
Exit;
end;
// 196 = (13 + 26) * 4 + (14 + 26) * 1
if (NumTotalBytes <> ((NumDataBytesInGroup1 + NumECBytesInGroup1) *
NumRSBlocksInGroup1) + ((NumDataBytesInGroup2 + NumECBytesInGroup2) *
NumRSBlocksInGroup2)) then
begin
FEncoderError := True;
Exit;
end;
if (BlockID < NumRSBlocksInGroup1) then
begin
NumDataBytesInBlock[0] := NumDataBytesInGroup1;
NumECBytesInBlock[0] := NumECBytesInGroup1;
end
else
begin
NumDataBytesInBlock[0] := NumDataBytesInGroup2;
NumECBytesInBlock[0] := NumECBytesInGroup2;
end;
end;
// Interleave "bits" with corresponding error correction bytes. On success,store the result in
// "result". The interleave rule is complicated. See 8.6 of JISX0510:2004 (p.37) for details.
procedure TEncoder.InterleaveWithECBytes(Bits: TBitArray;
NumTotalBytes,NumRSBlocks: Integer; var Result: TBitArray);
var
DataBytesOffset: Integer;
MaxNumDataBytes: Integer;
MaxNumECBytes: Integer;
Blocks: TObjectList<TBlockPair>;
NumDataBytesInBlock: TIntegerArray;
NumECBytesInBlock: TIntegerArray;
Size: Integer;
DataBytes: TByteArray;
ECBytes: TByteArray;
I,J: Integer;
BlockPair: TBlockPair;
begin
SetLength(ECBytes,0);
// "bits" must have "getNumDataBytes" bytes of data.
if (Bits.GetSizeInBytes <> NumDataBytes) then
begin
FEncoderError := True;
Exit;
end;
// Step 1. Divide data bytes into blocks and generate error correction bytes for them. We‘ll
// store the divided data bytes blocks and error correction bytes blocks into "blocks".
DataBytesOffset := 0;
MaxNumDataBytes := 0;
MaxNumECBytes := 0;
// Since,we know the number of reedsolmon blocks,we can initialize the vector with the number.
Blocks := TObjectList<TBlockPair>.Create(True);
try
Blocks.Capacity := NumRSBlocks;
for I := 0 to NumRSBlocks - 1 do
begin
SetLength(NumDataBytesInBlock,1);
SetLength(NumECBytesInBlock,1);
GetNumDataBytesAndNumECBytesForBlockID(NumTotalBytes,I,NumDataBytesInBlock,NumECBytesInBlock);
Size := NumDataBytesInBlock[0];
SetLength(DataBytes,Size);
Bits.ToBytes(8 * DataBytesOffset,DataBytes,Size);
ECBytes := GenerateECBytes(DataBytes,NumECBytesInBlock[0]);
BlockPair := TBlockPair.Create(DataBytes,ECBytes);
Blocks.Add(BlockPair);
MaxNumDataBytes := Max(MaxNumDataBytes,Size);
MaxNumECBytes := Max(MaxNumECBytes,Length(ECBytes));
Inc(DataBytesOffset,NumDataBytesInBlock[0]);
end;
if (NumDataBytes <> DataBytesOffset) then
begin
FEncoderError := True;
Exit;
end;
// First,place data blocks.
for I := 0 to MaxNumDataBytes - 1 do
begin
for J := 0 to Blocks.Count - 1 do
begin
DataBytes := TBlockPair(Blocks.Items[J]).GetDataBytes;
if (I < Length(DataBytes)) then
begin
Result.AppendBits(DataBytes[I],8);
end;
end;
end;
// Then,place error correction blocks.
for I := 0 to MaxNumECBytes - 1 do
begin
for J := 0 to Blocks.Count - 1 do
begin
ECBytes := TBlockPair(Blocks.Items[J]).GetErrorCorrectionBytes;
if (I < Length(ECBytes)) then
begin
Result.AppendBits(ECBytes[I],8);
end;
end;
end;
finally
Blocks.Free;
end;
if (NumTotalBytes <> Result.GetSizeInBytes) then // Should be same.
begin
FEncoderError := True;
Exit;
end;
end;
function TEncoder.GenerateECBytes(DataBytes: TByteArray;
NumECBytesInBlock: Integer): TByteArray;
var
NumDataBytes: Integer;
ToEncode: TIntegerArray;
ReedSolomonEncoder: TReedSolomonEncoder;
I: Integer;
ECBytes: TByteArray;
GenericGF: TGenericGF;
begin
NumDataBytes := Length(DataBytes);
SetLength(ToEncode,NumDataBytes + NumECBytesInBlock);
for I := 0 to NumDataBytes - 1 do
begin
ToEncode[I] := DataBytes[I] and $FF;
end;
GenericGF := TGenericGF.CreateQRCodeField256;
try
ReedSolomonEncoder := TReedSolomonEncoder.Create(GenericGF);
try
ReedSolomonEncoder.Encode(ToEncode,NumECBytesInBlock);
finally
ReedSolomonEncoder.Free;
end;
finally
GenericGF.Free;
end;
SetLength(ECBytes,NumECBytesInBlock);
for I := 0 to NumECBytesInBlock - 1 do
begin
ECBytes[I] := ToEncode[NumDataBytes + I];
end;
Result := ECBytes;
end;
// Append mode info. On success,store the result in "bits".
procedure TEncoder.AppendModeInfo(Mode: TMode; Bits: TBitArray);
begin
Bits.AppendBits(GetModeBits(Mode),4);
end;
// Append length info. On success,store the result in "bits".
procedure TEncoder.AppendLengthInfo(NumLetters,VersionNum: Integer;
Mode: TMode; Bits: TBitArray);
var
NumBits: Integer;
Version: TVersion;
begin
Version := TVersion.GetVersionForNumber(VersionNum);
try
NumBits := GetModeCharacterCountBits(Mode,Version);
finally
Version.Free;
end;
if (NumLetters > ((1 shl NumBits) - 1)) then
begin
FEncoderError := True;
Exit;
end;
Bits.AppendBits(NumLetters,NumBits);
end;
// Append "bytes" in "mode" mode (encoding) into "bits". On success,store the result in "bits".
procedure TEncoder.AppendBytes(const Content: string; Mode: TMode;
Bits: TBitArray; EncodeOptions: Integer);
begin
if (Mode = qmNumeric) then
begin
AppendNumericBytes(Content,Bits);
end
else if (Mode = qmAlphanumeric) then
begin
AppendAlphanumericBytes(Content,Bits);
end
else if (Mode = qmByte) then
begin
Append8BitBytes(Content,Bits,EncodeOptions);
end
else if (Mode = qmKanji) then
begin
AppendKanjiBytes(Content,Bits);
end
else
begin
FEncoderError := True;
Exit;
end;
end;
procedure TEncoder.AppendNumericBytes(const Content: string; Bits: TBitArray);
var
ContentLength: Integer;
I: Integer;
Num1: Integer;
Num2: Integer;
Num3: Integer;
begin
ContentLength := Length(Content);
// I := 0;
// while (I < ContentLength) do
I := Low(Content); // 2015-02-04，edited by vclclx。
while (I <= High(Content)) do // 2015-02-04，edited by vclclx。
begin
// Num1 := Ord(Content[I + 0 + 1]) - Ord(‘0‘);
Num1 := Ord(Content[I + 0]) - Ord(‘0‘); // 2015-02-04，edited by vclclx。
// if (I + 2 < ContentLength) then
if (I + 2 <= High(Content)) then // 2015-02-04，edited by vclclx。
begin
// Encode three numeric letters in ten bits.
// Num2 := Ord(Content[I + 1 + 1]) - Ord(‘0‘);
// Num3 := Ord(Content[I + 2 + 1]) - Ord(‘0‘);
Num2 := Ord(Content[I + 1]) - Ord(‘0‘); // 2015-02-04，edited by vclclx。
Num3 := Ord(Content[I + 2]) - Ord(‘0‘); // 2015-02-04，edited by vclclx。
Bits.AppendBits(Num1 * 100 + Num2 * 10 + Num3,10);
Inc(I,3);
end
else
// if (I + 1 < ContentLength) then
if (I + 1 <= High(Content)) then // 2015-02-04，edited by vclclx。
begin
// Encode two numeric letters in seven bits.
// Num2 := Ord(Content[I + 1 + 1]) - Ord(‘0‘);
Num2 := Ord(Content[I + 1]) - Ord(‘0‘); // 2015-02-04，edited by vclclx。
Bits.AppendBits(Num1 * 10 + Num2,7);
Inc(I,2);
end
else
begin
// Encode one numeric letter in four bits.
Bits.AppendBits(Num1,4);
Inc(I);
end;
end;
end;
procedure TEncoder.AppendAlphanumericBytes(const Content: string;
Bits: TBitArray);
var
ContentLength: Integer;
I: Integer;
Code1: Integer;
Code2: Integer;
begin
ContentLength := Length(Content);
// I := 0;
// while (I < ContentLength) do
I := Low(Content); // 2015-02-04，edited by vclclx。
while (I <= High(Content)) do // 2015-02-04，edited by vclclx。
begin
// Code1 := GetAlphanumericCode(Ord(Content[I + 0 + 1]));
Code1 := GetAlphanumericCode(Ord(Content[I + 0]));
// 2015-02-04，edited by vclclx。
if (Code1 = -1) then
begin
FEncoderError := True;
Exit;
end;
// if (I + 1 < ContentLength) then
if (I + 1 <= High(Content)) then // 2015-02-04，edited by vclclx。
begin
// Code2 := GetAlphanumericCode(Ord(Content[I + 1 + 1]));
Code2 := GetAlphanumericCode(Ord(Content[I + 1]));
// 2015-02-04，edited by vclclx。
if (Code2 = -1) then
begin
FEncoderError := True;
Exit;
end;
// Encode two alphanumeric letters in 11 bits.
Bits.AppendBits(Code1 * 45 + Code2,11);
Inc(I,2);
end
else
begin
// Encode one alphanumeric letter in six bits.
Bits.AppendBits(Code1,6);
Inc(I);
end;
end;
end;
procedure TEncoder.Append8BitBytes(const Content: string; Bits: TBitArray;
EncodeOptions: Integer);
var
Bytes: TByteArray;
I: Integer;
// UTF8Version: string;
UTF8Bytes: TBytes; // 2015-02-04，edited by vclclx。
begin
SetLength(Bytes,0);
if (EncodeOptions = 3) then
begin
SetLength(Bytes,Length(Content));
// for I := 1 to Length(Content) do
for I := Low(Content) to High(Content) do // 2015-02-04，edited by vclclx。
begin
// Bytes[I - 1] := Ord(Content[I]) and $FF;
Bytes[I] := Ord(Content[I]) and $FF; // 2015-02-04，edited by vclclx。
end;
end
else if (EncodeOptions = 4) then
begin
// Add the UTF-8 BOM
// UTF8Version := #$EF#$BB#$BF + UTF8Encode(Content);
// SetLength(Bytes,Length(UTF8Version));
// if (Length(UTF8Version) > 0) then
// begin
// Move(UTF8Version[1],Length(UTF8Version));
// end;
// 2015-02-04，edited by vclclx。
Bytes := [$EF,$BB,$BF];
with TUTF8Encoding.Create do
try
UTF8Bytes := GetBytes(Content);
finally
Free;
end;
if Length(UTF8Bytes) > 0 then
begin
SetLength(Bytes,3 + Length(UTF8Bytes));
Move(UTF8Bytes[0],Bytes[3],Length(UTF8Bytes));
end;
end
else if (EncodeOptions = 5) then
begin
// No BOM
// UTF8Version := UTF8Encode(Content);
// SetLength(Bytes,Length(UTF8Version));
// end;
// 2015-02-04，edited by vclclx。
with TUTF8Encoding.Create do
try
UTF8Bytes := GetBytes(Content);
finally
Free;
end;
if Length(UTF8Bytes) > 0 then
begin
SetLength(Bytes,Length(UTF8Bytes));
Move(UTF8Bytes[0],Length(UTF8Bytes));
end;
end;
for I := 0 to Length(Bytes) - 1 do
begin
Bits.AppendBits(Bytes[I],8);
end;
end;
procedure TEncoder.AppendKanjiBytes(const Content: string; Bits: TBitArray);
var
Bytes: TByteArray;
ByteLength: Integer;
I: Integer;
Byte1: Integer;
Byte2: Integer;
Code: Integer;
Subtracted: Integer;
Encoded: Integer;
begin
SetLength(Bytes,0);
try
except
FEncoderError := True;
Exit;
end;
ByteLength := Length(Bytes);
I := 0;
while (I < ByteLength) do
begin
Byte1 := Bytes[I] and $FF;
Byte2 := Bytes[I + 1] and $FF;
Code := (Byte1 shl 8) or Byte2;
Subtracted := -1;
if ((Code >= $8140) and (Code <= $9FFC)) then
begin
Subtracted := Code - $8140;
end
else if ((Code >= $E040) and (Code <= $EBBF)) then
begin
Subtracted := Code - $C140;
end;
if (Subtracted = -1) then
begin
FEncoderError := True;
Exit;
end;
Encoded := ((Subtracted shr 8) * $C0) + (Subtracted and $FF);
Bits.AppendBits(Encoded,13);
Inc(I,2);
end;
end;
procedure TMatrixUtil.ClearMatrix(Matrix: TByteMatrix);
begin
Matrix.Clear(Byte(-1));
end;
constructor TMatrixUtil.Create;
begin
FMatrixUtilError := False;
end;
// Build 2D matrix of QR Code from "dataBits" with "ecLevel","version" and "getMaskPattern". On
// success,store the result in "matrix" and return true.
procedure TMatrixUtil.BuildMatrix(DataBits: TBitArray;
ecLevel: TErrorCorrectionLevel; Version,MaskPattern: Integer;
Matrix: TByteMatrix);
begin
ClearMatrix(Matrix);
EmbedBasicPatterns(Version,Matrix);
// Type information appear with any version.
EmbedTypeInfo(ecLevel,Matrix);
// Version info appear if version >= 7.
MaybeEmbedVersionInfo(Version,Matrix);
// Data should be embedded at end.
EmbedDataBits(DataBits,Matrix);
end;
// Embed basic patterns. On success,modify the matrix and return true.
// The basic patterns are:
// - Position detection patterns
// - Timing patterns
// - Dark dot at the left bottom corner
// - Position adjustment patterns,if need be
procedure TMatrixUtil.EmbedBasicPatterns(Version: Integer; Matrix: TByteMatrix);
begin
// Let‘s get started with embedding big squares at corners.
EmbedPositionDetectionPatternsAndSeparators(Matrix);
// Then,embed the dark dot at the left bottom corner.
EmbedDarkDotAtLeftBottomCorner(Matrix);
// Position adjustment patterns appear if version >= 2.
MaybeEmbedPositionAdjustmentPatterns(Version,Matrix);
// Timing patterns should be embedded after position adj. patterns.
EmbedTimingPatterns(Matrix);
end;
// Embed type information. On success,modify the matrix.
procedure TMatrixUtil.EmbedTypeInfo(ecLevel: TErrorCorrectionLevel;
MaskPattern: Integer; Matrix: TByteMatrix);
var
TypeInfoBits: TBitArray;
I: Integer;
Bit: Boolean;
X1,Y1: Integer;
X2,Y2: Integer;
begin
TypeInfoBits := TBitArray.Create;
try
MakeTypeInfoBits(ecLevel,TypeInfoBits);
for I := 0 to TypeInfoBits.GetSize - 1 do
begin
// Place bits in LSB to MSB order. LSB (least significant bit) is the last value in
// "typeInfoBits".
Bit := TypeInfoBits.Get(TypeInfoBits.GetSize - 1 - I);
// Type info bits at the left top corner. See 8.9 of JISX0510:2004 (p.46).
X1 := TYPE_INFO_COORDINATES[I][0];
Y1 := TYPE_INFO_COORDINATES[I][1];
Matrix.SetBoolean(X1,Y1,Bit);
if (I < 8) then
begin
// Right top corner.
X2 := Matrix.Width - I - 1;
Y2 := 8;
Matrix.SetBoolean(X2,Y2,Bit);
end
else
begin
// Left bottom corner.
X2 := 8;
Y2 := Matrix.Height - 7 + (I - 8);
Matrix.SetBoolean(X2,Bit);
end;
end;
finally
TypeInfoBits.Free;
end;
end;
// Embed version information if need be. On success,modify the matrix and return true.
// See 8.10 of JISX0510:2004 (p.47) for how to embed version information.
procedure TMatrixUtil.MaybeEmbedVersionInfo(Version: Integer;
Matrix: TByteMatrix);
var
VersionInfoBits: TBitArray;
I,J: Integer;
BitIndex: Integer;
Bit: Boolean;
begin
if (Version < 7) then
begin
Exit; // Don‘t need version info.
end;
VersionInfoBits := TBitArray.Create;
try
MakeVersionInfoBits(Version,VersionInfoBits);
BitIndex := 6 * 3 - 1; // It will decrease from 17 to 0.
for I := 0 to 5 do
begin
for J := 0 to 2 do
begin
// Place bits in LSB (least significant bit) to MSB order.
Bit := VersionInfoBits.Get(BitIndex);
Dec(BitIndex);
// Left bottom corner.
Matrix.SetBoolean(I,Matrix.Height - 11 + J,Bit);
// Right bottom corner.
Matrix.SetBoolean(Matrix.Height - 11 + J,Bit);
end;
end;
finally
VersionInfoBits.Free;
end;
end;
// Embed "dataBits" using "getMaskPattern". On success,modify the matrix and return true.
// For debugging purposes,it skips masking process if "getMaskPattern" is -1.
// See 8.7 of JISX0510:2004 (p.38) for how to embed data bits.
procedure TMatrixUtil.EmbedDataBits(DataBits: TBitArray; MaskPattern: Integer;
Matrix: TByteMatrix);
var
BitIndex: Integer;
Direction: Integer;
X,XX: Integer;
Bit: Boolean;
MaskUtil: TMaskUtil;
begin
MaskUtil := TMaskUtil.Create;
try
BitIndex := 0;
Direction := -1;
// Start from the right bottom cell.
X := Matrix.Width - 1;
Y := Matrix.Height - 1;
while (X > 0) do
begin
// Skip the vertical timing pattern.
if (X = 6) then
begin
Dec(X,1);
end;
while ((Y >= 0) and (Y < Matrix.Height)) do
begin
for I := 0 to 1 do
begin
XX := X - I;
// Skip the cell if it‘s not empty.
if (not IsEmpty(Matrix.Get(XX,Y))) then
begin
Continue;
end;
if (BitIndex < DataBits.GetSize) then
begin
Bit := DataBits.Get(BitIndex);
Inc(BitIndex);
end
else
begin
// Padding bit. If there is no bit left,we‘ll fill the left cells with 0,as described
// in 8.4.9 of JISX0510:2004 (p. 24).
Bit := False;
end;
// Skip masking if mask_pattern is -1.
if (MaskPattern <> -1) then
begin
if (MaskUtil.GetDataMaskBit(MaskPattern,XX,Y)) then
begin
Bit := not Bit;
end;
end;
Matrix.SetBoolean(XX,Bit);
end;
Inc(Y,Direction);
end;
Direction := -Direction; // Reverse the direction.
Inc(Y,Direction);
Dec(X,2); // Move to the left.
end;
finally
MaskUtil.Free;
end;
// All bits should be consumed.
if (BitIndex <> DataBits.GetSize()) then
begin
FMatrixUtilError := True;
Exit;
end;
end;
// Return the position of the most significant bit set (to one) in the "value". The most
// significant bit is position 32. If there is no bit set,return 0. Examples:
// - findMSBSet(0) => 0
// - findMSBSet(1) => 1
// - findMSBSet(255) => 8
function TMatrixUtil.FindMSBSet(Value: Integer): Integer;
var
NumDigits: Integer;
begin
NumDigits := 0;
while (Value <> 0) do
begin
Value := Value shr 1;
Inc(NumDigits);
end;
Result := NumDigits;
end;
// Calculate BCH (Bose-Chaudhuri-Hocquenghem) code for "value" using polynomial "poly". The BCH
// code is used for encoding type information and version information.
// Example: Calculation of version information of 7.
// f(x) is created from 7.
// - 7 = 000111 in 6 bits
// - f(x) = x^2 + x^1 + x^0
// g(x) is given by the standard (p. 67)
// - g(x) = x^12 + x^11 + x^10 + x^9 + x^8 + x^5 + x^2 + 1
// Multiply f(x) by x^(18 - 6)
// - f‘(x) = f(x) * x^(18 - 6)
// - f‘(x) = x^14 + x^13 + x^12
// Calculate the remainder of f‘(x) / g(x)
// x^2
// __________________________________________________
// g(x) )x^14 + x^13 + x^12
// x^14 + x^13 + x^12 + x^11 + x^10 + x^7 + x^4 + x^2
// --------------------------------------------------
// x^11 + x^10 + x^7 + x^4 + x^2
//
// The remainder is x^11 + x^10 + x^7 + x^4 + x^2
// Encode it in binary: 110010010100
// The return value is 0xc94 (1100 1001 0100)
//
// Since all coefficients in the polynomials are 1 or 0,we can do the calculation by bit
// operations. We don‘t care if cofficients are positive or negative.
function TMatrixUtil.CalculateBCHCode(Value,Poly: Integer): Integer;
var
MSBSetInPoly: Integer;
begin
// If poly is "1 1111 0010 0101" (version info poly),msbSetInPoly is 13. We‘ll subtract 1
// from 13 to make it 12.
MSBSetInPoly := FindMSBSet(Poly);
Value := Value shl (MSBSetInPoly - 1);
// Do the division business using exclusive-or operations.
while (FindMSBSet(Value) >= MSBSetInPoly) do
begin
Value := Value xor (Poly shl (FindMSBSet(Value) - MSBSetInPoly));
end;
// Now the "value" is the remainder (i.e. the BCH code)
Result := Value;
end;
// Make bit vector of type information. On success,store the result in "bits" and return true.
// Encode error correction level and mask pattern. See 8.9 of
// JISX0510:2004 (p.45) for details.
procedure TMatrixUtil.MakeTypeInfoBits(ecLevel: TErrorCorrectionLevel;
MaskPattern: Integer; Bits: TBitArray);
var
TypeInfo: Integer;
BCHCode: Integer;
MaskBits: TBitArray;
begin
if ((MaskPattern >= 0) and (MaskPattern < NUM_MASK_PATTERNS)) then
begin
TypeInfo := (ecLevel.Bits shl 3) or MaskPattern;
Bits.AppendBits(TypeInfo,5);
BCHCode := CalculateBCHCode(TypeInfo,TYPE_INFO_POLY);
Bits.AppendBits(BCHCode,10);
MaskBits := TBitArray.Create;
try
MaskBits.AppendBits(TYPE_INFO_MASK_PATTERN,15);
Bits.XorOperation(MaskBits);
finally
MaskBits.Free;
end;
if (Bits.GetSize <> 15) then // Just in case.
begin
FMatrixUtilError := True;
Exit;
end;
end;
end;
// Make bit vector of version information. On success,store the result in "bits" and return true.
// See 8.10 of JISX0510:2004 (p.45) for details.
procedure TMatrixUtil.MakeVersionInfoBits(Version: Integer; Bits: TBitArray);
var
BCHCode: Integer;
begin
Bits.AppendBits(Version,6);
BCHCode := CalculateBCHCode(Version,VERSION_INFO_POLY);
Bits.AppendBits(BCHCode,12);
if (Bits.GetSize() <> 18) then
begin
FMatrixUtilError := True;
Exit;
end;
end;
// Check if "value" is empty.
function TMatrixUtil.IsEmpty(Value: Integer): Boolean;
begin
Result := (Value = -1);
end;
procedure TMatrixUtil.EmbedTimingPatterns(Matrix: TByteMatrix);
var
I: Integer;
Bit: Integer;
begin
// -8 is for skipping position detection patterns (size 7),and two horizontal/vertical
// separation patterns (size 1). Thus,8 = 7 + 1.
for I := 8 to Matrix.Width - 9 do
begin
Bit := (I + 1) mod 2;
// Horizontal line.
if (IsEmpty(Matrix.Get(I,6))) then
begin
Matrix.SetInteger(I,Bit);
end;
// Vertical line.
if (IsEmpty(Matrix.Get(6,I))) then
begin
Matrix.SetInteger(6,Bit);
end;
end;
end;
// Embed the lonely dark dot at left bottom corner. JISX0510:2004 (p.46)
procedure TMatrixUtil.EmbedDarkDotAtLeftBottomCorner(Matrix: TByteMatrix);
begin
if (Matrix.Get(8,Matrix.Height - 8) = 0) then
begin
FMatrixUtilError := True;
Exit;
end;
Matrix.SetInteger(8,Matrix.Height - 8,1);
end;
procedure TMatrixUtil.EmbedHorizontalSeparationPattern(XStart,YStart: Integer;
Matrix: TByteMatrix);
var
X: Integer;
begin
// We know the width and height.
for X := 0 to 7 do
begin
if (not IsEmpty(Matrix.Get(XStart + X,YStart))) then
begin
FMatrixUtilError := True;
Exit;
end;
Matrix.SetInteger(XStart + X,YStart,HORIZONTAL_SEPARATION_PATTERN[0][X]);
end;
end;
procedure TMatrixUtil.EmbedVerticalSeparationPattern(XStart,YStart: Integer;
Matrix: TByteMatrix);
var
Y: Integer;
begin
// We know the width and height.
for Y := 0 to 6 do
begin
if (not IsEmpty(Matrix.Get(XStart,YStart + Y))) then
begin
FMatrixUtilError := True;
Exit;
end;
Matrix.SetInteger(XStart,YStart + Y,VERTICAL_SEPARATION_PATTERN[Y][0]);
end;
end;
// Note that we cannot unify the function with embedPositionDetectionPattern() despite they are
// almost identical,since we cannot write a function that takes 2D arrays in different sizes in
// C/C++. We should live with the fact.
procedure TMatrixUtil.EmbedPositionAdjustmentPattern(XStart,YStart: Integer;
Matrix: TByteMatrix);
var
X,Y: Integer;
begin
// We know the width and height.
for Y := 0 to 4 do
begin
for X := 0 to 4 do
begin
if (not IsEmpty(Matrix.Get(XStart + X,YStart + Y))) then
begin
FMatrixUtilError := True;
Exit;
end;
Matrix.SetInteger(XStart + X,POSITION_ADJUSTMENT_PATTERN[Y][X]);
end;
end;
end;
procedure TMatrixUtil.EmbedPositionDetectionPattern(XStart,Y: Integer;
begin
// We know the width and height.
for Y := 0 to 6 do
begin
for X := 0 to 6 do
begin
if (not IsEmpty(Matrix.Get(XStart + X,POSITION_DETECTION_PATTERN[Y][X]);
end;
end;
end;
// Embed position detection patterns and surrounding vertical/horizontal separators.
procedure TMatrixUtil.EmbedPositionDetectionPatternsAndSeparators
(Matrix: TByteMatrix);
var
PDPWidth: Integer;
HSPWidth: Integer;
VSPSize: Integer;
begin
// Embed three big squares at corners.
PDPWidth := Length(POSITION_DETECTION_PATTERN[0]);
// Left top corner.
EmbedPositionDetectionPattern(0,Matrix);
// Right top corner.
EmbedPositionDetectionPattern(Matrix.Width - PDPWidth,Matrix);
// Left bottom corner.
EmbedPositionDetectionPattern(0,Matrix.Width - PDPWidth,Matrix);
// Embed horizontal separation patterns around the squares.
HSPWidth := Length(HORIZONTAL_SEPARATION_PATTERN[0]);
// Left top corner.
EmbedHorizontalSeparationPattern(0,HSPWidth - 1,Matrix);
// Right top corner.
EmbedHorizontalSeparationPattern(Matrix.Width - HSPWidth,Matrix);
// Left bottom corner.
EmbedHorizontalSeparationPattern(0,Matrix.Width - HSPWidth,Matrix);
// Embed vertical separation patterns around the squares.
VSPSize := Length(VERTICAL_SEPARATION_PATTERN);
// Left top corner.
EmbedVerticalSeparationPattern(VSPSize,Matrix);
// Right top corner.
EmbedVerticalSeparationPattern(Matrix.Height - VSPSize - 1,Matrix);
// Left bottom corner.
EmbedVerticalSeparationPattern(VSPSize,Matrix.Height - VSPSize,Matrix);
end;
// Embed position adjustment patterns if need be.
procedure TMatrixUtil.MaybeEmbedPositionAdjustmentPatterns(Version: Integer;
Matrix: TByteMatrix);
var
Index: Integer;
Coordinates: array of Integer;
NumCoordinates: Integer;
X,J: Integer;
begin
if (Version >= 2) then
begin
Index := Version - 1;
NumCoordinates :=
Length(POSITION_ADJUSTMENT_PATTERN_COORDINATE_TABLE[Index]);
SetLength(Coordinates,NumCoordinates);
Move(POSITION_ADJUSTMENT_PATTERN_COORDINATE_TABLE[Index][0],Coordinates[0],NumCoordinates * SizeOf(Integer));
for I := 0 to NumCoordinates - 1 do
begin
for J := 0 to NumCoordinates - 1 do
begin
Y := Coordinates[I];
X := Coordinates[J];
if ((X = -1) or (Y = -1)) then
begin
Continue;
end;
// If the cell is unset,we embed the position adjustment pattern here.
if (IsEmpty(Matrix.Get(X,Y))) then
begin
// -2 is necessary since the x/y coordinates point to the center of the pattern,not the
// left top corner.
EmbedPositionAdjustmentPattern(X - 2,Y - 2,Matrix);
end;
end;
end;
end;
end;
{ TBitArray }
procedure TBitArray.AppendBits(Value,NumBits: Integer);
var
NumBitsLeft: Integer;
begin
if ((NumBits < 0) or (NumBits > 32)) then
begin
end;
EnsureCapacity(Size + NumBits);
for NumBitsLeft := NumBits downto 1 do
begin
AppendBit(((Value shr (NumBitsLeft - 1)) and $01) = 1);
end;
end;
constructor TBitArray.Create(Size: Integer);
begin
Size := Size;
SetLength(Bits,(Size + 31) shr 5);
end;
constructor TBitArray.Create;
begin
Size := 0;
SetLength(Bits,1);
end;
function TBitArray.Get(I: Integer): Boolean;
begin
Result := (Bits[I shr 5] and (1 shl (I and $1F))) <> 0;
end;
function TBitArray.GetSize: Integer;
begin
Result := Size;
end;
function TBitArray.GetSizeInBytes: Integer;
begin
Result := (Size + 7) shr 3;
end;
procedure TBitArray.SetBit(Index: Integer);
begin
Bits[Index shr 5] := Bits[Index shr 5] or (1 shl (Index and $1F));
end;
procedure TBitArray.AppendBit(Bit: Boolean);
begin
EnsureCapacity(Size + 1);
if (Bit) then
begin
Bits[Size shr 5] := Bits[Size shr 5] or (1 shl (Size and $1F));
end;
Inc(Size);
end;
procedure TBitArray.ToBytes(BitOffset: Integer; Source: TByteArray;
Offset,NumBytes: Integer);
var
I: Integer;
J: Integer;
TheByte: Integer;
begin
for I := 0 to NumBytes - 1 do
begin
TheByte := 0;
for J := 0 to 7 do
begin
if (Get(BitOffset)) then
begin
TheByte := TheByte or (1 shl (7 - J));
end;
Inc(BitOffset);
end;
Source[Offset + I] := TheByte;
end;
end;
procedure TBitArray.XorOperation(Other: TBitArray);
var
I: Integer;
begin
if (Length(Bits) = Length(Other.Bits)) then
begin
for I := 0 to Length(Bits) - 1 do
begin
// The last byte could be incomplete (i.e. not have 8 bits in
// it) but there is no problem since 0 XOR 0 == 0.
Bits[I] := Bits[I] xor Other.Bits[I];
end;
end;
end;
procedure TBitArray.AppendBitArray(NewBitArray: TBitArray);
var
OtherSize: Integer;
I: Integer;
begin
OtherSize := NewBitArray.GetSize;
EnsureCapacity(Size + OtherSize);
for I := 0 to OtherSize - 1 do
begin
AppendBit(NewBitArray.Get(I));
end;
end;
procedure TBitArray.EnsureCapacity(Size: Integer);
begin
if (Size > (Length(Bits) shl 5)) then
begin
SetLength(Bits,Size);
end;
end;
{ TErrorCorrectionLevel }
procedure TErrorCorrectionLevel.Assign(Source: TErrorCorrectionLevel);
begin
Self.FBits := Source.FBits;
end;
function TErrorCorrectionLevel.Ordinal: Integer;
begin
Result := 0;
end;
{ TVersion }
class function TVersion.ChooseVersion(NumInputBits: Integer;
ecLevel: TErrorCorrectionLevel): TVersion;
var
VersionNum: Integer;
Version: TVersion;
NumBytes: Integer;
ECBlocks: TECBlocks;
NumECBytes: Integer;
NumDataBytes: Integer;
TotalInputBytes: Integer;
begin
Result := nil;
// In the following comments,we use numbers of Version 7-H.
for VersionNum := 1 to 40 do
begin
Version := TVersion.GetVersionForNumber(VersionNum);
// numBytes = 196
NumBytes := Version.GetTotalCodewords;
// getNumECBytes = 130
ECBlocks := Version.GetECBlocksForLevel(ecLevel);
NumECBytes := ECBlocks.GetTotalECCodewords;
// getNumDataBytes = 196 - 130 = 66
NumDataBytes := NumBytes - NumECBytes;
TotalInputBytes := (NumInputBits + 7) div 8;
if (NumDataBytes >= TotalInputBytes) then
begin
Result := Version;
Exit;
end
else
begin
Version.Free;
end;
end;
end;
constructor TVersion.Create(VersionNumber: Integer;
AlignmentPatternCenters: array of Integer; ECBlocks1,ECBlocks4: TECBlocks);
var
Total: Integer;
ECBlock: TECB;
ECBArray: TECBArray;
I: Integer;
begin
Self.VersionNumber := VersionNumber;
SetLength(Self.AlignmentPatternCenters,Length(AlignmentPatternCenters));
if (Length(AlignmentPatternCenters) > 0) then
begin
Move(AlignmentPatternCenters[0],Self.AlignmentPatternCenters[0],Length(AlignmentPatternCenters) * SizeOf(Integer));
end;
SetLength(ECBlocks,4);
ECBlocks[0] := ECBlocks1;
ECBlocks[1] := ECBlocks2;
ECBlocks[2] := ECBlocks3;
ECBlocks[3] := ECBlocks4;
Total := 0;
ECCodewords := ECBlocks1.GetECCodewordsPerBlock;
ECBArray := ECBlocks1.GetECBlocks;
for I := 0 to Length(ECBArray) - 1 do
begin
ECBlock := ECBArray[I];
Inc(Total,ECBlock.GetCount * (ECBlock.GetDataCodewords + ECCodewords));
end;
TotalCodewords := Total;
end;
destructor TVersion.Destroy;
var
X: Integer;
begin
for X := 0 to Length(ECBlocks) - 1 do
begin
ECBlocks[X].Free;
end;
inherited;
end;
function TVersion.GetDimensionForVersion: Integer;
begin
Result := 17 + 4 * VersionNumber;
end;
function TVersion.GetECBlocksForLevel(ecLevel: TErrorCorrectionLevel)
: TECBlocks;
begin
Result := ECBlocks[ecLevel.Ordinal];
end;
function TVersion.GetTotalCodewords: Integer;
begin
Result := TotalCodewords;
end;
class function TVersion.GetVersionForNumber(VersionNum: Integer): TVersion;
begin
if (VersionNum = 1) then
begin
Result := TVersion.Create(1,[],TECBlocks.Create(7,TECB.Create(1,19)),TECBlocks.Create(10,16)),TECBlocks.Create(13,13)),TECBlocks.Create(17,9)));
end
else if (VersionNum = 2) then
begin
Result := TVersion.Create(2,[6,18],34)),TECBlocks.Create(16,28)),TECBlocks.Create(22,22)),TECBlocks.Create(28,16)));
end
else if (VersionNum = 3) then
begin
Result := TVersion.Create(3,22],TECBlocks.Create(15,55)),TECBlocks.Create(26,44)),TECBlocks.Create(18,TECB.Create(2,17)),13)));
end
else if (VersionNum = 4) then
begin
Result := TVersion.Create(4,26],TECBlocks.Create(20,80)),32)),24)),TECB.Create(4,9)));
end
else if (VersionNum = 5) then
begin
Result := TVersion.Create(5,30],108)),TECBlocks.Create(24,43)),15),11),12)));
end
else if (VersionNum = 6) then
begin
Result := TVersion.Create(6,34],68)),27)),15)));
end
else if (VersionNum = 7) then
begin
Result := TVersion.Create(7,38],78)),31)),15)),14)));
end
else if (VersionNum = 8) then
begin
Result := TVersion.Create(8,42],97)),38),39)),18),15)));
end
else if (VersionNum = 9) then
begin
Result := TVersion.Create(9,46],TECBlocks.Create(30,116)),TECB.Create(3,36),37)),13)));
end
else if (VersionNum = 10) then
begin
Result := TVersion.Create(10,50],68),69)),43),TECB.Create(6,19),20)),16)));
end
else if (VersionNum = 11) then
begin
Result := TVersion.Create(11,54],81)),50),51)),22),23)),TECB.Create(8,13)));
end
else if (VersionNum = 12) then
begin
Result := TVersion.Create(12,58],92),93)),20),21)),TECB.Create(7,15)));
end
else if (VersionNum = 13) then
begin
Result := TVersion.Create(13,62],107)),37),38)),TECB.Create(12,12)));
end
else if (VersionNum = 14) then
begin
Result := TVersion.Create(14,66],115),40),TECB.Create(5,41)),TECB.Create(11,13)));
end
else if (VersionNum = 15) then
begin
Result := TVersion.Create(15,70],87),88)),41),42)),24),25)),13)));
end
else if (VersionNum = 16) then
begin
Result := TVersion.Create(16,74],98),99)),45),46)),TECB.Create(15,TECB.Create(13,16)));
end
else if (VersionNum = 17) then
begin
Result := TVersion.Create(17,78],107),TECB.Create(10,46),47)),TECB.Create(17,15)));
end
else if (VersionNum = 18) then
begin
Result := TVersion.Create(18,82],120),121)),TECB.Create(9,TECB.Create(19,15)));
end
else if (VersionNum = 19) then
begin
Result := TVersion.Create(19,86],113),114)),44),45)),21),TECB.Create(16,14)));
end
else if (VersionNum = 20) then
begin
Result := TVersion.Create(20,90],16)));
end
else if (VersionNum = 21) then
begin
Result := TVersion.Create(21,94],116),117)),17)));
end
else if (VersionNum = 22) then
begin
Result := TVersion.Create(22,98],111),112)),TECB.Create(34,13)));
end
else if (VersionNum = 23) then
begin
Result := TVersion.Create(23,102],121),122)),47),TECB.Create(14,48)),16)));
end
else if (VersionNum = 24) then
begin
Result := TVersion.Create(24,106],117),118)),TECB.Create(30,17)));
end
else if (VersionNum = 25) then
begin
Result := TVersion.Create(25,110],106),TECB.Create(22,16)));
end
else if (VersionNum = 26) then
begin
Result := TVersion.Create(26,114],114),115)),TECB.Create(28,TECB.Create(33,17)));
end
else if (VersionNum = 27) then
begin
Result := TVersion.Create(27,118],122),123)),23),TECB.Create(26,16)));
end
else if (VersionNum = 28) then
begin
Result := TVersion.Create(28,122],TECB.Create(23,TECB.Create(31,16)));
end
else if (VersionNum = 29) then
begin
Result := TVersion.Create(29,126],TECB.Create(21,TECB.Create(37,16)));
end
else if (VersionNum = 30) then
begin
Result := TVersion.Create(30,130],TECB.Create(25,16)));
end
else if (VersionNum = 31) then
begin
Result := TVersion.Create(31,134],TECB.Create(29,TECB.Create(42,16)));
end
else if (VersionNum = 32) then
begin
Result := TVersion.Create(32,138],TECB.Create(35,16)));
end
else if (VersionNum = 33) then
begin
Result := TVersion.Create(33,142],TECB.Create(46,16)));
end
else if (VersionNum = 34) then
begin
Result := TVersion.Create(34,146],TECB.Create(44,TECB.Create(59,17)));
end
else if (VersionNum = 35) then
begin
Result := TVersion.Create(35,150],TECB.Create(39,TECB.Create(41,16)));
end
else if (VersionNum = 36) then
begin
Result := TVersion.Create(36,154],TECB.Create(64,16)));
end
else if (VersionNum = 37) then
begin
Result := TVersion.Create(37,158],TECB.Create(49,TECB.Create(24,16)));
end
else if (VersionNum = 38) then
begin
Result := TVersion.Create(38,162],TECB.Create(18,TECB.Create(32,TECB.Create(48,16)));
end
else if (VersionNum = 39) then
begin
Result := TVersion.Create(39,166],TECB.Create(20,TECB.Create(40,TECB.Create(43,TECB.Create(67,16)));
end
else if (VersionNum = 40) then
begin
Result := TVersion.Create(40,170],118),119)),TECB.Create(61,16)));
end
else
begin
Result := nil;
end;
end;
{ TMaskUtil }
// Return the mask bit for "getMaskPattern" at "x" and "y". See 8.8 of JISX0510:2004 for mask
// pattern conditions.
function TMaskUtil.GetDataMaskBit(MaskPattern,Y: Integer): Boolean;
var
Intermediate: Integer;
Temp: Integer;
begin
Intermediate := 0;
if ((MaskPattern >= 0) and (MaskPattern < NUM_MASK_PATTERNS)) then
begin
case (MaskPattern) of
0:
Intermediate := (Y + X) and 1;
1:
Intermediate := Y and 1;
2:
Intermediate := X mod 3;
3:
Intermediate := (Y + X) mod 3;
4:
Intermediate := ((Y shr 1) + (X div 3)) and 1;
5:
begin
Temp := Y * X;
Intermediate := (Temp and 1) + (Temp mod 3);
end;
6:
begin
Temp := Y * X;
Intermediate := ((Temp and 1) + (Temp mod 3)) and 1;
end;
7:
begin
Temp := Y * X;
Intermediate := ((Temp mod 3) + ((Y + X) and 1)) and 1;
end;
end;
end;
Result := Intermediate = 0;
end;
{ TECBlocks }
constructor TECBlocks.Create(ECCodewordsPerBlock: Integer; ECBlocks: TECB);
begin
Self.ECCodewordsPerBlock := ECCodewordsPerBlock;
SetLength(Self.ECBlocks,1);
Self.ECBlocks[0] := ECBlocks;
end;
constructor TECBlocks.Create(ECCodewordsPerBlock: Integer;
ECBlocks1,ECBlocks2: TECB);
begin
Self.ECCodewordsPerBlock := ECCodewordsPerBlock;
SetLength(Self.ECBlocks,2);
ECBlocks[0] := ECBlocks1;
ECBlocks[1] := ECBlocks2;
end;
destructor TECBlocks.Destroy;
var
X: Integer;
begin
for X := 0 to Length(ECBlocks) - 1 do
begin
ECBlocks[X].Free;
end;
inherited;
end;
function TECBlocks.GetECBlocks: TECBArray;
begin
Result := ECBlocks;
end;
function TECBlocks.GetECCodewordsPerBlock: Integer;
begin
Result := ECCodewordsPerBlock;
end;
function TECBlocks.GetNumBlocks: Integer;
var
Total: Integer;
I: Integer;
begin
Total := 0;
for I := 0 to Length(ECBlocks) - 1 do
begin
Inc(Total,ECBlocks[I].GetCount);
end;
Result := Total;
end;
function TECBlocks.GetTotalECCodewords: Integer;
begin
Result := ECCodewordsPerBlock * GetNumBlocks;
end;
{ TBlockPair }
constructor TBlockPair.Create(BA1,BA2: TByteArray);
begin
FDataBytes := BA1;
FErrorCorrectionBytes := BA2;
end;
function TBlockPair.GetDataBytes: TByteArray;
begin
Result := FDataBytes;
end;
function TBlockPair.GetErrorCorrectionBytes: TByteArray;
begin
Result := FErrorCorrectionBytes;
end;
{ TReedSolomonEncoder }
function TReedSolomonEncoder.BuildGenerator(Degree: Integer): TGenericGFPoly;
var
LastGenerator: TGenericGFPoly;
NextGenerator: TGenericGFPoly;
Poly: TGenericGFPoly;
D: Integer;
CA: TIntegerArray;
begin
if (Degree >= FCachedGenerators.Count) then
begin
LastGenerator := TGenericGFPoly
(FCachedGenerators[FCachedGenerators.Count - 1]);
for D := FCachedGenerators.Count to Degree do
begin
SetLength(CA,2);
CA[0] := 1;
CA[1] := FField.Exp(D - 1 + FField.GetGeneratorBase);
Poly := TGenericGFPoly.Create(FField,CA);
NextGenerator := LastGenerator.Multiply(Poly);
FCachedGenerators.Add(NextGenerator);
LastGenerator := NextGenerator;
end;
end;
Result := TGenericGFPoly(FCachedGenerators[Degree]);
end;
constructor TReedSolomonEncoder.Create(AField: TGenericGF);
var
GenericGFPoly: TGenericGFPoly;
IntArray: TIntegerArray;
begin
FField := AField;
// Contents of FCachedGenerators will be freed by FGenericGF.Destroy
FCachedGenerators := TObjectList<TGenericGFPoly>.Create(False);
SetLength(IntArray,1);
IntArray[0] := 1;
GenericGFPoly := TGenericGFPoly.Create(AField,IntArray);
FCachedGenerators.Add(GenericGFPoly);
end;
destructor TReedSolomonEncoder.Destroy;
begin
FCachedGenerators.Free;
inherited;
end;
procedure TReedSolomonEncoder.Encode(ToEncode: TIntegerArray; ECBytes: Integer);
var
DataBytes: Integer;
Generator: TGenericGFPoly;
InfoCoefficients: TIntegerArray;
Info: TGenericGFPoly;
Remainder: TGenericGFPoly;
Coefficients: TIntegerArray;
NumZeroCoefficients: Integer;
I: Integer;
begin
SetLength(Coefficients,0);
if (ECBytes > 0) then
begin
DataBytes := Length(ToEncode) - ECBytes;
if (DataBytes > 0) then
begin
Generator := BuildGenerator(ECBytes);
SetLength(InfoCoefficients,DataBytes);
InfoCoefficients := Copy(ToEncode,DataBytes);
Info := TGenericGFPoly.Create(FField,InfoCoefficients);
Info := Info.MultiplyByMonomial(ECBytes,1);
Remainder := Info.Divide(Generator)[1];
Coefficients := Remainder.GetCoefficients;
NumZeroCoefficients := ECBytes - Length(Coefficients);
for I := 0 to NumZeroCoefficients - 1 do
begin
ToEncode[DataBytes + I] := 0;
end;
Move(Coefficients[0],ToEncode[DataBytes + NumZeroCoefficients],Length(Coefficients) * SizeOf(Integer));
end;
end;
end;
{ TECB }
constructor TECB.Create(Count,DataCodewords: Integer);
begin
Self.Count := Count;
Self.DataCodewords := DataCodewords;
end;
function TECB.GetCount: Integer;
begin
Result := Count;
end;
function TECB.GetDataCodewords: Integer;
begin
Result := DataCodewords;
end;
{ TGenericGFPoly }
function TGenericGFPoly.AddOrSubtract(Other: TGenericGFPoly): TGenericGFPoly;
var
SmallerCoefficients: TIntegerArray;
LargerCoefficients: TIntegerArray;
Temp: TIntegerArray;
SumDiff: TIntegerArray;
LengthDiff: Integer;
I: Integer;
begin
SetLength(SmallerCoefficients,0);
SetLength(LargerCoefficients,0);
SetLength(Temp,0);
SetLength(SumDiff,0);
Result := nil;
if (Assigned(Other)) then
begin
if (FField = Other.FField) then
begin
if (IsZero) then
begin
Result := Other;
Exit;
end;
if (Other.IsZero) then
begin
Result := Self;
Exit;
end;
SmallerCoefficients := FCoefficients;
LargerCoefficients := Other.Coefficients;
if (Length(SmallerCoefficients) > Length(LargerCoefficients)) then
begin
Temp := SmallerCoefficients;
SmallerCoefficients := LargerCoefficients;
LargerCoefficients := Temp;
end;
SetLength(SumDiff,Length(LargerCoefficients));
LengthDiff := Length(LargerCoefficients) - Length(SmallerCoefficients);
// Copy high-order terms only found in higher-degree polynomial‘s coefficients
if (LengthDiff > 0) then
begin
// SumDiff := Copy(LargerCoefficients,LengthDiff);
Move(LargerCoefficients[0],SumDiff[0],LengthDiff * SizeOf(Integer));
end;
for I := LengthDiff to Length(LargerCoefficients) - 1 do
begin
SumDiff[I] := TGenericGF.AddOrSubtract
(SmallerCoefficients[I - LengthDiff],LargerCoefficients[I]);
end;
Result := TGenericGFPoly.Create(FField,SumDiff);
end;
end;
end;
function TGenericGFPoly.Coefficients: TIntegerArray;
begin
Result := FCoefficients;
end;
constructor TGenericGFPoly.Create(AField: TGenericGF;
ACoefficients: TIntegerArray);
var
CoefficientsLength: Integer;
FirstNonZero: Integer;
begin
FField := AField;
SetLength(FField.FPolyList,Length(FField.FPolyList) + 1);
FField.FPolyList[Length(FField.FPolyList) - 1] := Self;
CoefficientsLength := Length(ACoefficients);
if ((CoefficientsLength > 1) and (ACoefficients[0] = 0)) then
begin
// Leading term must be non-zero for anything except the constant polynomial "0"
FirstNonZero := 1;
while ((FirstNonZero < CoefficientsLength) and
(ACoefficients[FirstNonZero] = 0)) do
begin
Inc(FirstNonZero);
end;
if (FirstNonZero = CoefficientsLength) then
begin
FCoefficients := AField.GetZero.Coefficients;
end
else
begin
SetLength(FCoefficients,CoefficientsLength - FirstNonZero);
FCoefficients := Copy(ACoefficients,FirstNonZero,Length(FCoefficients));
end;
end
else
begin
FCoefficients := ACoefficients;
end;
end;
destructor TGenericGFPoly.Destroy;
begin
Self.FField := FField;
inherited;
end;
function TGenericGFPoly.Divide(Other: TGenericGFPoly): TGenericGFPolyArray;
var
Quotient: TGenericGFPoly;
Remainder: TGenericGFPoly;
DenominatorLeadingTerm: Integer;
InverseDenominatorLeadingTerm: Integer;
DegreeDifference: Integer;
Scale: Integer;
Term: TGenericGFPoly;
IterationQuotient: TGenericGFPoly;
begin
SetLength(Result,0);
if ((FField = Other.FField) and (not Other.IsZero)) then
begin
Quotient := FField.GetZero;
Remainder := Self;
DenominatorLeadingTerm := Other.GetCoefficient(Other.GetDegree);
InverseDenominatorLeadingTerm := FField.Inverse(DenominatorLeadingTerm);
while ((Remainder.GetDegree >= Other.GetDegree) and
(not Remainder.IsZero)) do
begin
DegreeDifference := Remainder.GetDegree - Other.GetDegree;
Scale := FField.Multiply(Remainder.GetCoefficient(Remainder.GetDegree),InverseDenominatorLeadingTerm);
Term := Other.MultiplyByMonomial(DegreeDifference,Scale);
IterationQuotient := FField.BuildMonomial(DegreeDifference,Scale);
Quotient := Quotient.AddOrSubtract(IterationQuotient);
Remainder := Remainder.AddOrSubtract(Term);
end;
SetLength(Result,2);
Result[0] := Quotient;
Result[1] := Remainder;
end;
end;
function TGenericGFPoly.GetCoefficient(Degree: Integer): Integer;
begin
Result := FCoefficients[Length(FCoefficients) - 1 - Degree];
end;
function TGenericGFPoly.GetCoefficients: TIntegerArray;
begin
Result := FCoefficients;
end;
function TGenericGFPoly.GetDegree: Integer;
begin
Result := Length(FCoefficients) - 1;
end;
function TGenericGFPoly.IsZero: Boolean;
begin
Result := FCoefficients[0] = 0;
end;
function TGenericGFPoly.Multiply(Other: TGenericGFPoly): TGenericGFPoly;
var
ACoefficients: TIntegerArray;
BCoefficients: TIntegerArray;
Product: TIntegerArray;
ALength: Integer;
BLength: Integer;
I: Integer;
J: Integer;
ACoeff: Integer;
begin
SetLength(ACoefficients,0);
SetLength(BCoefficients,0);
Result := nil;
if (FField = Other.FField) then
begin
if (IsZero or Other.IsZero) then
begin
Result := FField.GetZero;
Exit;
end;
ACoefficients := FCoefficients;
ALength := Length(ACoefficients);
BCoefficients := Other.Coefficients;
BLength := Length(BCoefficients);
SetLength(Product,ALength + BLength - 1);
for I := 0 to ALength - 1 do
begin
ACoeff := ACoefficients[I];
for J := 0 to BLength - 1 do
begin
Product[I + J] := TGenericGF.AddOrSubtract(Product[I + J],FField.Multiply(ACoeff,BCoefficients[J]));
end;
end;
Result := TGenericGFPoly.Create(FField,Product);
end;
end;
function TGenericGFPoly.MultiplyByMonomial(Degree,Coefficient: Integer)
: TGenericGFPoly;
var
I: Integer;
Size: Integer;
Product: TIntegerArray;
begin
Result := nil;
if (Degree >= 0) then
begin
if (Coefficient = 0) then
begin
Result := FField.GetZero;
Exit;
end;
Size := Length(Coefficients);
SetLength(Product,Size + Degree);
for I := 0 to Size - 1 do
begin
Product[I] := FField.Multiply(FCoefficients[I],Coefficient);
end;
Result := TGenericGFPoly.Create(FField,Product);
end;
end;
{ TGenericGF }
class function TGenericGF.AddOrSubtract(A,B: Integer): Integer;
begin
Result := A xor B;
end;
function TGenericGF.BuildMonomial(Degree,Coefficient: Integer): TGenericGFPoly;
var
Coefficients: TIntegerArray;
begin
CheckInit();
if (Degree >= 0) then
begin
if (Coefficient = 0) then
begin
Result := FZero;
Exit;
end;
SetLength(Coefficients,Degree + 1);
Coefficients[0] := Coefficient;
Result := TGenericGFPoly.Create(Self,Coefficients);
end
else
begin
Result := nil;
end;
end;
procedure TGenericGF.CheckInit;
begin
if (not FInitialized) then
begin
Initialize;
end;
end;
constructor TGenericGF.Create(Primitive,B: Integer);
begin
FInitialized := False;
FPrimitive := Primitive;
FSize := Size;
FGeneratorBase := B;
if (FSize < 0) then
begin
Initialize;
end;
end;
class function TGenericGF.CreateQRCodeField256: TGenericGF;
begin
Result := TGenericGF.Create($011D,256,0);
end;
destructor TGenericGF.Destroy;
var
X: Integer;
Y: Integer;
begin
for X := 0 to Length(FPolyList) - 1 do
begin
if (Assigned(FPolyList[X])) then
begin
for Y := X + 1 to Length(FPolyList) - 1 do
begin
if (FPolyList[Y] = FPolyList[X]) then
begin
FPolyList[Y] := nil;
end;
end;
FPolyList[X].Free;
end;
end;
inherited;
end;
function TGenericGF.Exp(A: Integer): Integer;
begin
CheckInit;
Result := FExpTable[A];
end;
function TGenericGF.GetGeneratorBase: Integer;
begin
Result := FGeneratorBase;
end;
function TGenericGF.GetZero: TGenericGFPoly;
begin
CheckInit;
Result := FZero;
end;
procedure TGenericGF.Initialize;
var
X: Integer;
I: Integer;
CA: TIntegerArray;
begin
SetLength(FExpTable,FSize);
SetLength(FLogTable,FSize);
X := 1;
for I := 0 to FSize - 1 do
begin
FExpTable[I] := X;
X := X shl 1; // x = x * 2; we‘re assuming the generator alpha is 2
if (X >= FSize) then
begin
X := X xor FPrimitive;
X := X and (FSize - 1);
end;
end;
for I := 0 to FSize - 2 do
begin
FLogTable[FExpTable[I]] := I;
end;
// logTable[0] == 0 but this should never be used
SetLength(CA,1);
CA[0] := 0;
FZero := TGenericGFPoly.Create(Self,CA);
SetLength(CA,1);
CA[0] := 1;
FOne := TGenericGFPoly.Create(Self,CA);
FInitialized := True;
end;
function TGenericGF.Inverse(A: Integer): Integer;
begin
CheckInit;
if (A <> 0) then
begin
Result := FExpTable[FSize - FLogTable[A] - 1];
end
else
begin
Result := 0;
end;
end;
function TGenericGF.Multiply(A,B: Integer): Integer;
begin
CheckInit;
if ((A <> 0) and (B <> 0)) then
begin
Result := FExpTable[(FLogTable[A] + FLogTable[B]) mod (FSize - 1)];
end
else
begin
Result := 0;
end;
end;
function GenerateQRCode(const Input: string; EncodeOptions: Integer)
: T2DBooleanArray;
var
Encoder: TEncoder;
Level: TErrorCorrectionLevel;
QRCode: TQRCode;
X: Integer;
Y: Integer;
begin
Level := TErrorCorrectionLevel.Create;
Level.FBits := 1;
Encoder := TEncoder.Create;
QRCode := TQRCode.Create;
try
Encoder.Encode(Input,EncodeOptions,Level,QRCode);
if (Assigned(QRCode.FMatrix)) then
begin
SetLength(Result,QRCode.FMatrix.FHeight);
for Y := 0 to QRCode.FMatrix.FHeight - 1 do
begin
SetLength(Result[Y],QRCode.FMatrix.FWidth);
for X := 0 to QRCode.FMatrix.FWidth - 1 do
begin
Result[Y][X] := QRCode.FMatrix.Get(Y,X) = 1;
end;
end;
end;
finally
QRCode.Free;
Encoder.Free;
Level.Free;
end;
end;
{ TDelphiZXingQRCode }
constructor TDelphiZXingQRCode.Create;
begin
FData := ‘‘;
FEncoding := qrAuto;
FQuietZone := 4;
FRows := 0;
FColumns := 0;
end;
function TDelphiZXingQRCode.GetIsBlack(Row,Column: Integer): Boolean;
begin
Dec(Row,FQuietZone);
Dec(Column,FQuietZone);
if ((Row >= 0) and (Column >= 0) and (Row < (FRows - FQuietZone * 2)) and
(Column < (FColumns - FQuietZone * 2))) then
begin
Result := FElements[Column,Row];
end
else
begin
Result := False;
end;
end;
procedure TDelphiZXingQRCode.SetData(const NewData: string);
begin
if (FData <> NewData) then
begin
FData := NewData;
Update;
end;
end;
procedure TDelphiZXingQRCode.SetEncoding(NewEncoding: TQRCodeEncoding);
begin
if (FEncoding <> NewEncoding) then
begin
FEncoding := NewEncoding;
Update;
end;
end;
procedure TDelphiZXingQRCode.SetQuietZone(NewQuietZone: Integer);
begin
if ((FQuietZone <> NewQuietZone) and (NewQuietZone >= 0) and
(NewQuietZone <= 100)) then
begin
FQuietZone := NewQuietZone;
Update;
end;
end;
procedure TDelphiZXingQRCode.Update;
begin
FElements := GenerateQRCode(FData,Ord(FEncoding));
FRows := Length(FElements) + FQuietZone * 2;
FColumns := FRows;
end;
procedure TDelphiZXingQRCode.DrawQrcode(imgQRCode: TImage;
QRCode: TDelphiZXingQRCode);
const
downsizeQuality: Integer = 2;
// bigger value,slower rendering
var
Row,Column: Integer;
pixelColor: TAlphaColor;
vBitMapData: TBitmapData;
pixelCount,X: Integer;
columnPixel,rowPixel: Integer;
function GetPixelCount(AWidth,AHeight: Single): Integer;
begin
if QRCode.Rows > 0 then
Result := Trunc(Min(AWidth,AHeight)) div QRCode.Rows
else
Result := 0;
end;
begin
pixelCount := GetPixelCount(imgQRCode.Width,imgQRCode.Height);
imgQRCode.DisableInterpolation := False;
if imgQRCode.WrapMode = TImageWrapMode.iwStretch then
imgQRCode.WrapMode := TImageWrapMode.iwCenter;
imgQRCode.DisableInterpolation := True;
case imgQRCode.WrapMode of
TImageWrapMode.iwOriginal,TImageWrapMode.iwCenter:
begin
if pixelCount > 0 then
imgQRCode.Bitmap.SetSize(QRCode.Columns * pixelCount,QRCode.Rows * pixelCount);
end;
TImageWrapMode.iwFit:
begin
if pixelCount > 0 then
begin
imgQRCode.Bitmap.SetSize(QRCode.Columns * pixelCount *
downsizeQuality,QRCode.Rows * pixelCount * downsizeQuality);
pixelCount := pixelCount * downsizeQuality;
end;
end;
end;
try
imgQRCode.Bitmap.Canvas.Clear(TAlphaColors.White);
if pixelCount > 0 then
begin
if imgQRCode.Bitmap.Map(TMapAccess.maWrite,vBitMapData) then
begin
try
for Row := 0 to QRCode.Rows - 1 do
begin
for Column := 0 to QRCode.Columns - 1 do
begin
if (QRCode.IsBlack[Row,Column]) then
pixelColor := TAlphaColors.Black
else
pixelColor := TAlphaColors.White;
columnPixel := Column * pixelCount;
rowPixel := Row * pixelCount;
for X := 0 to pixelCount - 1 do
for Y := 0 to pixelCount - 1 do
vBitMapData.SetPixel(columnPixel + X,rowPixel + Y,pixelColor);
end;
end;
finally
imgQRCode.Bitmap.Unmap(vBitMapData);
end;
end;
end;
finally
end;
end;
end.
? https://www.cnblogs.com/qiufeng2014/p/4281761.html （编辑：李大同） 【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容! |
