├── .gitattributes
├── .gitignore
├── CHANGELOG-RUS.md
├── CHANGELOG.md
├── LICENSE.md
├── README-RUS.md
├── README.md
├── Source
├── DelphiZXIngQRCode.pas
├── QRGraphics.pas
├── QR_URL.pas
└── QR_Win1251.pas
└── TestApp
├── DelphiZXingQRCodeTestApp.dpr
├── DelphiZXingQRCodeTestApp.dproj
├── DelphiZXingQRCodeTestApp.exe
├── DelphiZXingQRCodeTestApp.res
├── DelphiZXingQRCodeTestAppMainForm.dfm
├── DelphiZXingQRCodeTestAppMainForm.pas
├── Lazarus-src.zip
└── qr.ico
/.gitattributes:
--------------------------------------------------------------------------------
1 | # Auto detect text files and perform LF normalization
2 | * text=auto
3 |
4 | # Custom for Visual Studio
5 | *.cs diff=csharp
6 | *.sln merge=union
7 | *.csproj merge=union
8 | *.vbproj merge=union
9 | *.fsproj merge=union
10 | *.dbproj merge=union
11 |
12 | # Standard to msysgit
13 | *.doc diff=astextplain
14 | *.DOC diff=astextplain
15 | *.docx diff=astextplain
16 | *.DOCX diff=astextplain
17 | *.dot diff=astextplain
18 | *.DOT diff=astextplain
19 | *.pdf diff=astextplain
20 | *.PDF diff=astextplain
21 | *.rtf diff=astextplain
22 | *.RTF diff=astextplain
23 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | #################
2 | ## Eclipse
3 | #################
4 |
5 | *.pydevproject
6 | .project
7 | .metadata
8 | bin/
9 | tmp/
10 | *.tmp
11 | *.bak
12 | *.swp
13 | *~.nib
14 | local.properties
15 | .classpath
16 | .settings/
17 | .loadpath
18 |
19 | # External tool builders
20 | .externalToolBuilders/
21 |
22 | # Locally stored "Eclipse launch configurations"
23 | *.launch
24 |
25 | # CDT-specific
26 | .cproject
27 |
28 | # PDT-specific
29 | .buildpath
30 |
31 |
32 | #################
33 | ## Visual Studio
34 | #################
35 |
36 | ## Ignore Visual Studio temporary files, build results, and
37 | ## files generated by popular Visual Studio add-ons.
38 |
39 | # User-specific files
40 | *.suo
41 | *.user
42 | *.sln.docstates
43 |
44 | # Build results
45 |
46 | [Dd]ebug/
47 | [Rr]elease/
48 | x64/
49 | build/
50 | [Bb]in/
51 | [Oo]bj/
52 |
53 | # MSTest test Results
54 | [Tt]est[Rr]esult*/
55 | [Bb]uild[Ll]og.*
56 |
57 | *_i.c
58 | *_p.c
59 | *.ilk
60 | *.meta
61 | *.obj
62 | *.pch
63 | *.pdb
64 | *.pgc
65 | *.pgd
66 | *.rsp
67 | *.sbr
68 | *.tlb
69 | *.tli
70 | *.tlh
71 | *.tmp
72 | *.tmp_proj
73 | *.log
74 | *.vspscc
75 | *.vssscc
76 | .builds
77 | *.pidb
78 | *.log
79 | *.scc
80 |
81 | # Visual C++ cache files
82 | ipch/
83 | *.aps
84 | *.ncb
85 | *.opensdf
86 | *.sdf
87 | *.cachefile
88 |
89 | # Visual Studio profiler
90 | *.psess
91 | *.vsp
92 | *.vspx
93 |
94 | # Guidance Automation Toolkit
95 | *.gpState
96 |
97 | # ReSharper is a .NET coding add-in
98 | _ReSharper*/
99 | *.[Rr]e[Ss]harper
100 |
101 | # TeamCity is a build add-in
102 | _TeamCity*
103 |
104 | # DotCover is a Code Coverage Tool
105 | *.dotCover
106 |
107 | # NCrunch
108 | *.ncrunch*
109 | .*crunch*.local.xml
110 |
111 | # Installshield output folder
112 | [Ee]xpress/
113 |
114 | # DocProject is a documentation generator add-in
115 | DocProject/buildhelp/
116 | DocProject/Help/*.HxT
117 | DocProject/Help/*.HxC
118 | DocProject/Help/*.hhc
119 | DocProject/Help/*.hhk
120 | DocProject/Help/*.hhp
121 | DocProject/Help/Html2
122 | DocProject/Help/html
123 |
124 | # Click-Once directory
125 | publish/
126 |
127 | # Publish Web Output
128 | *.Publish.xml
129 | *.pubxml
130 |
131 | # NuGet Packages Directory
132 | ## TODO: If you have NuGet Package Restore enabled, uncomment the next line
133 | #packages/
134 |
135 | # Windows Azure Build Output
136 | csx
137 | *.build.csdef
138 |
139 | # Windows Store app package directory
140 | AppPackages/
141 |
142 | # Others
143 | sql/
144 | *.Cache
145 | ClientBin/
146 | [Ss]tyle[Cc]op.*
147 | ~$*
148 | *~
149 | *.dbmdl
150 | *.[Pp]ublish.xml
151 | *.pfx
152 | *.publishsettings
153 |
154 | # RIA/Silverlight projects
155 | Generated_Code/
156 |
157 | # Backup & report files from converting an old project file to a newer
158 | # Visual Studio version. Backup files are not needed, because we have git ;-)
159 | _UpgradeReport_Files/
160 | Backup*/
161 | UpgradeLog*.XML
162 | UpgradeLog*.htm
163 |
164 | # SQL Server files
165 | App_Data/*.mdf
166 | App_Data/*.ldf
167 |
168 | #############
169 | ## Windows detritus
170 | #############
171 |
172 | # Windows image file caches
173 | Thumbs.db
174 | ehthumbs.db
175 |
176 | # Folder config file
177 | Desktop.ini
178 |
179 | # Recycle Bin used on file shares
180 | $RECYCLE.BIN/
181 |
182 | # Mac crap
183 | .DS_Store
184 |
185 |
186 | #############
187 | ## Python
188 | #############
189 |
190 | *.py[co]
191 |
192 | # Packages
193 | *.egg
194 | *.egg-info
195 | dist/
196 | build/
197 | eggs/
198 | parts/
199 | var/
200 | sdist/
201 | develop-eggs/
202 | .installed.cfg
203 |
204 | # Installer logs
205 | pip-log.txt
206 |
207 | # Unit test / coverage reports
208 | .coverage
209 | .tox
210 |
211 | #Translations
212 | *.mo
213 |
214 | #Mr Developer
215 | .mr.developer.cfg
216 |
217 | #############
218 | ## Delphi
219 | #############
220 |
221 | *.~ddp
222 | *.~dfm
223 | *.~pas
224 | *.~dpr
225 | *.~dsk
226 | *.dcu
--------------------------------------------------------------------------------
/CHANGELOG-RUS.md:
--------------------------------------------------------------------------------
1 | Список изменений
2 | ================
3 |
4 | По сравнению с оригинальным проектом DelphiZXingQRCode от Debenu были изменены следующие вещи:
5 |
6 | ## 1. Поддержка нестандартных кодировок, определяемых программистом ##
7 |
8 | Хотя стандарт QR фиксирует все возможные кодировки, иногда бывает нужно добавить какую-то специальную «псевдо-кодировку».
9 | Например, Сбербанк России рекомендует использовать Win-1251 или KOI-8 (которые в стандарте QR не предусмотрены). Бывают
10 | и другие ситуации. Скажем, удобно было бы реализовать возможность кодировать URL-адреса, содержащие нелатинские символы
11 | (которые заменяются UTF-8 кодами со знаком %). Для поддержки таких нетрадиционных способов кодирования были внесены
12 | следующие изменения:
13 |
14 | 1. Класс *TEncoder* и связанные с ним типы данных перемещены из секции *implementation* в секцию *interface* файла
15 | *DelphiZXIngQRCode.pas*.
16 | 2. Три метода класса *TEncoder* (*ChooseMode*, *FilterContent*, *AppendBytes*) перемещены в секцию *protected*
17 | и стали виртуальными. Так что теперь заинтересованный программист может добавлять собственные классы-кодировщики,
18 | просто производя потомков от класса *TEncoder* (ради чего всё и затевалось). Все остальные пункты из этого списка —
19 | лишь следствия этого решения.
20 | 3. Вместо перечислимого типа *TQRCodeEncoding* сделан набор целочисленных констант *ENCODING_…,* а класс
21 | *TDelphiZXingQRCode* получил новый метод *RegisterEncoder*. Теперь программист, создав собственный класс-кодировщик,
22 | может определить его как стандартный для новой кодировки (или даже для старой, если его что-то не устраивает). Для
23 | получения информации об определённых кодировщиках предусмотрен новый метод *GetEncoderClass*.
24 | 4. У компонента *TDelphiZXingQRCode* появилось свойство *FilteredData*, которое позволяет узнать, что именно
25 | записывается в QR-код (это полезно скорее для самоконтроля, поскольку входная строка преобразуется кодировщиком,
26 | и входные данные могут отличаться от записанных). У класса *TEncoder* доработан метод *Encode:* теперь он возвращает
27 | именно эту строку.
28 | 5. Удалена глобальная функция *GenerateQRCode*. Весь код теперь выполняется непосредственно внутри класса
29 | *TDelphiZXingQRCode* (метод *Update*, который по такому случаю перемещён в секцию *public* класса). Это, во-первых,
30 | проще, во-вторых, без этого манипулировать разными кодировщиками было бы неудобно.
31 | 6. Добавлены примеры кодировщиков, определённых программистом. Это *TWin1251Encoder* (кодировка Win-1251) в модуле
32 | *QR\_Win1251.pas* и *TURLEncoder* (кодирование URL с нелатинскими символами) в модуле *QR\_URL.pas*.
33 |
34 | ## 2. Уровень коррекции ошибок ##
35 |
36 | Вообще-то, он был в оригинальной библиотеке ZXing, но при портировании на Delphi его «сломали». Странно, что авторы
37 | за год так и не исправили эту ошибку сами, хотя она им определённо известна.
38 |
39 | 1. Добавлено свойство *TDelphiZXingQRCode.ErrorCorrectionOrdinal*. Это свойство перечислимого типа, соответствующего
40 | одному из четырёх уровней коррекции ошибок (L, M, H, Q).
41 | 2. Класс *TErrorCorrectionLevel* переписан (хотя что там было переписывать…).
42 |
43 | ## 3. Исключения ##
44 |
45 | DelphiZXingQRCode вообще почти не содержит каких-то обработок исключений. Например, если закодированная строка
46 | не влезает в отведённый размер, определённый стандартом QR-кодирования, то программа попросту выдаёт Access Violation.
47 | Мне это показалось неправильным, и я добавил класс-исключение *EQRMatrixTooLarge*.
48 |
49 | ## 4. Другие новые свойства, методы и события класса *TDelphiZXingQRCode* ##
50 |
51 | 1. У класса *TDelphiZXingQRCode* добавлены события *BeforeUpdate* и *AfterUpdate*, которые вызываются до и после
52 | генерации кода, соответственно. Первый позволяет, например, проверить входную строку, а второй — обеспечить перерисовку
53 | картинки с кодом после изменения.
54 | 2. Добавлены методы *BeginUpdate* и *EndUpdate*, которые позволяют временно заблокировать формирование матрицы при
55 | одновременном изменении большого количества свойств.
56 |
57 | ## 5. Новая глобальная настройка для кодировки по умолчанию ##
58 |
59 | Глобальная переменная *DefaultNonISOEncoding* — это кодировка по умолчанию для всех объектов типа *TDelphiZXIngQRCode*.
60 | Она применяется в том случае, когда свойство *Encoding* = ENCODING_AUTO, а кодируемая строка содержит символы, не
61 | являющиеся символами ISO (то есть латинскими буквами, цифрами и т.д.).
62 |
63 | По умолчанию используется ENCODING_UTF8_NOBOM, но программист может задать другое значение или вовсе придумать
64 | собственный способ кодирования (переопределив класс *TEncoder,* разумеется).
65 |
66 | ## 6. Добавлена поддержка Lazarus ##
67 |
68 | Внесены некоторые исправления для обеспечения совместимости с Lazarus (проверялось на версии 1.2.6 для Windows).
69 | Основные модули (*DelphiZXIngQRCode.pas*, *QR_URL.pas* и *QR_Win1251.pas*) компилируются без изменений, а вот в модуле
70 | *QRGraphics.pas* имеется одна мелкая неприятность: в стандартных модулях Lazarus (в частности, *Graphics.pas*)
71 | отсутствует поддержка класса *TMetafile*. Это можно исправить, например, подключив к проекту (и добавив в секцию *uses*
72 | модуля *QRGraphics.pas*) модуль *TADrawerWMF.pas*, поставляемый в составе библиотеки TAChart, которая устанавливается
73 | вместе с Lazarus. Путь к файлу выглядит как-то так (под Windows): *…\lazarus\components\tachart\tadrawerwmf.pas.*
74 | В этом случае для компиляции модуля *QRGraphics.pas* достаточно убрать (закомментировать) в процедуре *MakeMetafile*
75 | строку *Enhanced := True;* (эта реализация класса *TMetafile* её не поддерживает).
76 |
77 | Исправленный для совместимости с Lazarus исходник демонстрационного проекта также прилагается
78 | (файл *TestApp\Lazarus-src.zip*).
79 |
80 | ## 7. Исправление ошибок, рефакторинг и другие улучшения кода ##
81 |
82 | * Много рефакторинга для улучшения читаемости кода. Удалены ненужные скобки после *if* (наследие Java), бесполезные
83 | пары *begin / end* вокруг одной строки и т.п.
84 |
85 | -------------------------
86 |
87 | **Пример**
88 |
89 | было:
90 |
91 |
if (I = 1) then
92 | begin
93 | Exit;
94 | end;
95 |
96 |
97 | стало:
98 |
99 |
if I = 1 then
100 | Exit;
101 |
102 |
103 | -------------------------
104 |
105 | Самый объёмный пример: в одной подпрограмме заменил 40 подряд идущих *if … then … else if … then … else* на один оператор
106 | *case,* которому там самое место.
107 |
108 | Итог: в общей сложности объём кода сократился более чем на 200 строк, несмотря на добавленные свойства, методы и прочее
109 | перечисленное выше.
110 |
111 | * В нескольких местах пришлось разбираться с пустыми блоками *if / then* и *try / except* (фрагменты кода, которые должны
112 | были быть внутри, оказались снаружи этих блоков).
113 |
114 | * Удалено пустое объявление класса *TCharacterSetECI*.
115 |
116 | * Внутренняя структура классов (*private / public / protected* поля, свойства и методы) была несколько хаотична. «Причесал».
117 |
118 | * Удалил класс *TMaskUtil*, который состоял из единственного метода (*GetDataMaskBit*), вызывавшегося только в одном месте.
119 | Метод перенесён туда, где он нужен. Аналогично удалил функцию *GetModeBits*, потому что она состояла из одной простейшей
120 | строчки и вызывалась только в одном месте, куда я эту строчку и перенёс.
121 |
122 | * Класс *TECB* заменён на запись, так как он состоял всего из двух полей и методов для их чтения. Бесполезная вещь, как
123 | мне кажется.
124 |
125 | * Добавлено много поясняющих комментариев в тех местах, где что-то было особенно непонятно.
126 |
127 | * Возможно что-то ещё, о чём я уже не могу вспомнить.
128 |
129 | ## 8. Модуль *QRGraphics.pas* ##
130 |
131 | В DelphiZXingQRCode никаких средств преобразования QR-кода в графическое представление не было. Только
132 | демонстрационный пример показывал, как сгенерировать простейшую битовую матрицу. Мне этого показалось мало.
133 |
134 | Модуль *QRGraphics.pas* содержит несколько функций: для отрисовки QR-кода на заданной канве (*TCanvas*), для генерации
135 | битовой матрицы и для создания метафайла.
136 |
137 | Небольшой бонус: в демонстрационном примере имеется кусочек кода, который сохраняет картинку в формате JPEG (обработчик
138 | кнопки *btnSaveToFile*).
139 |
140 | ## 9. Демонстрационная программа *TestApp* ##
141 |
142 | Эта программа настолько переделана, что можно говорить скорее о создании с нуля. Фактически её теперь можно даже
143 | использовать как отдельное приложение для генерации различных QR-кодов. В частности, она умеет сохранять файлы
144 | в форматах BMP, EMF и JPEG.
145 |
--------------------------------------------------------------------------------
/CHANGELOG.md:
--------------------------------------------------------------------------------
1 | Changelog
2 | =========
3 |
4 | All changes listed here are given in comparison with the original project DelphiZXingQRCode from Debenu (see README.md).
5 |
6 | ## 1. Support for non-standard programmer-defined encodings ##
7 |
8 | Although the QR Code standard claims a list of possible encodings, sometimes a programmer needs to add something special.
9 | For example, Sberbank of Russia recommends using Win-1251 or KOI-8 encodings that are not provided by the standard.
10 | Or it would be convenient to implement the ability to encode URL-addresses containing non-Latin characters (which are
11 | usually replaced with the % sign and UTF-8 code). Some code changes were made to support such non-standard encoding ways:
12 |
13 | 1. *TEncoder* class and everything related has been moved from the *implementation* section of *DelphiZXIngQRCode*
14 | unit into *interface*.
15 | 2. Three methods of *TEncoder* class (*ChooseMode*, *FilterContent*, *AppendBytes*) have been moved into the
16 | *protected* section and have become virtual. Now a programmer is able to add their own encoding classes as *TEncoder*
17 | descendants. The following items in this list are the result of this.
18 | 3. Enumerated type *TQRCodeEncoding* is replaced by a set of integer constants *ENCODING_…* The class
19 | *TDelphiZXingQRCode* has a new method *RegisterEncoder*. So after creating a *TEncoder* descendant, a programmer
20 | can define it as a standard encoder for the new character set (or even for the old one if needed). The new method
21 | *GetEncoderClass* provides information about any registered encoder.
22 | 4. The new *TDelphiZXingQRCode* class property *FilteredData* contains a string that is actually written in the QR Code
23 | (useful for self-control as the input string is converted by the encoder, and the input data may differ from
24 | the recorded one). *TEncoder* class' method *Encode* was upgraded. It now returns this string.
25 | 5. The global function *GenerateQRCode* has been removed. All of its functionality is now implemented inside the
26 | *TDelphiZXingQRCode* class (*Update* method, which has made *public*). This simplifies the encoders management.
27 | 6. Examples of programmer-defined encoders have been added: *TWin1251Encoder* (Win-1251 encoding) in
28 | *QR\_Win1251.pas* and *TURLEncoder* (URL with non-Latin characters) in *QR\_URL.pas*.
29 |
30 | ## 2. Error correction level ##
31 |
32 | It actually existed in the original library ZXing, but had been incorrectly ported to Delphi. It is strange that
33 | after a year the authors have not corrected this bug themselves.
34 |
35 | 1. Property *TDelphiZXingQRCode.ErrorCorrectionOrdinal* has been added. It has the enumerated type related to four
36 | levels of error correction (L, M, H, Q).
37 | 2. Class *TErrorCorrectionLevel* has been rewritten.
38 |
39 | ## 3. Exception handling ##
40 |
41 | DelphiZXingQRCode doesn't contain a lot of exception handling. For example, if the input string exceeds the maximum possible
42 | length defined by the QR Code standard, Access Violation is raised. I think this behavior is not correct, and I added
43 | exception class *EQRMatrixTooLarge*.
44 |
45 | ## 4. Other new properties, methods, and events for *TDelphiZXingQRCode* class ##
46 |
47 | 1. *BeforeUpdate* and *AfterUpdate* events have been added to *TDelphiZXingQRCode* class. They are called before and
48 | after QR Code generation, accordingly. The first one allows, for example, to check input string, and the second can
49 | refresh the on-screen image.
50 | 2. Methods *BeginUpdate* and *EndUpdate* have been added to temporarily lock QR Code updates when property values
51 | change.
52 |
53 | ## 5. New global setting for non-ISO characters ##
54 |
55 | The global variable *DefaultNonISOEncoding* is the default encoding for any *TDelphiZXIngQRCode* object when its property
56 | Encoding = ENCODING_AUTO and the data string contains non-ISO characters.
57 |
58 | The default value is ENCODING_UTF8_NOBOM, but the programmer can change this value or even define their own encoding
59 | with custom *TEncoder* descendant.
60 |
61 | ## 6. Support for Lazarus ##
62 |
63 | The main units (*DelphiZXIngQRCode.pas*, *QR_URL.pas*, and *QR_Win1251.pas*) are fully compatible with Lazarus (they have
64 | been tested with Lazarus 1.2.6 for Windows). The unit *QRGraphics.pas* is mostly compatible. Details see in comments
65 | inside the unit.
66 |
67 | Demo application source for Lazarus included (TestApp\Lazarus-src.zip).
68 |
69 | ## 7. Minor bug fixes, refactoring, and other improvements ##
70 |
71 | * Many refactorings have been done to improve the source code readability. Redundant parentheses after *if* and
72 | unneeded *begin / end* pairs around single line have been removed, etc.
73 |
74 | -------------------------
75 |
76 | **Example**
77 |
78 | before:
79 |
80 |
if (I = 1) then
81 | begin
82 | Exit;
83 | end;
84 |
85 |
86 | after:
87 |
88 |
if I = 1 then
89 | Exit;
90 |
91 |
92 | -------------------------
93 |
94 | The biggest example was this: 40 sequential *if … then … else if … then … else* constructs have been replaced with single
95 | *case*.
96 |
97 | Thus the total source code has been shortened by more than 200 lines, despite the addition of properties, methods, and other
98 | (see above).
99 |
100 | * Empty *if / then* and *try / except* blocks have been corrected (code fragments that were supposed to be inside, were
101 | located outside these blocks).
102 |
103 | * Empty class *TCharacterSetECI* definition has been removed.
104 |
105 | * There was some confusion in the structure of classes (*private / public / protected* fields, methods, and properties).
106 | Corrected.
107 |
108 | * Class *TMaskUtil* has been removed. It contained one single method (*GetDataMaskBit*) that was used in one place.
109 | This method was placed there. Function *GetModeBits* was deleted because it contained a single line of
110 | code, which I put in the right place.
111 |
112 | * Class *TECB* has been replaced by a record type because it only contained a pair of fields and methods
113 | to read them. Useless thing, I think.
114 |
115 | * Some explanatory comments have been added in those places where something was particularly unclear.
116 |
117 | * …maybe something else that I forgot.
118 |
119 | ## 8. Unit *QRGraphics.pas* ##
120 |
121 | In DelphiZXingQRCode there was no code to create an image from the QR Code. Only a demo application could generate a simple bitmap.
122 | I think that it is not enough.
123 |
124 | *QRGraphics.pas* unit contains several functions to draw the QR Code on a given canvas (*TCanvas*) and to generate either
125 | a bitmap or a metafile.
126 |
127 | A little bonus: there is a code in the demo application that saves the image in JPEG format (see *btnSaveToFile.OnClick* handler).
128 |
129 | ## 9. Demo application *TestApp* ##
130 |
131 | This program is so altered that it can be considered as created from scratch. In fact, it is now possible to use it as
132 | a standalone application to generate different QR Codes. It also can save the image to BMP, EMF, or JPEG files.
133 |
--------------------------------------------------------------------------------
/LICENSE.md:
--------------------------------------------------------------------------------
1 | Apache License
2 | Version 2.0, January 2004
3 | http://www.apache.org/licenses/
4 |
5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
6 |
7 | 1. Definitions.
8 |
9 | "License" shall mean the terms and conditions for use, reproduction,
10 | and distribution as defined by Sections 1 through 9 of this document.
11 |
12 | "Licensor" shall mean the copyright owner or entity authorized by
13 | the copyright owner that is granting the License.
14 |
15 | "Legal Entity" shall mean the union of the acting entity and all
16 | other entities that control, are controlled by, or are under common
17 | control with that entity. For the purposes of this definition,
18 | "control" means (i) the power, direct or indirect, to cause the
19 | direction or management of such entity, whether by contract or
20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the
21 | outstanding shares, or (iii) beneficial ownership of such entity.
22 |
23 | "You" (or "Your") shall mean an individual or Legal Entity
24 | exercising permissions granted by this License.
25 |
26 | "Source" form shall mean the preferred form for making modifications,
27 | including but not limited to software source code, documentation
28 | source, and configuration files.
29 |
30 | "Object" form shall mean any form resulting from mechanical
31 | transformation or translation of a Source form, including but
32 | not limited to compiled object code, generated documentation,
33 | and conversions to other media types.
34 |
35 | "Work" shall mean the work of authorship, whether in Source or
36 | Object form, made available under the License, as indicated by a
37 | copyright notice that is included in or attached to the work
38 | (an example is provided in the Appendix below).
39 |
40 | "Derivative Works" shall mean any work, whether in Source or Object
41 | form, that is based on (or derived from) the Work and for which the
42 | editorial revisions, annotations, elaborations, or other modifications
43 | represent, as a whole, an original work of authorship. For the purposes
44 | of this License, Derivative Works shall not include works that remain
45 | separable from, or merely link (or bind by name) to the interfaces of,
46 | the Work and Derivative Works thereof.
47 |
48 | "Contribution" shall mean any work of authorship, including
49 | the original version of the Work and any modifications or additions
50 | to that Work or Derivative Works thereof, that is intentionally
51 | submitted to Licensor for inclusion in the Work by the copyright owner
52 | or by an individual or Legal Entity authorized to submit on behalf of
53 | the copyright owner. For the purposes of this definition, "submitted"
54 | means any form of electronic, verbal, or written communication sent
55 | to the Licensor or its representatives, including but not limited to
56 | communication on electronic mailing lists, source code control systems,
57 | and issue tracking systems that are managed by, or on behalf of, the
58 | Licensor for the purpose of discussing and improving the Work, but
59 | excluding communication that is conspicuously marked or otherwise
60 | designated in writing by the copyright owner as "Not a Contribution."
61 |
62 | "Contributor" shall mean Licensor and any individual or Legal Entity
63 | on behalf of whom a Contribution has been received by Licensor and
64 | subsequently incorporated within the Work.
65 |
66 | 2. Grant of Copyright License. Subject to the terms and conditions of
67 | this License, each Contributor hereby grants to You a perpetual,
68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable
69 | copyright license to reproduce, prepare Derivative Works of,
70 | publicly display, publicly perform, sublicense, and distribute the
71 | Work and such Derivative Works in Source or Object form.
72 |
73 | 3. Grant of Patent License. Subject to the terms and conditions of
74 | this License, each Contributor hereby grants to You a perpetual,
75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable
76 | (except as stated in this section) patent license to make, have made,
77 | use, offer to sell, sell, import, and otherwise transfer the Work,
78 | where such license applies only to those patent claims licensable
79 | by such Contributor that are necessarily infringed by their
80 | Contribution(s) alone or by combination of their Contribution(s)
81 | with the Work to which such Contribution(s) was submitted. If You
82 | institute patent litigation against any entity (including a
83 | cross-claim or counterclaim in a lawsuit) alleging that the Work
84 | or a Contribution incorporated within the Work constitutes direct
85 | or contributory patent infringement, then any patent licenses
86 | granted to You under this License for that Work shall terminate
87 | as of the date such litigation is filed.
88 |
89 | 4. Redistribution. You may reproduce and distribute copies of the
90 | Work or Derivative Works thereof in any medium, with or without
91 | modifications, and in Source or Object form, provided that You
92 | meet the following conditions:
93 |
94 | (a) You must give any other recipients of the Work or
95 | Derivative Works a copy of this License; and
96 |
97 | (b) You must cause any modified files to carry prominent notices
98 | stating that You changed the files; and
99 |
100 | (c) You must retain, in the Source form of any Derivative Works
101 | that You distribute, all copyright, patent, trademark, and
102 | attribution notices from the Source form of the Work,
103 | excluding those notices that do not pertain to any part of
104 | the Derivative Works; and
105 |
106 | (d) If the Work includes a "NOTICE" text file as part of its
107 | distribution, then any Derivative Works that You distribute must
108 | include a readable copy of the attribution notices contained
109 | within such NOTICE file, excluding those notices that do not
110 | pertain to any part of the Derivative Works, in at least one
111 | of the following places: within a NOTICE text file distributed
112 | as part of the Derivative Works; within the Source form or
113 | documentation, if provided along with the Derivative Works; or,
114 | within a display generated by the Derivative Works, if and
115 | wherever such third-party notices normally appear. The contents
116 | of the NOTICE file are for informational purposes only and
117 | do not modify the License. You may add Your own attribution
118 | notices within Derivative Works that You distribute, alongside
119 | or as an addendum to the NOTICE text from the Work, provided
120 | that such additional attribution notices cannot be construed
121 | as modifying the License.
122 |
123 | You may add Your own copyright statement to Your modifications and
124 | may provide additional or different license terms and conditions
125 | for use, reproduction, or distribution of Your modifications, or
126 | for any such Derivative Works as a whole, provided Your use,
127 | reproduction, and distribution of the Work otherwise complies with
128 | the conditions stated in this License.
129 |
130 | 5. Submission of Contributions. Unless You explicitly state otherwise,
131 | any Contribution intentionally submitted for inclusion in the Work
132 | by You to the Licensor shall be under the terms and conditions of
133 | this License, without any additional terms or conditions.
134 | Notwithstanding the above, nothing herein shall supersede or modify
135 | the terms of any separate license agreement you may have executed
136 | with Licensor regarding such Contributions.
137 |
138 | 6. Trademarks. This License does not grant permission to use the trade
139 | names, trademarks, service marks, or product names of the Licensor,
140 | except as required for reasonable and customary use in describing the
141 | origin of the Work and reproducing the content of the NOTICE file.
142 |
143 | 7. Disclaimer of Warranty. Unless required by applicable law or
144 | agreed to in writing, Licensor provides the Work (and each
145 | Contributor provides its Contributions) on an "AS IS" BASIS,
146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
147 | implied, including, without limitation, any warranties or conditions
148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
149 | PARTICULAR PURPOSE. You are solely responsible for determining the
150 | appropriateness of using or redistributing the Work and assume any
151 | risks associated with Your exercise of permissions under this License.
152 |
153 | 8. Limitation of Liability. In no event and under no legal theory,
154 | whether in tort (including negligence), contract, or otherwise,
155 | unless required by applicable law (such as deliberate and grossly
156 | negligent acts) or agreed to in writing, shall any Contributor be
157 | liable to You for damages, including any direct, indirect, special,
158 | incidental, or consequential damages of any character arising as a
159 | result of this License or out of the use or inability to use the
160 | Work (including but not limited to damages for loss of goodwill,
161 | work stoppage, computer failure or malfunction, or any and all
162 | other commercial damages or losses), even if such Contributor
163 | has been advised of the possibility of such damages.
164 |
165 | 9. Accepting Warranty or Additional Liability. While redistributing
166 | the Work or Derivative Works thereof, You may choose to offer,
167 | and charge a fee for, acceptance of support, warranty, indemnity,
168 | or other liability obligations and/or rights consistent with this
169 | License. However, in accepting such obligations, You may act only
170 | on Your own behalf and on Your sole responsibility, not on behalf
171 | of any other Contributor, and only if You agree to indemnify,
172 | defend, and hold each Contributor harmless for any liability
173 | incurred by, or claims asserted against, such Contributor by reason
174 | of your accepting any such warranty or additional liability.
175 |
176 | END OF TERMS AND CONDITIONS
177 |
178 | APPENDIX: How to apply the Apache License to your work.
179 |
180 | To apply the Apache License to your work, attach the following
181 | boilerplate notice, with the fields enclosed by brackets "{}"
182 | replaced with your own identifying information. (Don't include
183 | the brackets!) The text should be enclosed in the appropriate
184 | comment syntax for the file format. We also recommend that a
185 | file or class name and description of purpose be included on the
186 | same "printed page" as the copyright notice for easier
187 | identification within third-party archives.
188 |
189 | Copyright {yyyy} {name of copyright owner}
190 |
191 | Licensed under the Apache License, Version 2.0 (the "License");
192 | you may not use this file except in compliance with the License.
193 | You may obtain a copy of the License at
194 |
195 | http://www.apache.org/licenses/LICENSE-2.0
196 |
197 | Unless required by applicable law or agreed to in writing, software
198 | distributed under the License is distributed on an "AS IS" BASIS,
199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
200 | See the License for the specific language governing permissions and
201 | limitations under the License.
202 |
203 |
--------------------------------------------------------------------------------
/README-RUS.md:
--------------------------------------------------------------------------------
1 | DelphiZXingQRCodeEx
2 | ===================
3 |
4 | DelphiZXingQRCodeEx — это набор классов Delphi для генерации QR-кодов. Исходный код был портирован на Delphi
5 | из проекта ZXing, который представляет собой библиотеку для работы с различными графическими кодами.
6 |
7 | Изначально код был портирован Кевином Ньюманом, главным разработчиком австралийской компании Debenu, ныне Foxit
8 | (проект называется *DelphiZXingQRCode* и доступен на GitHub, см. ссылки ниже). После этого он был доработан
9 | и изменён Михаилом Демидовым. Подробный список этих изменений приведён в файле CHANGELOG-RUS.md.
10 |
11 | **Наиболее принципиальные отличия такие:**
12 |
13 | 1. Исправлен уровень коррекции ошибок.
14 | 2. Добавлена возможность для определения собственных способов кодирования входных строк. В качестве примера реализованы
15 | кодирование Win-1251 (совместимое с требованиями Сбербанка РФ — это уже проверено) и кодирование URL (преобразование
16 | нелатинских символов в %-коды).
17 | 3. Добавлена обработка исключений, чтобы избежать Access Violation, когда входная строка слишком длинная.
18 | 4. Добавлен отдельный модуль для получения графического представления QR-кода в разных форматах (битовая матрица,
19 | метафайл).
20 | 5. Сохранена совместимость со старыми версиями Delphi (по крайней мере, до 7 включительно). Совместима с Lazarus
21 | (см. пункт 5 файла CHANGELOG-RUS.md или статью в блоге — раздел *Ссылки* ниже).
22 |
23 | Проект распространяется под той же лицензией Apache License (v2.0), что и оригинальная библиотека.
24 |
25 | # Ссылки #
26 |
27 | 1. [Проект DelphiZXingQRCode на GitHub](https://github.com/foxitsoftware/DelphiZXingQRCode)
28 | 2. [ZXing GitHub](https://github.com/zxing/zxing)
29 | 3. [Блог М. В. Демидова](http://mik-demidov.blogspot.ru)
30 | * [Статья в блоге про DelphiZXingQRCodeEx](http://mik-demidov.blogspot.ru/2014/12/qr-code.html)
31 |
32 | # Требования #
33 |
34 | Delphi 7 или новее (теоретически может компилироваться и в более старых версиях, на практике не проверялось
35 | за неимением оных).
36 |
37 | # Инструкция #
38 |
39 | В папке TestApp находится простой проект, который демонстрирует работу с классом TDelphiZXingQRCode (в т.ч. сохранение
40 | изображения в форматах BMP, JPEG и EMF).
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | DelphiZXingQRCodeEx
2 | ===================
3 |
4 | DelphiZXingQRCodeEx is a Delphi port of the QR Code functionality from ZXing, an open source barcode image processing
5 | library.
6 |
7 | The code was initially ported to Delphi by Senior Debenu Developer, Kevin Newman (project *DelphiZXingQRCode,* see links
8 | below). Then it was changed by Michael Demidov. The changes are listed in CHANGELOG.md.
9 |
10 | **The most fundamental differences are:**
11 |
12 | 1. Error correction level has been fixed.
13 | 2. Support for programmer-defined charsets. As an example, I implemented Win-1251 Russian charset and URL encoding (when
14 | non-Latin characters are represented as %-codes).
15 | 3. Exception handling has been added. There is no more Access Violation when input string is too long.
16 | 4. New *QRGraphics.pas* unit has been added that contains several functions to draw the QR Code on a given canvas (*TCanvas*) and
17 | to generate either a bitmap or a metafile.
18 | 5. Still compatible with older versions of Delphi (at least Delphi 7). Compatible with Lazarus (1.2.6, for Windows),
19 | see CHANGELOG.md (section 5).
20 |
21 | The port retains the original Apache License (v2.0).
22 |
23 | # Links #
24 |
25 | 1. [Original DelphiZXingQRCode GitHub](https://github.com/foxitsoftware/DelphiZXingQRCode)
26 | 2. [ZXing GitHub](https://github.com/zxing/zxing)
27 | 3. [Michael Demidov's blog](http://mik-demidov.blogspot.ru) (in Russian only, sorry)
28 |
29 | # Software Requirements #
30 |
31 | Delphi 7 or newer (I tested with Delphi 7 and XE3).
32 |
33 | # Getting Started #
34 |
35 | A sample Delphi project is provided in the TestApp folder to demonstrate how to use DelphiZXingQRCode.
--------------------------------------------------------------------------------
/Source/DelphiZXIngQRCode.pas:
--------------------------------------------------------------------------------
1 | unit DelphiZXingQRCode;
2 |
3 | // ZXing QRCode port to Delphi, by Debenu Pty Ltd
4 | // www.debenu.com
5 |
6 | // Some changes by Michael Demidov (see changelog in CHANGELOG.md file)
7 | // http://mik-demidov.blogspot.ru (the blog available in Russian only, sorry...)
8 | // e-mail: michael.v.demidov@gmail.com
9 | //
10 | // Unchanged Delphi source from Debenu can be found here:
11 | // https://github.com/debenu/DelphiZXingQRCode/
12 |
13 | // Original copyright notice
14 | (*
15 | * Copyright 2008 ZXing authors
16 | *
17 | * Licensed under the Apache License, Version 2.0 (the "License");
18 | * you may not use this file except in compliance with the License.
19 | * You may obtain a copy of the License at
20 | *
21 | * http://www.apache.org/licenses/LICENSE-2.0
22 | *
23 | * Unless required by applicable law or agreed to in writing, software
24 | * distributed under the License is distributed on an "AS IS" BASIS,
25 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
26 | * See the License for the specific language governing permissions and
27 | * limitations under the License.
28 | *)
29 |
30 | interface
31 |
32 | uses
33 | Contnrs, Classes;
34 |
35 | const
36 | // ----------------- encodings -----------------
37 | ENCODING_AUTO = 0;
38 | ENCODING_NUMERIC = 1;
39 | ENCODING_ALPHANUMERIC = 2;
40 | ENCODING_8BIT = 3;
41 | ENCODING_UTF8_NOBOM = 4;
42 | ENCODING_UTF8_BOM = 5;
43 | // - you can add more encodings, e.g. ENCODING_WIN1251 = 6, etc.
44 | // Synchronously produce TEncoder descendants with overrided ChooseMode,
45 | // FilterContent, and AppendBytes methods if needed. Examples are given
46 | // in the QR_URL.pas and the QR_Win1251.pas - Michael Demidov
47 |
48 | // max QR matrix size (not including quiet zone!)
49 | MAX_MATRIX_SIZE = 177;
50 |
51 | resourcestring
52 | // error message for EQRMatrixTooLarge exception
53 | SQRMatrixTooLarge = 'Trying to store too many bytes';
54 |
55 | var
56 | // default encoding when property Encoding = ENCODING_AUTO and Data contains
57 | // non-ISO chars
58 | DefaultNonISOEncoding: Integer = ENCODING_UTF8_NOBOM;
59 |
60 | type
61 | // ----------------- exceptions -----------------
62 | // too large matrix error
63 | EQRMatrixTooLarge = class(EInvalidOperation);
64 |
65 | // ----------------- auxiliary types -----------------
66 | TByteArray = array of Byte;
67 | TIntegerArray = array of Integer;
68 | T2DBooleanArray = array of array of Boolean;
69 | T2DByteArray = array of array of Byte;
70 | TBitArray = class;
71 | TByteMatrix = class;
72 | TErrorCorrectionLevel = class;
73 | TQRCode = class;
74 |
75 | // error correction level
76 | TErrorCorrectionOrdinal = (ecoL, ecoM, ecoQ, ecoH);
77 | // ecoL = ~7% correction
78 | // ecoM = ~15% correction
79 | // ecoQ = ~25% correction
80 | // ecoH = ~30% correction
81 |
82 | // write data mode (used by TEncoder)
83 | TMode = (qmTerminator, qmNumeric, qmAlphanumeric, qmStructuredAppend,
84 | qmByte, qmECI, qmKanji, qmFNC1FirstPosition, qmFNC1SecondPosition,
85 | qmHanzi);
86 |
87 | // TEncoder
88 | TEncoder = class;
89 | TEncoderClass = class of TEncoder;
90 |
91 | // ----------------- main class -----------------
92 | TDelphiZXingQRCode = class
93 | private
94 | FData: WideString;
95 | FFilteredData: WideString;
96 | FRows: Integer;
97 | FColumns: Integer;
98 | FEncoding: Integer;
99 | FQuietZone: Integer;
100 | FElements: T2DBooleanArray;
101 | FEncoders: TClassList;
102 | FErrorCorrectionOrdinal: TErrorCorrectionOrdinal;
103 | FAfterUpdate: TNotifyEvent;
104 | FBeforeUpdate: TNotifyEvent;
105 | FUpdateLockCount: Integer;
106 | procedure SetEncoding(NewEncoding: Integer);
107 | procedure SetData(const NewData: WideString);
108 | procedure SetQuietZone(NewQuietZone: Integer);
109 | procedure SetErrorCorrectionOrdinal(Value: TErrorCorrectionOrdinal);
110 | function GetIsBlack(Row, Column: Integer): Boolean;
111 | function GetEncoderClass: TEncoderClass;
112 | public
113 | constructor Create;
114 | destructor Destroy; override;
115 |
116 | // add new encoder class
117 | procedure RegisterEncoder(NewEncoding: Integer; NewEncoder: TEncoderClass);
118 |
119 | // increase updates lock counter
120 | procedure BeginUpdate;
121 | // decrease updates lock counter and call Update if lock counter is 0
122 | // and DoUpdate = true
123 | procedure EndUpdate(DoUpdate: Boolean = False);
124 | // update data. The main work is done here
125 | procedure Update;
126 |
127 | // input string
128 | property Data: WideString read FData write SetData;
129 | // ecoding ID, see ENCODING_... constants above
130 | property Encoding: Integer read FEncoding write SetEncoding;
131 | // error correction level, see TErrorCorrectionOrdinal type above
132 | property ErrorCorrectionOrdinal: TErrorCorrectionOrdinal read
133 | FErrorCorrectionOrdinal write SetErrorCorrectionOrdinal;
134 | // input string after TEncoder filtering
135 | property FilteredData: WideString read FFilteredData;
136 | // margins size, from 0 to 100, default 4
137 | property QuietZone: Integer read FQuietZone write SetQuietZone;
138 | // height of matrix, in dots, including QuietZone
139 | property Rows: Integer read FRows;
140 | // width of matrix, in dots, including QuietZone
141 | property Columns: Integer read FColumns;
142 | // True if the dot is black. NB! Row and Column are considered EXCLUDING
143 | // QuietZone!
144 | property IsBlack[Row, Column: Integer]: Boolean read GetIsBlack; default;
145 |
146 | // the event called immediately after update. Here you can e.g. redraw
147 | // the QR image. BeginUpdate and EndUpdate are called internally, so you can
148 | // even change input string or other field if needed
149 | property AfterUpdate: TNotifyEvent read FAfterUpdate write FAfterUpdate;
150 |
151 | // the event called immediately before update. Here you can e.g. change
152 | // input string or other field (BeginUpdate and EndUpdate are called
153 | // internally, so this should not lead to recursive hangs)
154 | property BeforeUpdate: TNotifyEvent read FBeforeUpdate write FBeforeUpdate;
155 | end;
156 |
157 | // ----------------- encoder class -----------------
158 | TEncoder = class
159 | private
160 | function ApplyMaskPenaltyRule1Internal(Matrix: TByteMatrix;
161 | IsHorizontal: Boolean): Integer;
162 | procedure Append8BitBytes(const Content: WideString; Bits: TBitArray;
163 | EncodeOptions: Integer);
164 |
165 | procedure AppendAlphanumericBytes(const Content: WideString;
166 | Bits: TBitArray);
167 | procedure AppendKanjiBytes(const Content: WideString; Bits: TBitArray);
168 | procedure AppendLengthInfo(NumLetters, VersionNum: Integer; Mode: TMode;
169 | Bits: TBitArray);
170 | procedure AppendModeInfo(Mode: TMode; Bits: TBitArray);
171 | procedure AppendNumericBytes(const Content: WideString; Bits: TBitArray);
172 | function ChooseMaskPattern(Bits: TBitArray; ECLevel: TErrorCorrectionLevel;
173 | Version: Integer; Matrix: TByteMatrix): Integer;
174 | function GenerateECBytes(DataBytes: TByteArray;
175 |
176 | NumECBytesInBlock: Integer): TByteArray;
177 | function GetAlphanumericCode(Code: Integer): Integer;
178 | procedure GetNumDataBytesAndNumECBytesForBlockID(NumTotalBytes,
179 | NumDataBytes, NumRSBlocks, BlockID: Integer; var NumDataBytesInBlock:
180 | TIntegerArray; var NumECBytesInBlock: TIntegerArray);
181 | procedure InterleaveWithECBytes(Bits: TBitArray; NumTotalBytes,
182 | NumDataBytes, NumRSBlocks: Integer; var Result: TBitArray);
183 | //function IsOnlyDoubleByteKanji(const Content: WideString): Boolean;
184 | procedure TerminateBits(NumDataBytes: Integer; var Bits: TBitArray);
185 | function CalculateMaskPenalty(Matrix: TByteMatrix): Integer;
186 | function ApplyMaskPenaltyRule1(Matrix: TByteMatrix): Integer;
187 | function ApplyMaskPenaltyRule2(Matrix: TByteMatrix): Integer;
188 | function ApplyMaskPenaltyRule3(Matrix: TByteMatrix): Integer;
189 | function ApplyMaskPenaltyRule4(Matrix: TByteMatrix): Integer;
190 | protected
191 | FEncoderError: Boolean;
192 |
193 | // select the suitable mode for encoding
194 | function ChooseMode(const Content: WideString; var EncodeOptions: Integer):
195 | TMode; virtual;
196 | // remove any inappropriate chars from the input string
197 | function FilterContent(const Content: WideString; Mode: TMode;
198 | EncodeOptions: Integer): WideString; virtual;
199 | // add previously filtered chars into bit array
200 | procedure AppendBytes(const Content: WideString; Mode: TMode;
201 | Bits: TBitArray; EncodeOptions: Integer); virtual;
202 | public
203 | // do encoding (call ChooseMode, FilterContent, and AppendBytes)
204 | function Encode(const Content: WideString; EncodeOptions: Integer;
205 | ECLevel: TErrorCorrectionLevel; QRCode: TQRCode): WideString;
206 | constructor Create;
207 | property EncoderError: Boolean read FEncoderError;
208 | end;
209 |
210 | // ----------------- auxiliary classes -----------------
211 | TBitArray = class
212 | private
213 | FBits: array of Integer;
214 | FSize: Integer;
215 | procedure EnsureCapacity(Size: Integer);
216 | public
217 | constructor Create; overload;
218 | constructor Create(Size: Integer); overload;
219 | function GetSizeInBytes: Integer;
220 | function GetSize: Integer;
221 | function Get(I: Integer): Boolean;
222 | procedure SetBit(Index: Integer);
223 | procedure AppendBit(Bit: Boolean);
224 | procedure AppendBits(Value, NumBits: Integer);
225 | procedure AppendBitArray(NewBitArray: TBitArray);
226 | procedure ToBytes(BitOffset: Integer; Source: TByteArray; Offset,
227 | NumBytes: Integer);
228 | procedure XorOperation(Other: TBitArray);
229 | end;
230 |
231 | TByteMatrix = class
232 | protected
233 | FBytes: T2DByteArray;
234 | FWidth: Integer;
235 | FHeight: Integer;
236 | public
237 | constructor Create(Width, Height: Integer);
238 | function Get(X, Y: Integer): Integer;
239 | procedure SetBoolean(X, Y: Integer; Value: Boolean);
240 | procedure SetInteger(X, Y: Integer; Value: Integer);
241 | function GetArray: T2DByteArray;
242 | procedure Assign(Source: TByteMatrix);
243 | procedure Clear(Value: Byte);
244 | function Hash: AnsiString;
245 | property Width: Integer read FWidth;
246 | property Height: Integer read FHeight;
247 | end;
248 |
249 | TErrorCorrectionLevel = class
250 | private
251 | FBits: Integer;
252 | FOrdinal: TErrorCorrectionOrdinal;
253 | procedure SetOrdinal(Value: TErrorCorrectionOrdinal);
254 | public
255 | procedure Assign(Source: TErrorCorrectionLevel);
256 | property Ordinal: TErrorCorrectionOrdinal read FOrdinal write SetOrdinal;
257 | property Bits: Integer read FBits;
258 | end;
259 |
260 | TQRCode = class
261 | private
262 | FMode: TMode;
263 | FECLevel: TErrorCorrectionLevel;
264 | FVersion: Integer;
265 | FMatrixWidth: Integer;
266 | FMaskPattern: Integer;
267 | FNumTotalBytes: Integer;
268 | FNumDataBytes: Integer;
269 | FNumECBytes: Integer;
270 | FNumRSBlocks: Integer;
271 | FMatrix: TByteMatrix;
272 | FQRCodeError: Boolean;
273 | public
274 | constructor Create;
275 | destructor Destroy; override;
276 | function At(X, Y: Integer): Integer;
277 | function IsValid: Boolean;
278 | function IsValidMaskPattern(MaskPattern: Integer): Boolean;
279 | procedure SetMatrix(NewMatrix: TByteMatrix);
280 | procedure SetECLevel(NewECLevel: TErrorCorrectionLevel);
281 | procedure SetAll(VersionNum, NumBytes, NumDataBytes, NumRSBlocks,
282 | NumECBytes, MatrixWidth: Integer);
283 | property QRCodeError: Boolean read FQRCodeError;
284 | property Mode: TMode read FMode write FMode;
285 | property Version: Integer read FVersion write FVersion;
286 | property NumDataBytes: Integer read FNumDataBytes;
287 | property NumTotalBytes: Integer read FNumTotalBytes;
288 | property NumRSBlocks: Integer read FNumRSBlocks;
289 | property MatrixWidth: Integer read FMatrixWidth;
290 | property MaskPattern: Integer read FMaskPattern write FMaskPattern;
291 | property ECLevel: TErrorCorrectionLevel read FECLevel;
292 | end;
293 |
294 | implementation
295 |
296 | uses
297 | Math;
298 |
299 | const
300 | NUM_MASK_PATTERNS = 8;
301 |
302 | QUIET_ZONE_SIZE = 4;
303 |
304 | ALPHANUMERIC_TABLE: array[0..95] of Integer = (
305 | -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, // 0x00-0x0f
306 | -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, // 0x10-0x1f
307 | 36, -1, -1, -1, 37, 38, -1, -1, -1, -1, 39, 40, -1, 41, 42, 43, // 0x20-0x2f
308 | 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 44, -1, -1, -1, -1, -1, // 0x30-0x3f
309 | -1, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, // 0x40-0x4f
310 | 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, -1, -1, -1, -1, -1 // 0x50-0x5f
311 | );
312 |
313 | DEFAULT_BYTE_MODE_ENCODING = 'ISO-8859-1';
314 |
315 | POSITION_DETECTION_PATTERN: array[0..6, 0..6] of Integer = (
316 | (1, 1, 1, 1, 1, 1, 1),
317 | (1, 0, 0, 0, 0, 0, 1),
318 | (1, 0, 1, 1, 1, 0, 1),
319 | (1, 0, 1, 1, 1, 0, 1),
320 | (1, 0, 1, 1, 1, 0, 1),
321 | (1, 0, 0, 0, 0, 0, 1),
322 | (1, 1, 1, 1, 1, 1, 1));
323 |
324 | HORIZONTAL_SEPARATION_PATTERN: array[0..0, 0..7] of Integer = (
325 | (0, 0, 0, 0, 0, 0, 0, 0));
326 |
327 | VERTICAL_SEPARATION_PATTERN: array[0..6, 0..0] of Integer = (
328 | (0), (0), (0), (0), (0), (0), (0));
329 |
330 | POSITION_ADJUSTMENT_PATTERN: array[0..4, 0..4] of Integer = (
331 | (1, 1, 1, 1, 1),
332 | (1, 0, 0, 0, 1),
333 | (1, 0, 1, 0, 1),
334 | (1, 0, 0, 0, 1),
335 | (1, 1, 1, 1, 1));
336 |
337 | // From Appendix E. Table 1, JIS0510X:2004 (p 71). The table was double-checked by komatsu.
338 | POSITION_ADJUSTMENT_PATTERN_COORDINATE_TABLE: array[0..39, 0..6] of Integer = (
339 | (-1, -1, -1, -1, -1, -1, -1), // Version 1
340 | ( 6, 18, -1, -1, -1, -1, -1), // Version 2
341 | ( 6, 22, -1, -1, -1, -1, -1), // Version 3
342 | ( 6, 26, -1, -1, -1, -1, -1), // Version 4
343 | ( 6, 30, -1, -1, -1, -1, -1), // Version 5
344 | ( 6, 34, -1, -1, -1, -1, -1), // Version 6
345 | ( 6, 22, 38, -1, -1, -1, -1), // Version 7
346 | ( 6, 24, 42, -1, -1, -1, -1), // Version 8
347 | ( 6, 26, 46, -1, -1, -1, -1), // Version 9
348 | ( 6, 28, 50, -1, -1, -1, -1), // Version 10
349 | ( 6, 30, 54, -1, -1, -1, -1), // Version 11
350 | ( 6, 32, 58, -1, -1, -1, -1), // Version 12
351 | ( 6, 34, 62, -1, -1, -1, -1), // Version 13
352 | ( 6, 26, 46, 66, -1, -1, -1), // Version 14
353 | ( 6, 26, 48, 70, -1, -1, -1), // Version 15
354 | ( 6, 26, 50, 74, -1, -1, -1), // Version 16
355 | ( 6, 30, 54, 78, -1, -1, -1), // Version 17
356 | ( 6, 30, 56, 82, -1, -1, -1), // Version 18
357 | ( 6, 30, 58, 86, -1, -1, -1), // Version 19
358 | ( 6, 34, 62, 90, -1, -1, -1), // Version 20
359 | ( 6, 28, 50, 72, 94, -1, -1), // Version 21
360 | ( 6, 26, 50, 74, 98, -1, -1), // Version 22
361 | ( 6, 30, 54, 78, 102, -1, -1), // Version 23
362 | ( 6, 28, 54, 80, 106, -1, -1), // Version 24
363 | ( 6, 32, 58, 84, 110, -1, -1), // Version 25
364 | ( 6, 30, 58, 86, 114, -1, -1), // Version 26
365 | ( 6, 34, 62, 90, 118, -1, -1), // Version 27
366 | ( 6, 26, 50, 74, 98, 122, -1), // Version 28
367 | ( 6, 30, 54, 78, 102, 126, -1), // Version 29
368 | ( 6, 26, 52, 78, 104, 130, -1), // Version 30
369 | ( 6, 30, 56, 82, 108, 134, -1), // Version 31
370 | ( 6, 34, 60, 86, 112, 138, -1), // Version 32
371 | ( 6, 30, 58, 86, 114, 142, -1), // Version 33
372 | ( 6, 34, 62, 90, 118, 146, -1), // Version 34
373 | ( 6, 30, 54, 78, 102, 126, 150), // Version 35
374 | ( 6, 24, 50, 76, 102, 128, 154), // Version 36
375 | ( 6, 28, 54, 80, 106, 132, 158), // Version 37
376 | ( 6, 32, 58, 84, 110, 136, 162), // Version 38
377 | ( 6, 26, 54, 82, 110, 138, 166), // Version 39
378 | ( 6, 30, 58, 86, 114, 142, 170) // Version 40
379 | );
380 |
381 | // Type info cells at the left top corner.
382 | TYPE_INFO_COORDINATES: array[0..14, 0..1] of Integer = (
383 | (8, 0),
384 | (8, 1),
385 | (8, 2),
386 | (8, 3),
387 | (8, 4),
388 | (8, 5),
389 | (8, 7),
390 | (8, 8),
391 | (7, 8),
392 | (5, 8),
393 | (4, 8),
394 | (3, 8),
395 | (2, 8),
396 | (1, 8),
397 | (0, 8)
398 | );
399 |
400 | // From Appendix D in JISX0510:2004 (p. 67)
401 | VERSION_INFO_POLY = $1f25; // 1 1111 0010 0101
402 |
403 | // From Appendix C in JISX0510:2004 (p.65).
404 | TYPE_INFO_POLY = $537;
405 | TYPE_INFO_MASK_PATTERN = $5412;
406 |
407 | VERSION_DECODE_INFO: array[0..33] of Integer = (
408 | $07C94, $085BC, $09A99, $0A4D3, $0BBF6,
409 | $0C762, $0D847, $0E60D, $0F928, $10B78,
410 | $1145D, $12A17, $13532, $149A6, $15683,
411 | $168C9, $177EC, $18EC4, $191E1, $1AFAB,
412 | $1B08E, $1CC1A, $1D33F, $1ED75, $1F250,
413 | $209D5, $216F0, $228BA, $2379F, $24B0B,
414 | $2542E, $26A64, $27541, $28C69);
415 |
416 | // Byte order mark for UTF-8 encoding
417 | BOM = #$EF#$BB#$BF;
418 |
419 | const
420 | ModeCharacterCountBits: array[TMode] of array[0..2] of Integer = (
421 | (0, 0, 0), (10, 12, 14), (9, 11, 13), (0, 0, 0), (8, 16, 16),
422 | (0, 0, 0), (8, 10, 12), (0, 0, 0), (0, 0, 0), (8, 10, 12));
423 |
424 | ModeBits: array[TMode] of Integer = (0, 1, 2, 3, 4, 7, 8, 5, 9, 13);
425 |
426 | ErrorCorrectionDescriptors: array[TErrorCorrectionOrdinal] of Integer =
427 | ($01, // L = ~7% correction
428 | $00, // M = ~15% correction
429 | $03, // Q = ~25% correction
430 | $02 // H = ~30% correction
431 | );
432 |
433 | type
434 | TECB = record
435 | Count: Integer;
436 | DataCodewords: Integer;
437 | end;
438 |
439 | TECBArray = array of TECB;
440 |
441 | TECBlocks = class
442 | private
443 | FECCodewordsPerBlock: Integer;
444 | FECBlocks: TECBArray;
445 | public
446 | constructor Create(ECCodewordsPerBlock: Integer; ECBlocks: TECB); overload;
447 | constructor Create(ECCodewordsPerBlock: Integer; ECBlocks1,
448 | ECBlocks2: TECB); overload;
449 | destructor Destroy; override;
450 | function GetTotalECCodewords: Integer;
451 | function GetNumBlocks: Integer;
452 | function GetECCodewordsPerBlock: Integer;
453 | function GetECBlocks: TECBArray;
454 | end;
455 |
456 | TVersion = class
457 | private
458 | FVersionNumber: Integer;
459 | FAlignmentPatternCenters: array of Integer;
460 | FECBlocks: array of TECBlocks;
461 | FTotalCodewords: Integer;
462 | FECCodewords: Integer;
463 | public
464 | constructor Create(VersionNumber: Integer; AlignmentPatternCenters:
465 | array of Integer; ECBlocks1, ECBlocks2, ECBlocks3, ECBlocks4: TECBlocks);
466 | destructor Destroy; override;
467 | class function GetVersionForNumber(VersionNum: Integer): TVersion;
468 | class function ChooseVersion(NumInputBits: Integer;
469 | ecLevel: TErrorCorrectionLevel): TVersion;
470 | function GetTotalCodewords: Integer;
471 | function GetECBlocksForLevel(ECLevel: TErrorCorrectionLevel): TECBlocks;
472 | function GetDimensionForVersion: Integer;
473 |
474 | property VersionNumber: Integer read FVersionNumber;
475 | end;
476 |
477 | TMatrixUtil = class
478 | private
479 | FMatrixUtilError: Boolean;
480 |
481 | function GetDataMaskBit(MaskPattern, X, Y: Integer): Boolean;
482 |
483 | procedure ClearMatrix(Matrix: TByteMatrix);
484 |
485 | procedure EmbedBasicPatterns(Version: Integer; Matrix: TByteMatrix);
486 | procedure EmbedTypeInfo(ECLevel: TErrorCorrectionLevel;
487 | MaskPattern: Integer; Matrix: TByteMatrix);
488 | procedure MaybeEmbedVersionInfo(Version: Integer; Matrix: TByteMatrix);
489 | procedure EmbedDataBits(DataBits: TBitArray; MaskPattern: Integer;
490 | Matrix: TByteMatrix);
491 | function FindMSBSet(Value: Integer): Integer;
492 | function CalculateBCHCode(Value, Poly: Integer): Integer;
493 | procedure MakeTypeInfoBits(ECLevel: TErrorCorrectionLevel;
494 | MaskPattern: Integer; Bits: TBitArray);
495 | procedure MakeVersionInfoBits(Version: Integer; Bits: TBitArray);
496 | function IsEmpty(Value: Integer): Boolean;
497 | procedure EmbedTimingPatterns(Matrix: TByteMatrix);
498 | procedure EmbedDarkDotAtLeftBottomCorner(Matrix: TByteMatrix);
499 | procedure EmbedHorizontalSeparationPattern(XStart, YStart: Integer;
500 | Matrix: TByteMatrix);
501 | procedure EmbedVerticalSeparationPattern(XStart, YStart: Integer;
502 | Matrix: TByteMatrix);
503 | procedure EmbedPositionAdjustmentPattern(XStart, YStart: Integer;
504 | Matrix: TByteMatrix);
505 | procedure EmbedPositionDetectionPattern(XStart, YStart: Integer;
506 | Matrix: TByteMatrix);
507 | procedure EmbedPositionDetectionPatternsAndSeparators(Matrix: TByteMatrix);
508 | procedure MaybeEmbedPositionAdjustmentPatterns(Version: Integer;
509 | Matrix: TByteMatrix);
510 | public
511 | constructor Create;
512 | property MatrixUtilError: Boolean read FMatrixUtilError;
513 | procedure BuildMatrix(DataBits: TBitArray; ECLevel: TErrorCorrectionLevel;
514 | Version, MaskPattern: Integer; Matrix: TByteMatrix);
515 | end;
516 |
517 | function GetModeCharacterCountBits(Mode: TMode; Version: TVersion): Integer;
518 | var
519 | Number: Integer;
520 | Offset: Integer;
521 | begin
522 | Number := Version.VersionNumber;
523 |
524 | if Number <= 9 then
525 | begin
526 | Offset := 0;
527 | end else
528 | if Number <= 26 then
529 | begin
530 | Offset := 1;
531 | end else
532 | begin
533 | Offset := 2;
534 | end;
535 | Result := ModeCharacterCountBits[Mode][Offset];
536 | end;
537 |
538 | type
539 | TBlockPair = class
540 | private
541 | FDataBytes: TByteArray;
542 | FErrorCorrectionBytes: TByteArray;
543 | public
544 | constructor Create(BA1, BA2: TByteArray);
545 | function GetDataBytes: TByteArray;
546 | function GetErrorCorrectionBytes: TByteArray;
547 | end;
548 |
549 | TGenericGFPoly = class;
550 |
551 | TGenericGF = class
552 | private
553 | FExpTable: TIntegerArray;
554 | FLogTable: TIntegerArray;
555 | FZero: TGenericGFPoly;
556 | FOne: TGenericGFPoly;
557 | FSize: Integer;
558 | FPrimitive: Integer;
559 | FGeneratorBase: Integer;
560 | FInitialized: Boolean;
561 | FPolyList: array of TGenericGFPoly;
562 |
563 | procedure CheckInit;
564 | procedure Initialize;
565 | public
566 | class function CreateQRCodeField256: TGenericGF;
567 | class function AddOrSubtract(A, B: Integer): Integer;
568 | constructor Create(Primitive, Size, B: Integer);
569 | destructor Destroy; override;
570 | function GetZero: TGenericGFPoly;
571 | function Exp(A: Integer): Integer;
572 | function GetGeneratorBase: Integer;
573 | function Inverse(A: Integer): Integer;
574 | function Multiply(A, B: Integer): Integer;
575 | function BuildMonomial(Degree, Coefficient: Integer): TGenericGFPoly;
576 | end;
577 |
578 | TGenericGFPolyArray = array of TGenericGFPoly;
579 | TGenericGFPoly = class
580 | private
581 | FField: TGenericGF;
582 | FCoefficients: TIntegerArray;
583 | public
584 | constructor Create(AField: TGenericGF; ACoefficients: TIntegerArray);
585 | destructor Destroy; override;
586 | function Coefficients: TIntegerArray;
587 | function Multiply(Other: TGenericGFPoly): TGenericGFPoly;
588 | function MultiplyByMonomial(Degree, Coefficient: Integer): TGenericGFPoly;
589 | function Divide(Other: TGenericGFPoly): TGenericGFPolyArray;
590 | function GetCoefficients: TIntegerArray;
591 | function IsZero: Boolean;
592 | function GetCoefficient(Degree: Integer): Integer;
593 | function GetDegree: Integer;
594 | function AddOrSubtract(Other: TGenericGFPoly): TGenericGFPoly;
595 | end;
596 |
597 | TReedSolomonEncoder = class
598 | private
599 | FField: TGenericGF;
600 | FCachedGenerators: TObjectList;
601 | public
602 | constructor Create(AField: TGenericGF);
603 | destructor Destroy; override;
604 | procedure Encode(ToEncode: TIntegerArray; ECBytes: Integer);
605 | function BuildGenerator(Degree: Integer): TGenericGFPoly;
606 | end;
607 |
608 | function TEncoder.ApplyMaskPenaltyRule1(Matrix: TByteMatrix): Integer;
609 | begin
610 | Result := ApplyMaskPenaltyRule1Internal(Matrix, True) +
611 | ApplyMaskPenaltyRule1Internal(Matrix, False);
612 | end;
613 |
614 | // Apply mask penalty rule 2 and return the penalty. Find 2x2 blocks with the same color and give
615 | // penalty to them.
616 | function TEncoder.ApplyMaskPenaltyRule2(Matrix: TByteMatrix): Integer;
617 | var
618 | Penalty: Integer;
619 | TheArray: T2DByteArray;
620 | Width: Integer;
621 | Height: Integer;
622 | X: Integer;
623 | Y: Integer;
624 | Value: Integer;
625 | begin
626 | Penalty := 0;
627 | TheArray := Matrix.GetArray;
628 | Width := Matrix.Width;
629 | Height := Matrix.Height;
630 | for Y := 0 to Height - 2 do
631 | begin
632 | for X := 0 to Width - 2 do
633 | begin
634 | Value := TheArray[Y][X];
635 | if (Value = TheArray[Y][X + 1]) and (Value = TheArray[Y + 1][X]) and
636 | (Value = TheArray[Y + 1][X + 1]) then
637 | begin
638 | Inc(Penalty, 3);
639 | end;
640 | end;
641 | end;
642 | Result := Penalty;
643 | end;
644 |
645 | // Apply mask penalty rule 3 and return the penalty. Find consecutive cells of 00001011101 or
646 | // 10111010000, and give penalty to them. If we find patterns like 000010111010000, we give
647 | // penalties twice (i.e. 40 * 2).
648 | function TEncoder.ApplyMaskPenaltyRule3(Matrix: TByteMatrix): Integer;
649 | var
650 | Penalty: Integer;
651 | TheArray: T2DByteArray;
652 | Width: Integer;
653 | Height: Integer;
654 | X: Integer;
655 | Y: Integer;
656 | begin
657 | Penalty := 0;
658 | TheArray := Matrix.GetArray;
659 | Width := Matrix.Width;
660 | Height := Matrix.Height;
661 | for Y := 0 to Height - 1 do
662 | begin
663 | for X := 0 to Width - 1 do
664 | begin
665 | if (X + 6 < Width) and
666 | (TheArray[Y][X] = 1) and
667 | (TheArray[Y][X + 1] = 0) and
668 | (TheArray[Y][X + 2] = 1) and
669 | (TheArray[Y][X + 3] = 1) and
670 | (TheArray[Y][X + 4] = 1) and
671 | (TheArray[Y][X + 5] = 0) and
672 | (TheArray[Y][X + 6] = 1) and
673 | (((X + 10 < Width) and
674 | (TheArray[Y][X + 7] = 0) and
675 | (TheArray[Y][X + 8] = 0) and
676 | (TheArray[Y][X + 9] = 0) and
677 | (TheArray[Y][X + 10] = 0)) or
678 | ((x - 4 >= 0) and
679 | (TheArray[Y][X - 1] = 0) and
680 | (TheArray[Y][X - 2] = 0) and
681 | (TheArray[Y][X - 3] = 0) and
682 | (TheArray[Y][X - 4] = 0))) then
683 | begin
684 | Inc(Penalty, 40);
685 | end;
686 | if (Y + 6 < Height) and
687 | (TheArray[Y][X] = 1) and
688 | (TheArray[Y + 1][X] = 0) and
689 | (TheArray[Y + 2][X] = 1) and
690 | (TheArray[Y + 3][X] = 1) and
691 | (TheArray[Y + 4][X] = 1) and
692 | (TheArray[Y + 5][X] = 0) and
693 | (TheArray[Y + 6][X] = 1) and
694 | (((Y + 10 < Height) and
695 | (TheArray[Y + 7][X] = 0) and
696 | (TheArray[Y + 8][X] = 0) and
697 | (TheArray[Y + 9][X] = 0) and
698 | (TheArray[Y + 10][X] = 0)) or
699 | ((Y - 4 >= 0) and
700 | (TheArray[Y - 1][X] = 0) and
701 | (TheArray[Y - 2][X] = 0) and
702 | (TheArray[Y - 3][X] = 0) and
703 | (TheArray[Y - 4][X] = 0))) then
704 | begin
705 | Inc(Penalty, 40);
706 | end;
707 | end;
708 | end;
709 | Result := Penalty;
710 | end;
711 |
712 | // Apply mask penalty rule 4 and return the penalty. Calculate the ratio of dark cells and give
713 | // penalty if the ratio is far from 50%. It gives 10 penalty for 5% distance. Examples:
714 | // - 0% => 100
715 | // - 40% => 20
716 | // - 45% => 10
717 | // - 50% => 0
718 | // - 55% => 10
719 | // - 55% => 20
720 | // - 100% => 100
721 | function TEncoder.ApplyMaskPenaltyRule4(Matrix: TByteMatrix): Integer;
722 | var
723 | NumDarkCells: Integer;
724 | TheArray: T2DByteArray;
725 | Width: Integer;
726 | Height: Integer;
727 | NumTotalCells: Integer;
728 | DarkRatio: Double;
729 | X: Integer;
730 | Y: Integer;
731 | begin
732 | NumDarkCells := 0;
733 | TheArray := Matrix.GetArray;
734 | Width := Matrix.Width;
735 | Height := matrix.Height;
736 | for Y := 0 to Height - 1 do
737 | begin
738 | for X := 0 to Width - 1 do
739 | begin
740 | if TheArray[Y][X] = 1 then
741 | begin
742 | Inc(NumDarkCells);
743 | end;
744 | end;
745 | end;
746 | numTotalCells := matrix.Height * Matrix.Width;
747 | DarkRatio := NumDarkCells / NumTotalCells;
748 | Result := Round(Abs((DarkRatio * 100 - 50)) / 50);
749 | end;
750 |
751 | // Helper function for applyMaskPenaltyRule1. We need this for doing this calculation in both
752 | // vertical and horizontal orders respectively.
753 | function TEncoder.ApplyMaskPenaltyRule1Internal(Matrix: TByteMatrix;
754 | IsHorizontal: Boolean): Integer;
755 | var
756 | Penalty: Integer;
757 | NumSameBitCells: Integer;
758 | PrevBit: Integer;
759 | TheArray: T2DByteArray;
760 | I: Integer;
761 | J: Integer;
762 | Bit: Integer;
763 | ILimit: Integer;
764 | JLimit: Integer;
765 | begin
766 | Penalty := 0;
767 | NumSameBitCells := 0;
768 | PrevBit := -1;
769 | // Horizontal mode:
770 | // for (int i = 0; i < matrix.height(); ++i) {
771 | // for (int j = 0; j < matrix.width(); ++j) {
772 | // int bit = matrix.get(i, j);
773 | // Vertical mode:
774 | // for (int i = 0; i < matrix.width(); ++i) {
775 | // for (int j = 0; j < matrix.height(); ++j) {
776 | // int bit = matrix.get(j, i);
777 | if IsHorizontal then
778 | begin
779 | ILimit := Matrix.Height;
780 | JLimit := Matrix.Width;
781 | end else
782 | begin
783 | ILimit := Matrix.Width;
784 | JLimit := Matrix.Height;
785 | end;
786 | TheArray := Matrix.GetArray;
787 |
788 | for I := 0 to ILimit - 1 do
789 | begin
790 | for J := 0 to JLimit - 1 do
791 | begin
792 | if IsHorizontal then
793 | Bit := TheArray[I][J]
794 | else
795 | Bit := TheArray[J][I];
796 | if Bit = PrevBit then
797 | begin
798 | Inc(NumSameBitCells);
799 | // Found five repetitive cells with the same color (bit).
800 | // We'll give penalty of 3.
801 | if NumSameBitCells = 5 then
802 | Inc(Penalty, 3)
803 | else
804 | if NumSameBitCells > 5 then
805 | // After five repetitive cells, we'll add the penalty one
806 | // by one.
807 | Inc(Penalty, 1);
808 | end else
809 | begin
810 | NumSameBitCells := 1; // Include the cell itself.
811 | PrevBit := bit;
812 | end;
813 | end;
814 | NumSameBitCells := 0; // Clear at each row/column.
815 | end;
816 | Result := Penalty;
817 | end;
818 |
819 | { TQRCode }
820 |
821 | constructor TQRCode.Create;
822 | begin
823 | FMode := qmTerminator;
824 | FQRCodeError := False;
825 | FECLevel := nil;
826 | FVersion := -1;
827 | FMatrixWidth := -1;
828 | FMaskPattern := -1;
829 | FNumTotalBytes := -1;
830 | FNumDataBytes := -1;
831 | FNumECBytes := -1;
832 | FNumRSBlocks := -1;
833 | FMatrix := nil;
834 | end;
835 |
836 | destructor TQRCode.Destroy;
837 | begin
838 | if Assigned(FECLevel) then
839 | FECLevel.Free;
840 | if Assigned(FMatrix) then
841 | FMatrix.Free;
842 | inherited;
843 | end;
844 |
845 | function TQRCode.At(X, Y: Integer): Integer;
846 | var
847 | Value: Integer;
848 | begin
849 | // The value must be zero or one.
850 | Value := FMatrix.Get(X, Y);
851 | if not (Value in [0, 1]) then
852 | FQRCodeError := True;
853 | Result := Value;
854 | end;
855 |
856 | function TQRCode.IsValid: Boolean;
857 | begin
858 | Result :=
859 | // First check if all version are not uninitialized.
860 | (Assigned(FECLevel) and
861 | (FVersion <> -1) and
862 | (FMatrixWidth <> -1) and
863 | (FMaskPattern <> -1) and
864 | (FNumTotalBytes <> -1) and
865 | (FNumDataBytes <> -1) and
866 | (FNumECBytes <> -1) and
867 | (FNumRSBlocks <> -1) and
868 | // Then check them in other ways..
869 | IsValidMaskPattern(FMaskPattern) and
870 | (FNumTotalBytes = FNumDataBytes + FNumECBytes) and
871 | // ByteMatrix stuff.
872 | Assigned(FMatrix) and
873 | (FMatrixWidth = FMatrix.Width) and
874 | // See 7.3.1 of JISX0510:2004 (Fp.5).
875 | (FMatrix.Width = FMatrix.Height)); // Must be square.
876 | end;
877 |
878 | function TQRCode.IsValidMaskPattern(MaskPattern: Integer): Boolean;
879 | begin
880 | Result := (MaskPattern >= 0) and (MaskPattern < NUM_MASK_PATTERNS);
881 | end;
882 |
883 | procedure TQRCode.SetMatrix(NewMatrix: TByteMatrix);
884 | begin
885 | if Assigned(FMatrix) then
886 | begin
887 | FMatrix.Free;
888 | FMatrix := nil;
889 | end;
890 | FMatrix := NewMatrix;
891 | end;
892 |
893 | procedure TQRCode.SetAll(VersionNum, NumBytes, NumDataBytes, NumRSBlocks,
894 | NumECBytes, MatrixWidth: Integer);
895 | begin
896 | FVersion := VersionNum;
897 | FNumTotalBytes := NumBytes;
898 | FNumDataBytes := NumDataBytes;
899 | FNumRSBlocks := NumRSBlocks;
900 | FNumECBytes := NumECBytes;
901 | FMatrixWidth := MatrixWidth;
902 | end;
903 |
904 | procedure TQRCode.SetECLevel(NewECLevel: TErrorCorrectionLevel);
905 | begin
906 | if Assigned(FECLevel) then
907 | FECLevel.Free;
908 | FECLevel := TErrorCorrectionLevel.Create;
909 | FECLevel.Assign(NewECLevel);
910 | end;
911 |
912 | { TByteMatrix }
913 |
914 | procedure TByteMatrix.Clear(Value: Byte);
915 | var
916 | X, Y: Integer;
917 | begin
918 | for Y := 0 to FHeight - 1 do
919 | for X := 0 to FWidth - 1 do
920 | FBytes[Y][X] := Value;
921 | end;
922 |
923 | constructor TByteMatrix.Create(Width, Height: Integer);
924 | var
925 | Y: Integer;
926 | X: Integer;
927 | begin
928 | if (Width > MAX_MATRIX_SIZE) or (Height > MAX_MATRIX_SIZE) then
929 | raise EQRMatrixTooLarge.Create(SQRMatrixTooLarge);
930 | FWidth := Width;
931 | FHeight := Height;
932 | SetLength(FBytes, Height);
933 | for Y := 0 to Height - 1 do
934 | begin
935 | SetLength(FBytes[Y], Width);
936 | for X := 0 to Width - 1 do
937 | FBytes[Y][X] := 0;
938 | end;
939 | end;
940 |
941 | function TByteMatrix.Get(X, Y: Integer): Integer;
942 | begin
943 | if FBytes[Y][X] = 255 then
944 | Result := -1
945 | else
946 | Result := FBytes[Y][X];
947 | end;
948 |
949 | function TByteMatrix.GetArray: T2DByteArray;
950 | begin
951 | Result := FBytes;
952 | end;
953 |
954 | function TByteMatrix.Hash: AnsiString;
955 | var
956 | X, Y: Integer;
957 | Counter: Integer;
958 | CC: Integer;
959 | begin
960 | Result := '';
961 | for Y := 0 to FHeight - 1 do
962 | begin
963 | Counter := 0;
964 | for X := 0 to FWidth - 1 do
965 | begin
966 | CC := Get(X, Y);
967 | if CC = -1 then
968 | CC := 255;
969 | Counter := Counter + CC;
970 | end;
971 | Result := Result + AnsiChar((Counter mod 26) + 65);
972 | end;
973 | end;
974 |
975 | procedure TByteMatrix.SetBoolean(X, Y: Integer; Value: Boolean);
976 | begin
977 | FBytes[Y][X] := Byte(Value) and $FF;
978 | end;
979 |
980 | procedure TByteMatrix.SetInteger(X, Y, Value: Integer);
981 | begin
982 | FBytes[Y][X] := Value and $FF;
983 | end;
984 |
985 | procedure TByteMatrix.Assign(Source: TByteMatrix);
986 | var
987 | SourceLength: Integer;
988 | begin
989 | SourceLength := Length(Source.FBytes);
990 | SetLength(FBytes, SourceLength);
991 | if SourceLength > 0 then
992 | Move(Source.FBytes[0], FBytes[0], SourceLength);
993 | FWidth := Source.Width;
994 | FHeight := Source.Height;
995 | end;
996 |
997 | { TEncoder }
998 |
999 | function TEncoder.CalculateMaskPenalty(Matrix: TByteMatrix): Integer;
1000 | var
1001 | Penalty: Integer;
1002 | begin
1003 | Penalty := 0;
1004 | Inc(Penalty, ApplyMaskPenaltyRule1(Matrix));
1005 | Inc(Penalty, ApplyMaskPenaltyRule2(Matrix));
1006 | Inc(Penalty, ApplyMaskPenaltyRule3(Matrix));
1007 | Inc(Penalty, ApplyMaskPenaltyRule4(Matrix));
1008 | Result := Penalty;
1009 | end;
1010 |
1011 | function TEncoder.Encode(const Content: WideString; EncodeOptions: Integer;
1012 | ECLevel: TErrorCorrectionLevel; QRCode: TQRCode): WideString;
1013 | var
1014 | Mode: TMode;
1015 | DataBits: TBitArray;
1016 | FinalBits: TBitArray;
1017 | HeaderBits: TBitArray;
1018 | HeaderAndDataBits: TBitArray;
1019 | Matrix: TByteMatrix;
1020 | NumLetters: Integer;
1021 | MatrixUtil: TMatrixUtil;
1022 | BitsNeeded: Integer;
1023 | ProvisionalBitsNeeded: Integer;
1024 | ProvisionalVersion: TVersion;
1025 | Version: TVersion;
1026 | ECBlocks: TECBlocks;
1027 | NumDataBytes: Integer;
1028 | Dimension: Integer;
1029 | begin
1030 | DataBits := TBitArray.Create;
1031 | HeaderBits := TBitArray.Create;
1032 |
1033 | // Pick an encoding mode appropriate for the content. Note that this will not attempt to use
1034 | // multiple modes / segments even if that were more efficient. Twould be nice.
1035 | // Collect data within the main segment, separately, to count its size if needed. Don't add it to
1036 | // main payload yet.
1037 |
1038 | Mode := ChooseMode(Content, EncodeOptions);
1039 | Result := FilterContent(Content, Mode, EncodeOptions);
1040 | AppendBytes(Result, Mode, DataBits, EncodeOptions);
1041 |
1042 | // (With ECI in place,) Write the mode marker
1043 | AppendModeInfo(Mode, HeaderBits);
1044 |
1045 | // Hard part: need to know version to know how many bits length takes. But need to know how many
1046 | // bits it takes to know version. First we take a guess at version by assuming version will be
1047 | // the minimum, 1:
1048 | ProvisionalVersion := TVersion.GetVersionForNumber(1);
1049 | try
1050 | ProvisionalBitsNeeded := HeaderBits.GetSize +
1051 | GetModeCharacterCountBits(Mode, ProvisionalVersion) +
1052 | DataBits.GetSize;
1053 | finally
1054 | ProvisionalVersion.Free;
1055 | end;
1056 |
1057 | ProvisionalVersion := TVersion.ChooseVersion(ProvisionalBitsNeeded, ECLevel);
1058 |
1059 | if not Assigned(ProvisionalVersion) then
1060 | raise EQRMatrixTooLarge.Create(SQRMatrixTooLarge);
1061 |
1062 | try
1063 | // Use that guess to calculate the right version. I am still not sure this works in 100% of cases.
1064 | BitsNeeded := HeaderBits.GetSize +
1065 | GetModeCharacterCountBits(Mode, ProvisionalVersion) +
1066 | DataBits.GetSize;
1067 | Version := TVersion.ChooseVersion(BitsNeeded, ECLevel);
1068 | finally
1069 | ProvisionalVersion.Free;
1070 | end;
1071 |
1072 | if not Assigned(Version) then
1073 | raise EQRMatrixTooLarge.Create(SQRMatrixTooLarge);
1074 |
1075 | HeaderAndDataBits := TBitArray.Create;
1076 | FinalBits := TBitArray.Create;
1077 | try
1078 | HeaderAndDataBits.AppendBitArray(HeaderBits);
1079 |
1080 | // Find "length" of main segment and write it
1081 | if Mode = qmByte then
1082 | NumLetters := DataBits.GetSizeInBytes
1083 | else
1084 | NumLetters := Length(Result);
1085 | AppendLengthInfo(NumLetters, Version.VersionNumber, Mode,
1086 | HeaderAndDataBits);
1087 | // Put data together into the overall payload
1088 | HeaderAndDataBits.AppendBitArray(DataBits);
1089 |
1090 | ECBlocks := Version.GetECBlocksForLevel(ECLevel);
1091 | NumDataBytes := Version.GetTotalCodewords - ECBlocks.GetTotalECCodewords;
1092 |
1093 | // Terminate the bits properly.
1094 | TerminateBits(NumDataBytes, HeaderAndDataBits);
1095 |
1096 | // Interleave data bits with error correction code.
1097 | InterleaveWithECBytes(HeaderAndDataBits, Version.GetTotalCodewords,
1098 | NumDataBytes, ECBlocks.GetNumBlocks, FinalBits);
1099 |
1100 | // QRCode qrCode = new QRCode(); // This is passed in
1101 |
1102 |
1103 | QRCode.SetECLevel(ECLevel);
1104 | QRCode.Mode := Mode;
1105 | QRCode.Version := Version.VersionNumber;
1106 |
1107 | // Choose the mask pattern and set to "qrCode".
1108 | Dimension := Version.GetDimensionForVersion;
1109 | Matrix := TByteMatrix.Create(Dimension, Dimension);
1110 |
1111 | QRCode.MaskPattern := ChooseMaskPattern(FinalBits, ECLevel,
1112 | Version.VersionNumber, Matrix);
1113 |
1114 | Matrix.Free;
1115 | Matrix := TByteMatrix.Create(Dimension, Dimension);
1116 |
1117 | // Build the matrix and set it to "qrCode".
1118 | MatrixUtil := TMatrixUtil.Create;
1119 | try
1120 | MatrixUtil.BuildMatrix(FinalBits, QRCode.ECLevel, QRCode.Version,
1121 | QRCode.MaskPattern, Matrix);
1122 | finally
1123 | MatrixUtil.Free;
1124 | end;
1125 |
1126 | QRCode.SetMatrix(Matrix); // QRCode will free the matrix
1127 | finally
1128 | DataBits.Free;
1129 | HeaderAndDataBits.Free;
1130 | FinalBits.Free;
1131 | HeaderBits.Free;
1132 | Version.Free;
1133 | end;
1134 | end;
1135 |
1136 | function TEncoder.FilterContent(const Content: WideString; Mode: TMode;
1137 | EncodeOptions: Integer): WideString;
1138 | var
1139 | X: Integer;
1140 | CanAdd: Boolean;
1141 | begin
1142 | Result := '';
1143 | for X := 1 to Length(Content) do
1144 | begin
1145 | CanAdd := False;
1146 | if Mode = qmNumeric then
1147 | CanAdd := (Content[X] >= '0') and (Content[X] <= '9')
1148 | else
1149 | if Mode = qmAlphanumeric then
1150 | CanAdd := GetAlphanumericCode(Ord(Content[X])) > -1
1151 | else
1152 | if Mode = qmByte then
1153 | begin
1154 | if EncodeOptions = ENCODING_8BIT then
1155 | CanAdd := Ord(Content[X]) <= $FF
1156 | else
1157 | if EncodeOptions in [ENCODING_UTF8_NOBOM, ENCODING_UTF8_BOM] then
1158 | CanAdd := True;
1159 | end;
1160 | if CanAdd then
1161 | Result := Result + Content[X];
1162 | end;
1163 | end;
1164 |
1165 | // Return the code point of the table used in alphanumeric mode or
1166 | // -1 if there is no corresponding code in the table.
1167 | function TEncoder.GetAlphanumericCode(Code: Integer): Integer;
1168 | begin
1169 | if Code < Length(ALPHANUMERIC_TABLE) then
1170 | Result := ALPHANUMERIC_TABLE[Code]
1171 | else
1172 | Result := -1;
1173 | end;
1174 |
1175 | // Choose the mode based on the content
1176 | function TEncoder.ChooseMode(const Content: WideString;
1177 | var EncodeOptions: Integer): TMode;
1178 | var
1179 | AllNumeric: Boolean;
1180 | AllAlphanumeric: Boolean;
1181 | AllISO: Boolean;
1182 | I: Integer;
1183 | C: WideChar;
1184 | begin
1185 | if EncodeOptions = ENCODING_AUTO then
1186 | begin
1187 | AllNumeric := Length(Content) > 0;
1188 | I := 1;
1189 | while (I <= Length(Content)) and (AllNumeric) do
1190 | begin
1191 | C := Content[I];
1192 | if (C < '0') or (C > '9') then
1193 | AllNumeric := False
1194 | else
1195 | Inc(I);
1196 | end;
1197 |
1198 | if not AllNumeric then
1199 | begin
1200 | AllAlphanumeric := Length(Content) > 0;
1201 | I := 1;
1202 | while (I <= Length(Content)) and (AllAlphanumeric) do
1203 | begin
1204 | C := Content[I];
1205 | if GetAlphanumericCode(Ord(C)) < 0 then
1206 | AllAlphanumeric := False
1207 | else
1208 | Inc(I);
1209 | end;
1210 | end else
1211 | AllAlphanumeric := False;
1212 |
1213 | if not AllAlphanumeric then
1214 | begin
1215 | AllISO := Length(Content) > 0;
1216 | I := 1;
1217 | while (I <= Length(Content)) and (AllISO) do
1218 | begin
1219 | C := Content[I];
1220 | if Ord(C) > $FF then
1221 | AllISO := False
1222 | else
1223 | Inc(I);
1224 | end;
1225 | end else
1226 | AllISO := False;
1227 |
1228 | if AllNumeric then
1229 | Result := qmNumeric
1230 | else
1231 | if AllAlphanumeric then
1232 | Result := qmAlphanumeric
1233 | else
1234 | if AllISO then
1235 | begin
1236 | Result := qmByte;
1237 | EncodeOptions := ENCODING_8BIT;
1238 | end else
1239 | begin
1240 | Result := qmByte;
1241 | EncodeOptions := DefaultNonISOEncoding;
1242 | end;
1243 | end else
1244 | case EncodeOptions of
1245 | ENCODING_NUMERIC:
1246 | Result := qmNumeric;
1247 | ENCODING_ALPHANUMERIC:
1248 | Result := qmAlphanumeric;
1249 | else
1250 | Result := qmByte;
1251 | end;
1252 | end;
1253 |
1254 | constructor TEncoder.Create;
1255 | begin
1256 | FEncoderError := False;
1257 | end;
1258 |
1259 | {function TEncoder.IsOnlyDoubleByteKanji(const Content: WideString): Boolean;
1260 | var
1261 | I: Integer;
1262 | Char1: Integer;
1263 | begin
1264 | Result := True;
1265 | I := 0;
1266 | while ((I < Length(Content)) and Result) do
1267 | begin
1268 | Char1 := Ord(Content[I + 1]);
1269 | if (((Char1 < $81) or (Char1 > $9F)) and ((Char1 < $E0) or (Char1 > $EB))) then
1270 | begin
1271 | Result := False;
1272 | end;
1273 | end;
1274 | end;}
1275 |
1276 | function TEncoder.ChooseMaskPattern(Bits: TBitArray; ECLevel:
1277 | TErrorCorrectionLevel; Version: Integer; Matrix: TByteMatrix): Integer;
1278 | var
1279 | MinPenalty: Integer;
1280 | BestMaskPattern: Integer;
1281 | MaskPattern: Integer;
1282 | MatrixUtil: TMatrixUtil;
1283 | Penalty: Integer;
1284 | begin
1285 | MinPenalty := MaxInt;
1286 | BestMaskPattern := -1;
1287 |
1288 | // We try all mask patterns to choose the best one.
1289 | for MaskPattern := 0 to NUM_MASK_PATTERNS - 1 do
1290 | begin
1291 | MatrixUtil := TMatrixUtil.Create;
1292 | try
1293 | MatrixUtil.BuildMatrix(Bits, ECLevel, Version, MaskPattern, Matrix);
1294 | finally
1295 | MatrixUtil.Free;
1296 | end;
1297 | Penalty := CalculateMaskPenalty(Matrix);
1298 | if Penalty < MinPenalty then
1299 | begin
1300 | MinPenalty := Penalty;
1301 | BestMaskPattern := MaskPattern;
1302 | end;
1303 | end;
1304 |
1305 | Result := BestMaskPattern;
1306 | end;
1307 |
1308 | // Terminate bits as described in 8.4.8 and 8.4.9 of JISX0510:2004 (p.24).
1309 | procedure TEncoder.TerminateBits(NumDataBytes: Integer; var Bits: TBitArray);
1310 | var
1311 | Capacity: Integer;
1312 | I: Integer;
1313 | NumBitsInLastByte: Integer;
1314 | NumPaddingBytes: Integer;
1315 | begin
1316 | Capacity := NumDataBytes shl 3;
1317 | if Bits.GetSize > Capacity then
1318 | begin
1319 | FEncoderError := True;
1320 | Exit;
1321 | end;
1322 | I := 0;
1323 | while ((I < 4) and (Bits.GetSize < capacity)) do
1324 | begin
1325 | Bits.AppendBit(False);
1326 | Inc(I);
1327 | end;
1328 |
1329 | // Append termination bits. See 8.4.8 of JISX0510:2004 (p.24) for details.
1330 | // If the last byte isn't 8-bit aligned, we'll add padding bits.
1331 | NumBitsInLastByte := Bits.GetSize and $07;
1332 | if NumBitsInLastByte > 0 then
1333 | for I := numBitsInLastByte to 7 do
1334 | Bits.AppendBit(False);
1335 |
1336 | // If we have more space, we'll fill the space with padding patterns defined in 8.4.9 (p.24).
1337 | NumPaddingBytes := NumDataBytes - Bits.GetSizeInBytes;
1338 | for I := 0 to NumPaddingBytes - 1 do
1339 | if (I and $01) = 0 then
1340 | Bits.AppendBits($EC, 8)
1341 | else
1342 | Bits.AppendBits($11, 8);
1343 | if Bits.GetSize <> Capacity then
1344 | FEncoderError := True;
1345 | end;
1346 |
1347 | // Get number of data bytes and number of error correction bytes for block id "blockID". Store
1348 | // the result in "numDataBytesInBlock", and "numECBytesInBlock". See table 12 in 8.5.1 of
1349 | // JISX0510:2004 (p.30)
1350 | procedure TEncoder.GetNumDataBytesAndNumECBytesForBlockID(NumTotalBytes,
1351 | NumDataBytes, NumRSBlocks, BlockID: Integer;
1352 | var NumDataBytesInBlock: TIntegerArray; var NumECBytesInBlock: TIntegerArray);
1353 | var
1354 | NumRSBlocksInGroup1: Integer;
1355 | NumRSBlocksInGroup2: Integer;
1356 | NumTotalBytesInGroup1: Integer;
1357 | NumTotalBytesInGroup2: Integer;
1358 | NumDataBytesInGroup1: Integer;
1359 | NumDataBytesInGroup2: Integer;
1360 | NumECBytesInGroup1: Integer;
1361 | NumECBytesInGroup2: Integer;
1362 | begin
1363 | if BlockID >= NumRSBlocks then
1364 | begin
1365 | FEncoderError := True;
1366 | Exit;
1367 | end;
1368 | // numRsBlocksInGroup2 = 196 % 5 = 1
1369 | NumRSBlocksInGroup2 := NumTotalBytes mod NumRSBlocks;
1370 | // numRsBlocksInGroup1 = 5 - 1 = 4
1371 | NumRSBlocksInGroup1 := NumRSBlocks - NumRSBlocksInGroup2;
1372 | // numTotalBytesInGroup1 = 196 / 5 = 39
1373 | NumTotalBytesInGroup1 := NumTotalBytes div NumRSBlocks;
1374 | // numTotalBytesInGroup2 = 39 + 1 = 40
1375 | NumTotalBytesInGroup2 := NumTotalBytesInGroup1 + 1;
1376 | // numDataBytesInGroup1 = 66 / 5 = 13
1377 | NumDataBytesInGroup1 := NumDataBytes div NumRSBlocks;
1378 | // numDataBytesInGroup2 = 13 + 1 = 14
1379 | NumDataBytesInGroup2 := NumDataBytesInGroup1 + 1;
1380 | // numEcBytesInGroup1 = 39 - 13 = 26
1381 | NumECBytesInGroup1 := NumTotalBytesInGroup1 - NumDataBytesInGroup1;
1382 | // numEcBytesInGroup2 = 40 - 14 = 26
1383 | NumECBytesInGroup2 := NumTotalBytesInGroup2 - NumDataBytesInGroup2;
1384 | // Sanity checks.
1385 | // 26 = 26
1386 | if NumECBytesInGroup1 <> NumECBytesInGroup2 then
1387 | begin
1388 | FEncoderError := True;
1389 | Exit;
1390 | end;
1391 | // 5 = 4 + 1.
1392 | if NumRSBlocks <> (NumRSBlocksInGroup1 + NumRSBlocksInGroup2) then
1393 | begin
1394 | FEncoderError := True;
1395 | Exit;
1396 | end;
1397 | // 196 = (13 + 26) * 4 + (14 + 26) * 1
1398 | if NumTotalBytes <>
1399 | ((NumDataBytesInGroup1 + NumECBytesInGroup1) * NumRsBlocksInGroup1) +
1400 | ((NumDataBytesInGroup2 + NumECBytesInGroup2) * NumRsBlocksInGroup2) then
1401 | begin
1402 | FEncoderError := True;
1403 | Exit;
1404 | end;
1405 |
1406 | if BlockID < NumRSBlocksInGroup1 then
1407 | begin
1408 | NumDataBytesInBlock[0] := NumDataBytesInGroup1;
1409 | NumECBytesInBlock[0] := numECBytesInGroup1;
1410 | end else
1411 | begin
1412 | NumDataBytesInBlock[0] := NumDataBytesInGroup2;
1413 | NumECBytesInBlock[0] := numEcBytesInGroup2;
1414 | end;
1415 | end;
1416 |
1417 | // Interleave "bits" with corresponding error correction bytes. On success, store the result in
1418 | // "result". The interleave rule is complicated. See 8.6 of JISX0510:2004 (p.37) for details.
1419 | procedure TEncoder.InterleaveWithECBytes(Bits: TBitArray; NumTotalBytes,
1420 | NumDataBytes, NumRSBlocks: Integer; var Result: TBitArray);
1421 | var
1422 | DataBytesOffset: Integer;
1423 | MaxNumDataBytes: Integer;
1424 | MaxNumECBytes: Integer;
1425 | Blocks: TObjectList;
1426 | NumDataBytesInBlock: TIntegerArray;
1427 | NumECBytesInBlock: TIntegerArray;
1428 | Size: Integer;
1429 | DataBytes: TByteArray;
1430 | ECBytes: TByteArray;
1431 | I, J: Integer;
1432 | BlockPair: TBlockPair;
1433 | begin
1434 | SetLength(ECBytes, 0);
1435 |
1436 | // "bits" must have "getNumDataBytes" bytes of data.
1437 | if Bits.GetSizeInBytes <> NumDataBytes then
1438 | begin
1439 | FEncoderError := True;
1440 | Exit;
1441 | end;
1442 |
1443 | // Step 1. Divide data bytes into blocks and generate error correction bytes for them. We'll
1444 | // store the divided data bytes blocks and error correction bytes blocks into "blocks".
1445 | DataBytesOffset := 0;
1446 | MaxNumDataBytes := 0;
1447 | MaxNumEcBytes := 0;
1448 |
1449 | // Since, we know the number of reedsolmon blocks, we can initialize the vector with the number.
1450 | Blocks := TObjectList.Create(True);
1451 | try
1452 | Blocks.Capacity := NumRSBlocks;
1453 |
1454 | for I := 0 to NumRSBlocks - 1 do
1455 | begin
1456 | SetLength(NumDataBytesInBlock, 1);
1457 | SetLength(NumECBytesInBlock, 1);
1458 | GetNumDataBytesAndNumECBytesForBlockID(
1459 | NumTotalBytes, NumDataBytes, NumRSBlocks, I,
1460 | NumDataBytesInBlock, NumEcBytesInBlock);
1461 |
1462 | Size := NumDataBytesInBlock[0];
1463 | SetLength(DataBytes, Size);
1464 | Bits.ToBytes(8 * DataBytesOffset, DataBytes, 0, Size);
1465 | ECBytes := GenerateECBytes(DataBytes, NumEcBytesInBlock[0]);
1466 | BlockPair := TBlockPair.Create(DataBytes, ECBytes);
1467 | Blocks.Add(BlockPair);
1468 |
1469 | MaxNumDataBytes := Max(MaxNumDataBytes, Size);
1470 | MaxNumECBytes := Max(MaxNumECBytes, Length(ECBytes));
1471 | Inc(DataBytesOffset, NumDataBytesInBlock[0]);
1472 | end;
1473 | if NumDataBytes <> DataBytesOffset then
1474 | begin
1475 | FEncoderError := True;
1476 | Exit;
1477 | end;
1478 |
1479 | // First, place data blocks.
1480 | for I := 0 to MaxNumDataBytes - 1 do
1481 | begin
1482 | for J := 0 to Blocks.Count - 1 do
1483 | begin
1484 | DataBytes := TBlockPair(Blocks.Items[J]).GetDataBytes;
1485 | if I < Length(DataBytes) then
1486 | Result.AppendBits(DataBytes[I], 8);
1487 | end;
1488 | end;
1489 | // Then, place error correction blocks.
1490 | for I := 0 to MaxNumECBytes - 1 do
1491 | begin
1492 | for J := 0 to Blocks.Count - 1 do
1493 | begin
1494 | ECBytes := TBlockPair(Blocks.Items[J]).GetErrorCorrectionBytes;
1495 | if I < Length(ECBytes) then
1496 | Result.AppendBits(ECBytes[I], 8);
1497 | end;
1498 | end;
1499 | finally
1500 | Blocks.Free;
1501 | end;
1502 | if numTotalBytes <> Result.GetSizeInBytes then // Should be same.
1503 | FEncoderError := True;
1504 | end;
1505 |
1506 | function TEncoder.GenerateECBytes(DataBytes: TByteArray; NumECBytesInBlock:
1507 | Integer): TByteArray;
1508 | var
1509 | NumDataBytes: Integer;
1510 | ToEncode: TIntegerArray;
1511 | ReedSolomonEncoder: TReedSolomonEncoder;
1512 | I: Integer;
1513 | ECBytes: TByteArray;
1514 | GenericGF: TGenericGF;
1515 | begin
1516 | NumDataBytes := Length(DataBytes);
1517 | SetLength(ToEncode, NumDataBytes + NumECBytesInBlock);
1518 |
1519 | for I := 0 to NumDataBytes - 1 do
1520 | ToEncode[I] := DataBytes[I] and $FF;
1521 |
1522 | GenericGF := TGenericGF.CreateQRCodeField256;
1523 | try
1524 | ReedSolomonEncoder := TReedSolomonEncoder.Create(GenericGF);
1525 | try
1526 | ReedSolomonEncoder.Encode(ToEncode, NumECBytesInBlock);
1527 | finally
1528 | ReedSolomonEncoder.Free;
1529 | end;
1530 | finally
1531 | GenericGF.Free;
1532 | end;
1533 |
1534 | SetLength(ECBytes, NumECBytesInBlock);
1535 | for I := 0 to NumECBytesInBlock - 1 do
1536 | ECBytes[I] := ToEncode[NumDataBytes + I];
1537 |
1538 | Result := ECBytes;
1539 | end;
1540 |
1541 | // Append mode info. On success, store the result in "bits".
1542 | procedure TEncoder.AppendModeInfo(Mode: TMode; Bits: TBitArray);
1543 | begin
1544 | Bits.AppendBits(ModeBits[Mode], 4);
1545 | end;
1546 |
1547 | // Append length info. On success, store the result in "bits".
1548 | procedure TEncoder.AppendLengthInfo(NumLetters, VersionNum: Integer; Mode:
1549 | TMode; Bits: TBitArray);
1550 | var
1551 | NumBits: Integer;
1552 | Version: TVersion;
1553 | begin
1554 | Version := TVersion.GetVersionForNumber(VersionNum);
1555 | try
1556 | NumBits := GetModeCharacterCountBits(Mode, Version);
1557 | finally
1558 | Version.Free;
1559 | end;
1560 |
1561 | if NumLetters > ((1 shl NumBits) - 1) then
1562 | FEncoderError := True
1563 | else
1564 | Bits.AppendBits(NumLetters, NumBits);
1565 | end;
1566 |
1567 | // Append "bytes" in "mode" mode (encoding) into "bits". On success, store the result in "bits".
1568 | procedure TEncoder.AppendBytes(const Content: WideString; Mode: TMode; Bits:
1569 | TBitArray; EncodeOptions: Integer);
1570 | begin
1571 | case Mode of
1572 | qmNumeric:
1573 | AppendNumericBytes(Content, Bits);
1574 | qmAlphanumeric:
1575 | AppendAlphanumericBytes(Content, Bits);
1576 | qmByte:
1577 | Append8BitBytes(Content, Bits, EncodeOptions);
1578 | qmKanji:
1579 | AppendKanjiBytes(Content, Bits);
1580 | else
1581 | FEncoderError := True;
1582 | end;
1583 | end;
1584 |
1585 | procedure TEncoder.AppendNumericBytes(const Content: WideString; Bits:
1586 | TBitArray);
1587 | var
1588 | ContentLength: Integer;
1589 | I: Integer;
1590 | Num1: Integer;
1591 | Num2: Integer;
1592 | Num3: Integer;
1593 | begin
1594 | ContentLength := Length(Content);
1595 | I := 0;
1596 | while (I < ContentLength) do
1597 | begin
1598 | Num1 := Ord(Content[I + 0 + 1]) - Ord('0');
1599 | if I + 2 < ContentLength then
1600 | begin
1601 | // Encode three numeric letters in ten bits.
1602 | Num2 := Ord(Content[I + 1 + 1]) - Ord('0');
1603 | Num3 := Ord(Content[I + 2 + 1]) - Ord('0');
1604 | Bits.AppendBits(Num1 * 100 + Num2 * 10 + Num3, 10);
1605 | Inc(I, 3);
1606 | end else
1607 | if I + 1 < ContentLength then
1608 | begin
1609 | // Encode two numeric letters in seven bits.
1610 | Num2 := Ord(Content[I + 1 + 1]) - Ord('0');
1611 | Bits.AppendBits(Num1 * 10 + Num2, 7);
1612 | Inc(I, 2);
1613 | end else
1614 | begin
1615 | // Encode one numeric letter in four bits.
1616 | Bits.AppendBits(Num1, 4);
1617 | Inc(I);
1618 | end;
1619 | end;
1620 | end;
1621 |
1622 | procedure TEncoder.AppendAlphanumericBytes(const Content: WideString; Bits:
1623 | TBitArray);
1624 | var
1625 | ContentLength: Integer;
1626 | I: Integer;
1627 | Code1: Integer;
1628 | Code2: Integer;
1629 | begin
1630 | ContentLength := Length(Content);
1631 | I := 0;
1632 | while (I < ContentLength) do
1633 | begin
1634 | Code1 := GetAlphanumericCode(Ord(Content[I + 0 + 1]));
1635 | if Code1 = -1 then
1636 | begin
1637 | FEncoderError := True;
1638 | Exit;
1639 | end;
1640 | if I + 1 < ContentLength then
1641 | begin
1642 | Code2 := GetAlphanumericCode(Ord(Content[I + 1 + 1]));
1643 | if Code2 = -1 then
1644 | begin
1645 | FEncoderError := True;
1646 | Exit;
1647 | end;
1648 | // Encode two alphanumeric letters in 11 bits.
1649 | Bits.AppendBits(Code1 * 45 + Code2, 11);
1650 | Inc(I, 2);
1651 | end else
1652 | begin
1653 | // Encode one alphanumeric letter in six bits.
1654 | Bits.AppendBits(Code1, 6);
1655 | Inc(I);
1656 | end;
1657 | end;
1658 | end;
1659 |
1660 | procedure TEncoder.Append8BitBytes(const Content: WideString; Bits: TBitArray;
1661 | EncodeOptions: Integer);
1662 | var
1663 | Bytes: TByteArray;
1664 | I: Integer;
1665 | UTF8Version: AnsiString;
1666 | begin
1667 | SetLength(Bytes, 0);
1668 |
1669 | case EncodeOptions of
1670 | ENCODING_8BIT:
1671 | begin
1672 | SetLength(Bytes, Length(Content));
1673 | for I := 1 to Length(Content) do
1674 | Bytes[I - 1] := Ord(Content[I]) and $FF;
1675 | end;
1676 | ENCODING_UTF8_NOBOM:
1677 | begin
1678 | // No BOM
1679 | UTF8Version := UTF8Encode(Content);
1680 | SetLength(Bytes, Length(UTF8Version));
1681 | {$WARNINGS OFF}
1682 | if Length(UTF8Version) > 0 then
1683 | Move(UTF8Version[1], Bytes[0], Length(UTF8Version));
1684 | {$WARNINGS ON}
1685 | end;
1686 | ENCODING_UTF8_BOM:
1687 | begin
1688 | // Add the UTF-8 BOM
1689 | UTF8Version := BOM + UTF8Encode(Content);
1690 | SetLength(Bytes, Length(UTF8Version));
1691 | {$WARNINGS OFF}
1692 | if Length(UTF8Version) > 0 then
1693 | Move(UTF8Version[1], Bytes[0], Length(UTF8Version));
1694 | {$WARNINGS ON}
1695 | end;
1696 | end;
1697 | for I := 0 to Length(Bytes) - 1 do
1698 | Bits.AppendBits(Bytes[I], 8);
1699 | end;
1700 |
1701 | procedure TEncoder.AppendKanjiBytes(const Content: WideString; Bits: TBitArray);
1702 | var
1703 | Bytes: TByteArray;
1704 | ByteLength: Integer;
1705 | I: Integer;
1706 | Byte1: Integer;
1707 | Byte2: Integer;
1708 | Code: Integer;
1709 | Subtracted: Integer;
1710 | Encoded: Integer;
1711 | begin
1712 | SetLength(Bytes, 0);
1713 | try
1714 | ByteLength := Length(Bytes);
1715 | I := 0;
1716 | while (I < ByteLength) do
1717 | begin
1718 | Byte1 := Bytes[I] and $FF;
1719 | Byte2 := Bytes[I + 1] and $FF;
1720 | Code := (Byte1 shl 8) or Byte2;
1721 | Subtracted := -1;
1722 | if (Code >= $8140) and (Code <= $9ffc) then
1723 | Subtracted := Code - $8140
1724 | else
1725 | if (Code >= $e040) and (Code <= $ebbf) then
1726 | Subtracted := Code - $c140;
1727 | if Subtracted = -1 then
1728 | begin
1729 | FEncoderError := True;
1730 | Exit;
1731 | end;
1732 | Encoded := ((Subtracted shr 8) * $c0) + (Subtracted and $ff);
1733 | Bits.AppendBits(Encoded, 13);
1734 | Inc(I, 2);
1735 | end;
1736 | except
1737 | FEncoderError := True;
1738 | end;
1739 | end;
1740 |
1741 | procedure TMatrixUtil.ClearMatrix(Matrix: TByteMatrix);
1742 | begin
1743 | Matrix.Clear(Byte(-1));
1744 | end;
1745 |
1746 | constructor TMatrixUtil.Create;
1747 | begin
1748 | FMatrixUtilError := False;
1749 | end;
1750 |
1751 | // Build 2D matrix of QR Code from "dataBits" with "ecLevel", "version" and "getMaskPattern". On
1752 | // success, store the result in "matrix" and return true.
1753 | procedure TMatrixUtil.BuildMatrix(DataBits: TBitArray; ECLevel:
1754 | TErrorCorrectionLevel; Version, MaskPattern: Integer; Matrix: TByteMatrix);
1755 | begin
1756 | ClearMatrix(Matrix);
1757 | EmbedBasicPatterns(Version, Matrix);
1758 |
1759 | // Type information appear with any version.
1760 | EmbedTypeInfo(ECLevel, MaskPattern, Matrix);
1761 |
1762 | // Version info appear if version >= 7.
1763 | MaybeEmbedVersionInfo(Version, Matrix);
1764 |
1765 | // Data should be embedded at end.
1766 | EmbedDataBits(DataBits, MaskPattern, Matrix);
1767 | end;
1768 |
1769 | // Embed basic patterns. On success, modify the matrix and return true.
1770 | // The basic patterns are:
1771 | // - Position detection patterns
1772 | // - Timing patterns
1773 | // - Dark dot at the left bottom corner
1774 | // - Position adjustment patterns, if need be
1775 | procedure TMatrixUtil.EmbedBasicPatterns(Version: Integer; Matrix: TByteMatrix);
1776 | begin
1777 | // Let's get started with embedding big squares at corners.
1778 | EmbedPositionDetectionPatternsAndSeparators(Matrix);
1779 |
1780 | // Then, embed the dark dot at the left bottom corner.
1781 | EmbedDarkDotAtLeftBottomCorner(Matrix);
1782 |
1783 | // Position adjustment patterns appear if version >= 2.
1784 | MaybeEmbedPositionAdjustmentPatterns(Version, Matrix);
1785 |
1786 | // Timing patterns should be embedded after position adj. patterns.
1787 | EmbedTimingPatterns(Matrix);
1788 | end;
1789 |
1790 | // Embed type information. On success, modify the matrix.
1791 | procedure TMatrixUtil.EmbedTypeInfo(ECLevel: TErrorCorrectionLevel;
1792 | MaskPattern: Integer; Matrix: TByteMatrix);
1793 | var
1794 | TypeInfoBits: TBitArray;
1795 | I: Integer;
1796 | Bit: Boolean;
1797 | X1, Y1: Integer;
1798 | X2, Y2: Integer;
1799 | begin
1800 | TypeInfoBits := TBitArray.Create;
1801 | try
1802 | MakeTypeInfoBits(ECLevel, MaskPattern, TypeInfoBits);
1803 |
1804 | for I := 0 to TypeInfoBits.GetSize - 1 do
1805 | begin
1806 | // Place bits in LSB to MSB order. LSB (least significant bit) is the last value in
1807 | // "typeInfoBits".
1808 | Bit := TypeInfoBits.Get(TypeInfoBits.GetSize - 1 - I);
1809 |
1810 | // Type info bits at the left top corner. See 8.9 of JISX0510:2004 (p.46).
1811 | X1 := TYPE_INFO_COORDINATES[I][0];
1812 | Y1 := TYPE_INFO_COORDINATES[I][1];
1813 | Matrix.SetBoolean(X1, Y1, Bit);
1814 |
1815 | if I < 8 then
1816 | begin
1817 | // Right top corner.
1818 | X2 := Matrix.Width - I - 1;
1819 | Y2 := 8;
1820 | Matrix.SetBoolean(X2, Y2, Bit);
1821 | end else
1822 | begin
1823 | // Left bottom corner.
1824 | X2 := 8;
1825 | Y2 := Matrix.Height - 7 + (I - 8);
1826 | Matrix.SetBoolean(X2, Y2, Bit);
1827 | end;
1828 | end;
1829 | finally
1830 | TypeInfoBits.Free;
1831 | end;
1832 | end;
1833 |
1834 | // Embed version information if need be. On success, modify the matrix and return true.
1835 | // See 8.10 of JISX0510:2004 (p.47) for how to embed version information.
1836 | procedure TMatrixUtil.MaybeEmbedVersionInfo(Version: Integer; Matrix:
1837 | TByteMatrix);
1838 | var
1839 | VersionInfoBits: TBitArray;
1840 | I, J: Integer;
1841 | BitIndex: Integer;
1842 | Bit: Boolean;
1843 | begin
1844 | if Version >= 7 then // otherwise don't need version info.
1845 | begin
1846 | VersionInfoBits := TBitArray.Create;
1847 | try
1848 | MakeVersionInfoBits(Version, VersionInfoBits);
1849 |
1850 | BitIndex := 6 * 3 - 1; // It will decrease from 17 to 0.
1851 | for I := 0 to 5 do
1852 | for J := 0 to 2 do
1853 | begin
1854 | // Place bits in LSB (least significant bit) to MSB order.
1855 | Bit := VersionInfoBits.Get(BitIndex);
1856 | Dec(BitIndex);
1857 | // Left bottom corner.
1858 | Matrix.SetBoolean(I, Matrix.Height - 11 + J, Bit);
1859 | // Right bottom corner.
1860 | Matrix.SetBoolean(Matrix.Height - 11 + J, I, bit);
1861 | end;
1862 | finally
1863 | VersionInfoBits.Free;
1864 | end;
1865 | end;
1866 | end;
1867 |
1868 | // Embed "dataBits" using "getMaskPattern". On success, modify the matrix and return true.
1869 | // For debugging purposes, it skips masking process if "getMaskPattern" is -1.
1870 | // See 8.7 of JISX0510:2004 (p.38) for how to embed data bits.
1871 | procedure TMatrixUtil.EmbedDataBits(DataBits: TBitArray; MaskPattern: Integer;
1872 | Matrix: TByteMatrix);
1873 | var
1874 | BitIndex: Integer;
1875 | Direction: Integer;
1876 | X, Y, I, XX: Integer;
1877 | Bit: Boolean;
1878 | begin
1879 | bitIndex := 0;
1880 | direction := -1;
1881 | // Start from the right bottom cell.
1882 | X := Matrix.Width - 1;
1883 | Y := Matrix.Height - 1;
1884 | while X > 0 do
1885 | begin
1886 | // Skip the vertical timing pattern.
1887 | if X = 6 then
1888 | Dec(X, 1);
1889 | while (Y >= 0) and (Y < Matrix.Height) do
1890 | begin
1891 | for I := 0 to 1 do
1892 | begin
1893 | XX := X - I;
1894 | // Skip the cell if it's not empty.
1895 | if not IsEmpty(Matrix.Get(XX, Y)) then
1896 | Continue;
1897 |
1898 | if BitIndex < DataBits.GetSize then
1899 | begin
1900 | Bit := DataBits.Get(BitIndex);
1901 | Inc(BitIndex);
1902 | end else
1903 | // Padding bit. If there is no bit left, we'll fill the left cells
1904 | // with 0, as described in 8.4.9 of JISX0510:2004 (p. 24).
1905 | Bit := False;
1906 |
1907 | // Skip masking if mask_pattern is -1.
1908 | if (MaskPattern <> -1) and GetDataMaskBit(MaskPattern, XX, Y)
1909 | then
1910 | Bit := not Bit;
1911 | Matrix.SetBoolean(XX, Y, Bit);
1912 | end;
1913 | Inc(Y, Direction);
1914 | end;
1915 | Direction := -Direction; // Reverse the direction.
1916 | Inc(Y, Direction);
1917 | Dec(X, 2); // Move to the left.
1918 | end;
1919 |
1920 | // All bits should be consumed.
1921 | if BitIndex <> DataBits.GetSize then
1922 | FMatrixUtilError := True;
1923 | end;
1924 |
1925 | // Return the position of the most significant bit set (to one) in the "value". The most
1926 | // significant bit is position 32. If there is no bit set, return 0. Examples:
1927 | // - findMSBSet(0) => 0
1928 | // - findMSBSet(1) => 1
1929 | // - findMSBSet(255) => 8
1930 | function TMatrixUtil.FindMSBSet(Value: Integer): Integer;
1931 | var
1932 | NumDigits: Integer;
1933 | begin
1934 | NumDigits := 0;
1935 | while (Value <> 0) do
1936 | begin
1937 | Value := Value shr 1;
1938 | Inc(NumDigits);
1939 | end;
1940 | Result := NumDigits;
1941 | end;
1942 |
1943 | // Calculate BCH (Bose-Chaudhuri-Hocquenghem) code for "value" using polynomial "poly". The BCH
1944 | // code is used for encoding type information and version information.
1945 | // Example: Calculation of version information of 7.
1946 | // f(x) is created from 7.
1947 | // - 7 = 000111 in 6 bits
1948 | // - f(x) = x^2 + x^1 + x^0
1949 | // g(x) is given by the standard (p. 67)
1950 | // - g(x) = x^12 + x^11 + x^10 + x^9 + x^8 + x^5 + x^2 + 1
1951 | // Multiply f(x) by x^(18 - 6)
1952 | // - f'(x) = f(x) * x^(18 - 6)
1953 | // - f'(x) = x^14 + x^13 + x^12
1954 | // Calculate the remainder of f'(x) / g(x)
1955 | // x^2
1956 | // __________________________________________________
1957 | // g(x) )x^14 + x^13 + x^12
1958 | // x^14 + x^13 + x^12 + x^11 + x^10 + x^7 + x^4 + x^2
1959 | // --------------------------------------------------
1960 | // x^11 + x^10 + x^7 + x^4 + x^2
1961 | //
1962 | // The remainder is x^11 + x^10 + x^7 + x^4 + x^2
1963 | // Encode it in binary: 110010010100
1964 | // The return value is 0xc94 (1100 1001 0100)
1965 | //
1966 | // Since all coefficients in the polynomials are 1 or 0, we can do the calculation by bit
1967 | // operations. We don't care if cofficients are positive or negative.
1968 | function TMatrixUtil.CalculateBCHCode(Value, Poly: Integer): Integer;
1969 | var
1970 | MSBSetInPoly: Integer;
1971 | begin
1972 | // If poly is "1 1111 0010 0101" (version info poly), msbSetInPoly is 13. We'll subtract 1
1973 | // from 13 to make it 12.
1974 | MSBSetInPoly := FindMSBSet(Poly);
1975 | Value := Value shl (MSBSetInPoly - 1);
1976 | // Do the division business using exclusive-or operations.
1977 | while (FindMSBSet(Value) >= MSBSetInPoly) do
1978 | Value := Value xor (Poly shl (FindMSBSet(Value) - MSBSetInPoly));
1979 | // Now the "value" is the remainder (i.e. the BCH code)
1980 | Result := Value;
1981 | end;
1982 |
1983 | // Make bit vector of type information. On success, store the result in "bits" and return true.
1984 | // Encode error correction level and mask pattern. See 8.9 of
1985 | // JISX0510:2004 (p.45) for details.
1986 | procedure TMatrixUtil.MakeTypeInfoBits(ECLevel: TErrorCorrectionLevel;
1987 | MaskPattern: Integer; Bits: TBitArray);
1988 | var
1989 | TypeInfo: Integer;
1990 | BCHCode: Integer;
1991 | MaskBits: TBitArray;
1992 | begin
1993 | if (MaskPattern >= 0) and (MaskPattern < NUM_MASK_PATTERNS) then
1994 | begin
1995 | TypeInfo := (ECLevel.Bits shl 3) or MaskPattern;
1996 | Bits.AppendBits(TypeInfo, 5);
1997 |
1998 | BCHCode := CalculateBCHCode(TypeInfo, TYPE_INFO_POLY);
1999 | Bits.AppendBits(BCHCode, 10);
2000 |
2001 | MaskBits := TBitArray.Create;
2002 | try
2003 | MaskBits.AppendBits(TYPE_INFO_MASK_PATTERN, 15);
2004 | Bits.XorOperation(MaskBits);
2005 | finally
2006 | MaskBits.Free;
2007 | end;
2008 |
2009 | if Bits.GetSize <> 15 then // Just in case.
2010 | FMatrixUtilError := True;
2011 | end;
2012 | end;
2013 |
2014 | // Return the mask bit for "getMaskPattern" at "x" and "y". See 8.8 of JISX0510:2004 for mask
2015 | // pattern conditions.
2016 | function TMatrixUtil.GetDataMaskBit(MaskPattern, X, Y: Integer): Boolean;
2017 | var
2018 | Intermediate: Integer;
2019 | Temp: Integer;
2020 | begin
2021 | Intermediate := 0;
2022 | if (MaskPattern >= 0) and (MaskPattern < NUM_MASK_PATTERNS) then
2023 | case (MaskPattern) of
2024 | 0: Intermediate := (Y + X) and 1;
2025 | 1: Intermediate := Y and 1;
2026 | 2: Intermediate := X mod 3;
2027 | 3: Intermediate := (Y + X) mod 3;
2028 | 4: Intermediate := ((y shr 1) + (X div 3)) and 1;
2029 | 5:
2030 | begin
2031 | Temp := Y * X;
2032 | Intermediate := (Temp and 1) + (Temp mod 3);
2033 | end;
2034 | 6:
2035 | begin
2036 | Temp := Y * X;
2037 | Intermediate := ((Temp and 1) + (Temp mod 3)) and 1;
2038 | end;
2039 | 7:
2040 | begin
2041 | Temp := Y * X;
2042 | Intermediate := ((temp mod 3) + ((Y + X) and 1)) and 1;
2043 | end;
2044 | end;
2045 | Result := Intermediate = 0;
2046 | end;
2047 |
2048 | // Make bit vector of version information. On success, store the result in "bits" and return true.
2049 | // See 8.10 of JISX0510:2004 (p.45) for details.
2050 | procedure TMatrixUtil.MakeVersionInfoBits(Version: Integer; Bits: TBitArray);
2051 | var
2052 | BCHCode: Integer;
2053 | begin
2054 | Bits.AppendBits(Version, 6);
2055 | BCHCode := CalculateBCHCode(Version, VERSION_INFO_POLY);
2056 | Bits.AppendBits(BCHCode, 12);
2057 |
2058 | if Bits.GetSize() <> 18 then
2059 | FMatrixUtilError := True;
2060 | end;
2061 |
2062 | // Check if "value" is empty.
2063 | function TMatrixUtil.IsEmpty(Value: Integer): Boolean;
2064 | begin
2065 | Result := (Value = -1);
2066 | end;
2067 |
2068 | procedure TMatrixUtil.EmbedTimingPatterns(Matrix: TByteMatrix);
2069 | var
2070 | I: Integer;
2071 | Bit: Integer;
2072 | begin
2073 | // -8 is for skipping position detection patterns (size 7), and two
2074 | // horizontal/vertical separation patterns (size 1). Thus, 8 = 7 + 1.
2075 | for I := 8 to Matrix.Width - 9 do
2076 | begin
2077 | Bit := (I + 1) mod 2;
2078 | // Horizontal line.
2079 | if IsEmpty(Matrix.Get(I, 6)) then
2080 | Matrix.SetInteger(I, 6, Bit);
2081 | // Vertical line.
2082 | if IsEmpty(Matrix.Get(6, I)) then
2083 | Matrix.SetInteger(6, I, Bit);
2084 | end;
2085 | end;
2086 |
2087 | // Embed the lonely dark dot at left bottom corner. JISX0510:2004 (p.46)
2088 | procedure TMatrixUtil.EmbedDarkDotAtLeftBottomCorner(Matrix: TByteMatrix);
2089 | begin
2090 | if Matrix.Get(8, Matrix.Height - 8) = 0 then
2091 | FMatrixUtilError := True
2092 | else
2093 | Matrix.SetInteger(8, Matrix.Height - 8, 1);
2094 | end;
2095 |
2096 | procedure TMatrixUtil.EmbedHorizontalSeparationPattern(XStart, YStart: Integer;
2097 | Matrix: TByteMatrix);
2098 | var
2099 | X: Integer;
2100 | begin
2101 | // We know the width and height.
2102 | for X := 0 to 7 do
2103 | begin
2104 | if not IsEmpty(Matrix.Get(XStart + X, YStart)) then
2105 | begin
2106 | FMatrixUtilError := True;
2107 | Exit;
2108 | end;
2109 | Matrix.SetInteger(XStart + X, YStart, HORIZONTAL_SEPARATION_PATTERN[0][X]);
2110 | end;
2111 | end;
2112 |
2113 | procedure TMatrixUtil.EmbedVerticalSeparationPattern(XStart, YStart: Integer;
2114 | Matrix: TByteMatrix);
2115 | var
2116 | Y: Integer;
2117 | begin
2118 | // We know the width and height.
2119 | for Y := 0 to 6 do
2120 | begin
2121 | if not IsEmpty(Matrix.Get(XStart, YStart + Y)) then
2122 | begin
2123 | FMatrixUtilError := True;
2124 | Exit;
2125 | end;
2126 | Matrix.SetInteger(XStart, YStart + Y, VERTICAL_SEPARATION_PATTERN[Y][0]);
2127 | end;
2128 | end;
2129 |
2130 | // Note that we cannot unify the function with embedPositionDetectionPattern() despite they are
2131 | // almost identical, since we cannot write a function that takes 2D arrays in different sizes in
2132 | // C/C++. We should live with the fact.
2133 | procedure TMatrixUtil.EmbedPositionAdjustmentPattern(XStart, YStart: Integer;
2134 | Matrix: TByteMatrix);
2135 | var
2136 | X, Y: Integer;
2137 | begin
2138 | // We know the width and height.
2139 | for Y := 0 to 4 do
2140 | for X := 0 to 4 do
2141 | begin
2142 | if not IsEmpty(Matrix.Get(XStart + X, YStart + Y)) then
2143 | begin
2144 | FMatrixUtilError := True;
2145 | Exit;
2146 | end;
2147 | Matrix.SetInteger(XStart + X, YStart + Y, POSITION_ADJUSTMENT_PATTERN[Y][X]);
2148 | end;
2149 | end;
2150 |
2151 | procedure TMatrixUtil.EmbedPositionDetectionPattern(XStart, YStart: Integer;
2152 | Matrix: TByteMatrix);
2153 | var
2154 | X, Y: Integer;
2155 | begin
2156 | // We know the width and height.
2157 | for Y := 0 to 6 do
2158 | for X := 0 to 6 do
2159 | begin
2160 | if not IsEmpty(Matrix.Get(XStart + X, YStart + Y)) then
2161 | begin
2162 | FMatrixUtilError := True;
2163 | Exit;
2164 | end;
2165 | Matrix.SetInteger(XStart + X, YStart + Y,
2166 | POSITION_DETECTION_PATTERN[Y][X]);
2167 | end;
2168 | end;
2169 |
2170 | // Embed position detection patterns and surrounding vertical/horizontal separators.
2171 | procedure TMatrixUtil.EmbedPositionDetectionPatternsAndSeparators(Matrix:
2172 | TByteMatrix);
2173 | var
2174 | PDPWidth: Integer;
2175 | HSPWidth: Integer;
2176 | VSPSize: Integer;
2177 | begin
2178 | // Embed three big squares at corners.
2179 | PDPWidth := Length(POSITION_DETECTION_PATTERN[0]);
2180 | // Left top corner.
2181 | EmbedPositionDetectionPattern(0, 0, Matrix);
2182 | // Right top corner.
2183 | EmbedPositionDetectionPattern(Matrix.Width - PDPWidth, 0, Matrix);
2184 | // Left bottom corner.
2185 | EmbedPositionDetectionPattern(0, Matrix.Width- PDPWidth, Matrix);
2186 |
2187 | // Embed horizontal separation patterns around the squares.
2188 | HSPWidth := Length(HORIZONTAL_SEPARATION_PATTERN[0]);
2189 | // Left top corner.
2190 | EmbedHorizontalSeparationPattern(0, HSPWidth - 1, Matrix);
2191 | // Right top corner.
2192 | EmbedHorizontalSeparationPattern(Matrix.Width - HSPWidth,
2193 | HSPWidth - 1, Matrix);
2194 | // Left bottom corner.
2195 | EmbedHorizontalSeparationPattern(0, Matrix.Width - HSPWidth, Matrix);
2196 |
2197 | // Embed vertical separation patterns around the squares.
2198 | VSPSize := Length(VERTICAL_SEPARATION_PATTERN);
2199 | // Left top corner.
2200 | EmbedVerticalSeparationPattern(VSPSize, 0, Matrix);
2201 | // Right top corner.
2202 | EmbedVerticalSeparationPattern(Matrix.Height - VSPSize - 1, 0, Matrix);
2203 | // Left bottom corner.
2204 | EmbedVerticalSeparationPattern(VSPSize, Matrix.Height - VSPSize, Matrix);
2205 | end;
2206 |
2207 | // Embed position adjustment patterns if need be.
2208 | procedure TMatrixUtil.MaybeEmbedPositionAdjustmentPatterns(Version: Integer;
2209 | Matrix: TByteMatrix);
2210 | var
2211 | Index: Integer;
2212 | Coordinates: array of Integer;
2213 | NumCoordinates: Integer;
2214 | X, Y, I, J: Integer;
2215 | begin
2216 | if Version >= 2 then
2217 | begin
2218 | Index := Version - 1;
2219 | NumCoordinates := Length(POSITION_ADJUSTMENT_PATTERN_COORDINATE_TABLE[Index]);
2220 | SetLength(Coordinates, NumCoordinates);
2221 | Move(POSITION_ADJUSTMENT_PATTERN_COORDINATE_TABLE[Index][0], Coordinates[0],
2222 | NumCoordinates * SizeOf(Integer));
2223 | for I := 0 to NumCoordinates - 1 do
2224 | for J := 0 to NumCoordinates - 1 do
2225 | begin
2226 | Y := Coordinates[I];
2227 | X := Coordinates[J];
2228 | if ((X = -1) or (Y = -1)) then
2229 | Continue;
2230 | // If the cell is unset, we embed the position adjustment pattern here.
2231 | if (IsEmpty(Matrix.Get(X, Y))) then
2232 | // -2 is necessary since the x/y coordinates point to the center of the pattern, not the
2233 | // left top corner.
2234 | EmbedPositionAdjustmentPattern(X - 2, Y - 2, Matrix);
2235 | end;
2236 | end;
2237 | end;
2238 |
2239 | { TBitArray }
2240 |
2241 | procedure TBitArray.AppendBits(Value, NumBits: Integer);
2242 | var
2243 | NumBitsLeft: Integer;
2244 | begin
2245 | if (NumBits >= 0) and (NumBits <= 32) then
2246 | begin
2247 | EnsureCapacity(FSize + NumBits);
2248 | for NumBitsLeft := NumBits downto 1 do
2249 | AppendBit(((Value shr (NumBitsLeft - 1)) and $01) = 1);
2250 | end;
2251 | end;
2252 |
2253 | constructor TBitArray.Create(Size: Integer);
2254 | begin
2255 | FSize := Size;
2256 | SetLength(FBits, (FSize + 31) shr 5);
2257 | end;
2258 |
2259 | constructor TBitArray.Create;
2260 | begin
2261 | FSize := 0;
2262 | SetLength(FBits, 1);
2263 | end;
2264 |
2265 | function TBitArray.Get(I: Integer): Boolean;
2266 | begin
2267 | Result := (FBits[I shr 5] and (1 shl (I and $1F))) <> 0;
2268 | end;
2269 |
2270 | function TBitArray.GetSize: Integer;
2271 | begin
2272 | Result := FSize;
2273 | end;
2274 |
2275 | function TBitArray.GetSizeInBytes: Integer;
2276 | begin
2277 | Result := (FSize + 7) shr 3;
2278 | end;
2279 |
2280 | procedure TBitArray.SetBit(Index: Integer);
2281 | begin
2282 | FBits[Index shr 5] := FBits[Index shr 5] or (1 shl (Index and $1F));
2283 | end;
2284 |
2285 | procedure TBitArray.AppendBit(Bit: Boolean);
2286 | begin
2287 | EnsureCapacity(FSize + 1);
2288 | if Bit then
2289 | FBits[FSize shr 5] := FBits[FSize shr 5] or (1 shl (FSize and $1F));
2290 | Inc(FSize);
2291 | end;
2292 |
2293 | procedure TBitArray.ToBytes(BitOffset: Integer; Source: TByteArray; Offset,
2294 | NumBytes: Integer);
2295 | var
2296 | I: Integer;
2297 | J: Integer;
2298 | TheByte: Integer;
2299 | begin
2300 | for I := 0 to NumBytes - 1 do
2301 | begin
2302 | TheByte := 0;
2303 | for J := 0 to 7 do
2304 | begin
2305 | if Get(BitOffset) then
2306 | TheByte := TheByte or (1 shl (7 - J));
2307 | Inc(BitOffset);
2308 | end;
2309 | Source[Offset + I] := TheByte;
2310 | end;
2311 | end;
2312 |
2313 | procedure TBitArray.XorOperation(Other: TBitArray);
2314 | var
2315 | I: Integer;
2316 | begin
2317 | if Length(FBits) = Length(Other.FBits) then
2318 | for I := 0 to Length(FBits) - 1 do
2319 | // The last byte could be incomplete (i.e. not have 8 bits in
2320 | // it) but there is no problem since 0 XOR 0 == 0.
2321 | FBits[I] := FBits[I] xor Other.FBits[I];
2322 | end;
2323 |
2324 | procedure TBitArray.AppendBitArray(NewBitArray: TBitArray);
2325 | var
2326 | OtherSize: Integer;
2327 | I: Integer;
2328 | begin
2329 | OtherSize := NewBitArray.GetSize;
2330 | EnsureCapacity(FSize + OtherSize);
2331 | for I := 0 to OtherSize - 1 do
2332 | AppendBit(NewBitArray.Get(I));
2333 | end;
2334 |
2335 | procedure TBitArray.EnsureCapacity(Size: Integer);
2336 | begin
2337 | if Size > (Length(FBits) shl 5) then
2338 | SetLength(FBits, Size);
2339 | end;
2340 |
2341 | { TErrorCorrectionLevel }
2342 |
2343 | procedure TErrorCorrectionLevel.Assign(Source: TErrorCorrectionLevel);
2344 | begin
2345 | Self.FBits := Source.FBits;
2346 | Self.FOrdinal := Source.FOrdinal;
2347 | end;
2348 |
2349 | procedure TErrorCorrectionLevel.SetOrdinal(Value: TErrorCorrectionOrdinal);
2350 | begin
2351 | FOrdinal := Value;
2352 | FBits := ErrorCorrectionDescriptors[Value];
2353 | end;
2354 |
2355 | { TVersion }
2356 |
2357 | class function TVersion.ChooseVersion(NumInputBits: Integer;
2358 | ECLevel: TErrorCorrectionLevel): TVersion;
2359 | var
2360 | VersionNum: Integer;
2361 | Version: TVersion;
2362 | NumBytes: Integer;
2363 | ECBlocks: TECBlocks;
2364 | NumECBytes: Integer;
2365 | NumDataBytes: Integer;
2366 | TotalInputBytes: Integer;
2367 | begin
2368 | Result := nil;
2369 | // In the following comments, we use numbers of Version 7-H.
2370 | for VersionNum := 1 to 40 do
2371 | begin
2372 | Version := TVersion.GetVersionForNumber(VersionNum);
2373 |
2374 | // numBytes = 196
2375 | NumBytes := Version.GetTotalCodewords;
2376 | // getNumECBytes = 130
2377 | ECBlocks := Version.GetECBlocksForLevel(ECLevel);
2378 | NumECBytes := ECBlocks.GetTotalECCodewords;
2379 | // getNumDataBytes = 196 - 130 = 66
2380 | NumDataBytes := NumBytes - NumECBytes;
2381 | TotalInputBytes := (NumInputBits + 7) div 8;
2382 |
2383 | if numDataBytes >= totalInputBytes then
2384 | begin
2385 | Result := Version;
2386 | Break;
2387 | end else
2388 | Version.Free;
2389 | end;
2390 | end;
2391 |
2392 | constructor TVersion.Create(VersionNumber: Integer;
2393 | AlignmentPatternCenters: array of Integer; ECBlocks1, ECBlocks2, ECBlocks3,
2394 | ECBlocks4: TECBlocks);
2395 | var
2396 | Total: Integer;
2397 | ECBlock: TECB;
2398 | ECBArray: TECBArray;
2399 | I: Integer;
2400 | begin
2401 | FVersionNumber := VersionNumber;
2402 | SetLength(FAlignmentPatternCenters, Length(AlignmentPatternCenters));
2403 | if Length(AlignmentPatternCenters) > 0 then
2404 | Move(AlignmentPatternCenters[0], FAlignmentPatternCenters[0],
2405 | Length(AlignmentPatternCenters) * SizeOf(Integer));
2406 | SetLength(FECBlocks, 4);
2407 | FECBlocks[0] := ECBlocks1;
2408 | FECBlocks[1] := ECBlocks2;
2409 | FECBlocks[2] := ECBlocks3;
2410 | FECBlocks[3] := ECBlocks4;
2411 | Total := 0;
2412 | FECCodewords := ECBlocks1.GetECCodewordsPerBlock;
2413 | ECBArray := ECBlocks1.GetECBlocks;
2414 | for I := 0 to Length(ECBArray) - 1 do
2415 | begin
2416 | ECBlock := ECBArray[I];
2417 | Inc(Total, ECBlock.Count * (ECBlock.DataCodewords + FECCodewords));
2418 | end;
2419 | FTotalCodewords := Total;
2420 | end;
2421 |
2422 | destructor TVersion.Destroy;
2423 | var
2424 | X: Integer;
2425 | begin
2426 | for X := 0 to Length(FECBlocks) - 1 do
2427 | FECBlocks[X].Free;
2428 | inherited;
2429 | end;
2430 |
2431 | function TVersion.GetDimensionForVersion: Integer;
2432 | begin
2433 | Result := 17 + 4 * VersionNumber;
2434 | end;
2435 |
2436 | function TVersion.GetECBlocksForLevel(ECLevel: TErrorCorrectionLevel):
2437 | TECBlocks;
2438 | begin
2439 | Result := FECBlocks[Ord(ECLevel.Ordinal)];
2440 | end;
2441 |
2442 | function TVersion.GetTotalCodewords: Integer;
2443 | begin
2444 | Result := FTotalCodewords;
2445 | end;
2446 |
2447 | class function TVersion.GetVersionForNumber(VersionNum: Integer): TVersion;
2448 |
2449 | function MakeECB(Count, DataCodewords: Integer): TECB;
2450 | begin
2451 | Result.Count := Count;
2452 | Result.DataCodewords := DataCodewords;
2453 | end;
2454 |
2455 | begin
2456 | case VersionNum of
2457 | 1:
2458 | Result := TVersion.Create(1, [],
2459 | TECBlocks.Create(7, MakeECB(1, 19)),
2460 | TECBlocks.Create(10, MakeECB(1, 16)),
2461 | TECBlocks.Create(13, MakeECB(1, 13)),
2462 | TECBlocks.Create(17, MakeECB(1, 9)));
2463 | 2:
2464 | Result := TVersion.Create(2, [6, 18],
2465 | TECBlocks.Create(10, MakeECB(1, 34)),
2466 | TECBlocks.Create(16, MakeECB(1, 28)),
2467 | TECBlocks.Create(22, MakeECB(1, 22)),
2468 | TECBlocks.Create(28, MakeECB(1, 16)));
2469 | 3:
2470 | Result := TVersion.Create(3, [6, 22],
2471 | TECBlocks.Create(15, MakeECB(1, 55)),
2472 | TECBlocks.Create(26, MakeECB(1, 44)),
2473 | TECBlocks.Create(18, MakeECB(2, 17)),
2474 | TECBlocks.Create(22, MakeECB(2, 13)));
2475 | 4:
2476 | Result := TVersion.Create(4, [6, 26],
2477 | TECBlocks.Create(20, MakeECB(1, 80)),
2478 | TECBlocks.Create(18, MakeECB(2, 32)),
2479 | TECBlocks.Create(26, MakeECB(2, 24)),
2480 | TECBlocks.Create(16, MakeECB(4, 9)));
2481 | 5:
2482 | Result := TVersion.Create(5, [6, 30],
2483 | TECBlocks.Create(26, MakeECB(1, 108)),
2484 | TECBlocks.Create(24, MakeECB(2, 43)),
2485 | TECBlocks.Create(18, MakeECB(2, 15), MakeECB(2, 16)),
2486 | TECBlocks.Create(22, MakeECB(2, 11), MakeECB(2, 12)));
2487 | 6:
2488 | Result := TVersion.Create(6, [6, 34],
2489 | TECBlocks.Create(18, MakeECB(2, 68)),
2490 | TECBlocks.Create(16, MakeECB(4, 27)),
2491 | TECBlocks.Create(24, MakeECB(4, 19)),
2492 | TECBlocks.Create(28, MakeECB(4, 15)));
2493 | 7:
2494 | Result := TVersion.Create(7, [6, 22, 38],
2495 | TECBlocks.Create(20, MakeECB(2, 78)),
2496 | TECBlocks.Create(18, MakeECB(4, 31)),
2497 | TECBlocks.Create(18, MakeECB(2, 14), MakeECB(4, 15)),
2498 | TECBlocks.Create(26, MakeECB(4, 13), MakeECB(1, 14)));
2499 | 8:
2500 | Result := TVersion.Create(8, [6, 24, 42],
2501 | TECBlocks.Create(24, MakeECB(2, 97)),
2502 | TECBlocks.Create(22, MakeECB(2, 38), MakeECB(2, 39)),
2503 | TECBlocks.Create(22, MakeECB(4, 18), MakeECB(2, 19)),
2504 | TECBlocks.Create(26, MakeECB(4, 14), MakeECB(2, 15)));
2505 | 9:
2506 | Result := TVersion.Create(9, [6, 26, 46],
2507 | TECBlocks.Create(30, MakeECB(2, 116)),
2508 | TECBlocks.Create(22, MakeECB(3, 36), MakeECB(2, 37)),
2509 | TECBlocks.Create(20, MakeECB(4, 16), MakeECB(4, 17)),
2510 | TECBlocks.Create(24, MakeECB(4, 12), MakeECB(4, 13)));
2511 | 10:
2512 | Result := TVersion.Create(10, [6, 28, 50],
2513 | TECBlocks.Create(18, MakeECB(2, 68), MakeECB(2, 69)),
2514 | TECBlocks.Create(26, MakeECB(4, 43), MakeECB(1, 44)),
2515 | TECBlocks.Create(24, MakeECB(6, 19), MakeECB(2, 20)),
2516 | TECBlocks.Create(28, MakeECB(6, 15), MakeECB(2, 16)));
2517 | 11:
2518 | Result := TVersion.Create(11, [6, 30, 54],
2519 | TECBlocks.Create(20, MakeECB(4, 81)),
2520 | TECBlocks.Create(30, MakeECB(1, 50), MakeECB(4, 51)),
2521 | TECBlocks.Create(28, MakeECB(4, 22), MakeECB(4, 23)),
2522 | TECBlocks.Create(24, MakeECB(3, 12), MakeECB(8, 13)));
2523 | 12:
2524 | Result := TVersion.Create(12, [6, 32, 58],
2525 | TECBlocks.Create(24, MakeECB(2, 92), MakeECB(2, 93)),
2526 | TECBlocks.Create(22, MakeECB(6, 36), MakeECB(2, 37)),
2527 | TECBlocks.Create(26, MakeECB(4, 20), MakeECB(6, 21)),
2528 | TECBlocks.Create(28, MakeECB(7, 14), MakeECB(4, 15)));
2529 | 13:
2530 | Result := TVersion.Create(13, [6, 34, 62],
2531 | TECBlocks.Create(26, MakeECB(4, 107)),
2532 | TECBlocks.Create(22, MakeECB(8, 37), MakeECB(1, 38)),
2533 | TECBlocks.Create(24, MakeECB(8, 20), MakeECB(4, 21)),
2534 | TECBlocks.Create(22, MakeECB(12, 11), MakeECB(4, 12)));
2535 | 14:
2536 | Result := TVersion.Create(14, [6, 26, 46, 66],
2537 | TECBlocks.Create(30, MakeECB(3, 115), MakeECB(1, 116)),
2538 | TECBlocks.Create(24, MakeECB(4, 40), MakeECB(5, 41)),
2539 | TECBlocks.Create(20, MakeECB(11, 16), MakeECB(5, 17)),
2540 | TECBlocks.Create(24, MakeECB(11, 12), MakeECB(5, 13)));
2541 | 15:
2542 | Result := TVersion.Create(15, [6, 26, 48, 70],
2543 | TECBlocks.Create(22, MakeECB(5, 87), MakeECB(1, 88)),
2544 | TECBlocks.Create(24, MakeECB(5, 41), MakeECB(5, 42)),
2545 | TECBlocks.Create(30, MakeECB(5, 24), MakeECB(7, 25)),
2546 | TECBlocks.Create(24, MakeECB(11, 12), MakeECB(7, 13)));
2547 | 16:
2548 | Result := TVersion.Create(16, [6, 26, 50, 74],
2549 | TECBlocks.Create(24, MakeECB(5, 98), MakeECB(1, 99)),
2550 | TECBlocks.Create(28, MakeECB(7, 45), MakeECB(3, 46)),
2551 | TECBlocks.Create(24, MakeECB(15, 19), MakeECB(2, 20)),
2552 | TECBlocks.Create(30, MakeECB(3, 15), MakeECB(13, 16)));
2553 | 17:
2554 | Result := TVersion.Create(17, [6, 30, 54, 78],
2555 | TECBlocks.Create(28, MakeECB(1, 107), MakeECB(5, 108)),
2556 | TECBlocks.Create(28, MakeECB(10, 46), MakeECB(1, 47)),
2557 | TECBlocks.Create(28, MakeECB(1, 22), MakeECB(15, 23)),
2558 | TECBlocks.Create(28, MakeECB(2, 14), MakeECB(17, 15)));
2559 | 18:
2560 | Result := TVersion.Create(18, [6, 30, 56, 82],
2561 | TECBlocks.Create(30, MakeECB(5, 120), MakeECB(1, 121)),
2562 | TECBlocks.Create(26, MakeECB(9, 43), MakeECB(4, 44)),
2563 | TECBlocks.Create(28, MakeECB(17, 22), MakeECB(1, 23)),
2564 | TECBlocks.Create(28, MakeECB(2, 14), MakeECB(19, 15)));
2565 | 19:
2566 | Result := TVersion.Create(19, [6, 30, 58, 86],
2567 | TECBlocks.Create(28, MakeECB(3, 113), MakeECB(4, 114)),
2568 | TECBlocks.Create(26, MakeECB(3, 44), MakeECB(11, 45)),
2569 | TECBlocks.Create(26, MakeECB(17, 21), MakeECB(4, 22)),
2570 | TECBlocks.Create(26, MakeECB(9, 13), MakeECB(16, 14)));
2571 | 20:
2572 | Result := TVersion.Create(20, [6, 34, 62, 90],
2573 | TECBlocks.Create(28, MakeECB(3, 107), MakeECB(5, 108)),
2574 | TECBlocks.Create(26, MakeECB(3, 41), MakeECB(13, 42)),
2575 | TECBlocks.Create(30, MakeECB(15, 24), MakeECB(5, 25)),
2576 | TECBlocks.Create(28, MakeECB(15, 15), MakeECB(10, 16)));
2577 | 21:
2578 | Result := TVersion.Create(21, [6, 28, 50, 72, 94],
2579 | TECBlocks.Create(28, MakeECB(4, 116), MakeECB(4, 117)),
2580 | TECBlocks.Create(26, MakeECB(17, 42)),
2581 | TECBlocks.Create(28, MakeECB(17, 22), MakeECB(6, 23)),
2582 | TECBlocks.Create(30, MakeECB(19, 16), MakeECB(6, 17)));
2583 | 22:
2584 | Result := TVersion.Create(22, [6, 26, 50, 74, 98],
2585 | TECBlocks.Create(28, MakeECB(2, 111), MakeECB(7, 112)),
2586 | TECBlocks.Create(28, MakeECB(17, 46)),
2587 | TECBlocks.Create(30, MakeECB(7, 24), MakeECB(16, 25)),
2588 | TECBlocks.Create(24, MakeECB(34, 13)));
2589 | 23:
2590 | Result := TVersion.Create(23, [6, 30, 54, 78, 102],
2591 | TECBlocks.Create(30, MakeECB(4, 121), MakeECB(5, 122)),
2592 | TECBlocks.Create(28, MakeECB(4, 47), MakeECB(14, 48)),
2593 | TECBlocks.Create(30, MakeECB(11, 24), MakeECB(14, 25)),
2594 | TECBlocks.Create(30, MakeECB(16, 15), MakeECB(14, 16)));
2595 | 24:
2596 | Result := TVersion.Create(24, [6, 28, 54, 80, 106],
2597 | TECBlocks.Create(30, MakeECB(6, 117), MakeECB(4, 118)),
2598 | TECBlocks.Create(28, MakeECB(6, 45), MakeECB(14, 46)),
2599 | TECBlocks.Create(30, MakeECB(11, 24), MakeECB(16, 25)),
2600 | TECBlocks.Create(30, MakeECB(30, 16), MakeECB(2, 17)));
2601 | 25:
2602 | Result := TVersion.Create(25, [6, 32, 58, 84, 110],
2603 | TECBlocks.Create(26, MakeECB(8, 106), MakeECB(4, 107)),
2604 | TECBlocks.Create(28, MakeECB(8, 47), MakeECB(13, 48)),
2605 | TECBlocks.Create(30, MakeECB(7, 24), MakeECB(22, 25)),
2606 | TECBlocks.Create(30, MakeECB(22, 15), MakeECB(13, 16)));
2607 | 26:
2608 | Result := TVersion.Create(26, [6, 30, 58, 86, 114],
2609 | TECBlocks.Create(28, MakeECB(10, 114), MakeECB(2, 115)),
2610 | TECBlocks.Create(28, MakeECB(19, 46), MakeECB(4, 47)),
2611 | TECBlocks.Create(28, MakeECB(28, 22), MakeECB(6, 23)),
2612 | TECBlocks.Create(30, MakeECB(33, 16), MakeECB(4, 17)));
2613 | 27:
2614 | Result := TVersion.Create(27, [6, 34, 62, 90, 118],
2615 | TECBlocks.Create(30, MakeECB(8, 122), MakeECB(4, 123)),
2616 | TECBlocks.Create(28, MakeECB(22, 45), MakeECB(3, 46)),
2617 | TECBlocks.Create(30, MakeECB(8, 23), MakeECB(26, 24)),
2618 | TECBlocks.Create(30, MakeECB(12, 15), MakeECB(28, 16)));
2619 | 28:
2620 | Result := TVersion.Create(28, [6, 26, 50, 74, 98, 122],
2621 | TECBlocks.Create(30, MakeECB(3, 117), MakeECB(10, 118)),
2622 | TECBlocks.Create(28, MakeECB(3, 45), MakeECB(23, 46)),
2623 | TECBlocks.Create(30, MakeECB(4, 24), MakeECB(31, 25)),
2624 | TECBlocks.Create(30, MakeECB(11, 15), MakeECB(31, 16)));
2625 | 29:
2626 | Result := TVersion.Create(29, [6, 30, 54, 78, 102, 126],
2627 | TECBlocks.Create(30, MakeECB(7, 116), MakeECB(7, 117)),
2628 | TECBlocks.Create(28, MakeECB(21, 45), MakeECB(7, 46)),
2629 | TECBlocks.Create(30, MakeECB(1, 23), MakeECB(37, 24)),
2630 | TECBlocks.Create(30, MakeECB(19, 15), MakeECB(26, 16)));
2631 | 30:
2632 | Result := TVersion.Create(30, [6, 26, 52, 78, 104, 130],
2633 | TECBlocks.Create(30, MakeECB(5, 115), MakeECB(10, 116)),
2634 | TECBlocks.Create(28, MakeECB(19, 47), MakeECB(10, 48)),
2635 | TECBlocks.Create(30, MakeECB(15, 24), MakeECB(25, 25)),
2636 | TECBlocks.Create(30, MakeECB(23, 15), MakeECB(25, 16)));
2637 | 31:
2638 | Result := TVersion.Create(31, [6, 30, 56, 82, 108, 134],
2639 | TECBlocks.Create(30, MakeECB(13, 115), MakeECB(3, 116)),
2640 | TECBlocks.Create(28, MakeECB(2, 46), MakeECB(29, 47)),
2641 | TECBlocks.Create(30, MakeECB(42, 24), MakeECB(1, 25)),
2642 | TECBlocks.Create(30, MakeECB(23, 15), MakeECB(28, 16)));
2643 | 32:
2644 | Result := TVersion.Create(32, [6, 34, 60, 86, 112, 138],
2645 | TECBlocks.Create(30, MakeECB(17, 115)),
2646 | TECBlocks.Create(28, MakeECB(10, 46), MakeECB(23, 47)),
2647 | TECBlocks.Create(30, MakeECB(10, 24), MakeECB(35, 25)),
2648 | TECBlocks.Create(30, MakeECB(19, 15), MakeECB(35, 16)));
2649 | 33:
2650 | Result := TVersion.Create(33, [6, 30, 58, 86, 114, 142],
2651 | TECBlocks.Create(30, MakeECB(17, 115), MakeECB(1, 116)),
2652 | TECBlocks.Create(28, MakeECB(14, 46), MakeECB(21, 47)),
2653 | TECBlocks.Create(30, MakeECB(29, 24), MakeECB(19, 25)),
2654 | TECBlocks.Create(30, MakeECB(11, 15), MakeECB(46, 16)));
2655 | 34:
2656 | Result := TVersion.Create(34, [6, 34, 62, 90, 118, 146],
2657 | TECBlocks.Create(30, MakeECB(13, 115), MakeECB(6, 116)),
2658 | TECBlocks.Create(28, MakeECB(14, 46), MakeECB(23, 47)),
2659 | TECBlocks.Create(30, MakeECB(44, 24), MakeECB(7, 25)),
2660 | TECBlocks.Create(30, MakeECB(59, 16), MakeECB(1, 17)));
2661 | 35:
2662 | Result := TVersion.Create(35, [6, 30, 54, 78, 102, 126, 150],
2663 | TECBlocks.Create(30, MakeECB(12, 121), MakeECB(7, 122)),
2664 | TECBlocks.Create(28, MakeECB(12, 47), MakeECB(26, 48)),
2665 | TECBlocks.Create(30, MakeECB(39, 24), MakeECB(14, 25)),
2666 | TECBlocks.Create(30, MakeECB(22, 15), MakeECB(41, 16)));
2667 | 36:
2668 | Result := TVersion.Create(36, [6, 24, 50, 76, 102, 128, 154],
2669 | TECBlocks.Create(30, MakeECB(6, 121), MakeECB(14, 122)),
2670 | TECBlocks.Create(28, MakeECB(6, 47), MakeECB(34, 48)),
2671 | TECBlocks.Create(30, MakeECB(46, 24), MakeECB(10, 25)),
2672 | TECBlocks.Create(30, MakeECB(2, 15), MakeECB(64, 16)));
2673 | 37:
2674 | Result := TVersion.Create(37, [6, 28, 54, 80, 106, 132, 158],
2675 | TECBlocks.Create(30, MakeECB(17, 122), MakeECB(4, 123)),
2676 | TECBlocks.Create(28, MakeECB(29, 46), MakeECB(14, 47)),
2677 | TECBlocks.Create(30, MakeECB(49, 24), MakeECB(10, 25)),
2678 | TECBlocks.Create(30, MakeECB(24, 15), MakeECB(46, 16)));
2679 | 38:
2680 | Result := TVersion.Create(38, [6, 32, 58, 84, 110, 136, 162],
2681 | TECBlocks.Create(30, MakeECB(4, 122), MakeECB(18, 123)),
2682 | TECBlocks.Create(28, MakeECB(13, 46), MakeECB(32, 47)),
2683 | TECBlocks.Create(30, MakeECB(48, 24), MakeECB(14, 25)),
2684 | TECBlocks.Create(30, MakeECB(42, 15), MakeECB(32, 16)));
2685 | 39:
2686 | Result := TVersion.Create(39, [6, 26, 54, 82, 110, 138, 166],
2687 | TECBlocks.Create(30, MakeECB(20, 117), MakeECB(4, 118)),
2688 | TECBlocks.Create(28, MakeECB(40, 47), MakeECB(7, 48)),
2689 | TECBlocks.Create(30, MakeECB(43, 24), MakeECB(22, 25)),
2690 | TECBlocks.Create(30, MakeECB(10, 15), MakeECB(67, 16)));
2691 | 40:
2692 | Result := TVersion.Create(40, [6, 30, 58, 86, 114, 142, 170],
2693 | TECBlocks.Create(30, MakeECB(19, 118), MakeECB(6, 119)),
2694 | TECBlocks.Create(28, MakeECB(18, 47), MakeECB(31, 48)),
2695 | TECBlocks.Create(30, MakeECB(34, 24), MakeECB(34, 25)),
2696 | TECBlocks.Create(30, MakeECB(20, 15), MakeECB(61, 16)));
2697 | else
2698 | Result := nil;
2699 | end;
2700 | end;
2701 |
2702 | { TECBlocks }
2703 |
2704 | constructor TECBlocks.Create(ECCodewordsPerBlock: Integer; ECBlocks: TECB);
2705 | begin
2706 | FECCodewordsPerBlock := ECCodewordsPerBlock;
2707 | SetLength(FECBlocks, 1);
2708 | FECBlocks[0] := ECBlocks;
2709 | end;
2710 |
2711 | constructor TECBlocks.Create(ECCodewordsPerBlock: Integer; ECBlocks1,
2712 | ECBlocks2: TECB);
2713 | begin
2714 | FECCodewordsPerBlock := ECCodewordsPerBlock;
2715 | SetLength(FECBlocks, 2);
2716 | FECBlocks[0] := ECBlocks1;
2717 | FECBlocks[1] := ECBlocks2;
2718 | end;
2719 |
2720 | destructor TECBlocks.Destroy;
2721 | begin
2722 | SetLength(FECBlocks, 0);
2723 | inherited;
2724 | end;
2725 |
2726 | function TECBlocks.GetECBlocks: TECBArray;
2727 | begin
2728 | Result := FECBlocks;
2729 | end;
2730 |
2731 | function TECBlocks.GetECCodewordsPerBlock: Integer;
2732 | begin
2733 | Result := FECCodewordsPerBlock;
2734 | end;
2735 |
2736 | function TECBlocks.GetNumBlocks: Integer;
2737 | var
2738 | Total: Integer;
2739 | I: Integer;
2740 | begin
2741 | Total := 0;
2742 | for I := 0 to Length(FECBlocks) - 1 do
2743 | Inc(Total, FECBlocks[I].Count);
2744 | Result := Total;
2745 | end;
2746 |
2747 | function TECBlocks.GetTotalECCodewords: Integer;
2748 | begin
2749 | Result := FECCodewordsPerBlock * GetNumBlocks;
2750 | end;
2751 |
2752 | { TBlockPair }
2753 |
2754 | constructor TBlockPair.Create(BA1, BA2: TByteArray);
2755 | begin
2756 | FDataBytes := BA1;
2757 | FErrorCorrectionBytes := BA2;
2758 | end;
2759 |
2760 | function TBlockPair.GetDataBytes: TByteArray;
2761 | begin
2762 | Result := FDataBytes;
2763 | end;
2764 |
2765 | function TBlockPair.GetErrorCorrectionBytes: TByteArray;
2766 | begin
2767 | Result := FErrorCorrectionBytes;
2768 | end;
2769 |
2770 | { TReedSolomonEncoder }
2771 |
2772 | function TReedSolomonEncoder.BuildGenerator(Degree: Integer): TGenericGFPoly;
2773 | var
2774 | LastGenerator: TGenericGFPoly;
2775 | NextGenerator: TGenericGFPoly;
2776 | Poly: TGenericGFPoly;
2777 | D: Integer;
2778 | CA: TIntegerArray;
2779 | begin
2780 | if Degree >= FCachedGenerators.Count then
2781 | begin
2782 | LastGenerator := TGenericGFPoly(FCachedGenerators[FCachedGenerators.Count -
2783 | 1]);
2784 |
2785 | for D := FCachedGenerators.Count to Degree do
2786 | begin
2787 | SetLength(CA, 2);
2788 | CA[0] := 1;
2789 | CA[1] := FField.Exp(D - 1 + FField.GetGeneratorBase);
2790 | Poly := TGenericGFPoly.Create(FField, CA);
2791 | NextGenerator := LastGenerator.Multiply(Poly);
2792 | FCachedGenerators.Add(NextGenerator);
2793 | LastGenerator := NextGenerator;
2794 | end;
2795 | end;
2796 | Result := TGenericGFPoly(FCachedGenerators[Degree]);
2797 | end;
2798 |
2799 | constructor TReedSolomonEncoder.Create(AField: TGenericGF);
2800 | var
2801 | GenericGFPoly: TGenericGFPoly;
2802 | IntArray: TIntegerArray;
2803 | begin
2804 | FField := AField;
2805 |
2806 | // Contents of FCachedGenerators will be freed by FGenericGF.Destroy
2807 | FCachedGenerators := TObjectList.Create(False);
2808 |
2809 | SetLength(IntArray, 1);
2810 | IntArray[0] := 1;
2811 | GenericGFPoly := TGenericGFPoly.Create(AField, IntArray);
2812 | FCachedGenerators.Add(GenericGFPoly);
2813 | end;
2814 |
2815 | destructor TReedSolomonEncoder.Destroy;
2816 | begin
2817 | FCachedGenerators.Free;
2818 | inherited;
2819 | end;
2820 |
2821 | procedure TReedSolomonEncoder.Encode(ToEncode: TIntegerArray; ECBytes: Integer);
2822 | var
2823 | DataBytes: Integer;
2824 | Generator: TGenericGFPoly;
2825 | InfoCoefficients: TIntegerArray;
2826 | Info: TGenericGFPoly;
2827 | Remainder: TGenericGFPoly;
2828 | Coefficients: TIntegerArray;
2829 | NumZeroCoefficients: Integer;
2830 | I: Integer;
2831 | begin
2832 | SetLength(Coefficients, 0);
2833 | if ECBytes > 0 then
2834 | begin
2835 | DataBytes := Length(ToEncode) - ECBytes;
2836 | if DataBytes > 0 then
2837 | begin
2838 | Generator := BuildGenerator(ECBytes);
2839 | SetLength(InfoCoefficients, DataBytes);
2840 | InfoCoefficients := Copy(ToEncode, 0, DataBytes);
2841 | Info := TGenericGFPoly.Create(FField, InfoCoefficients);
2842 | Info := Info.MultiplyByMonomial(ECBytes, 1);
2843 | Remainder := Info.Divide(Generator)[1];
2844 | Coefficients := Remainder.GetCoefficients;
2845 | NumZeroCoefficients := ECBytes - Length(Coefficients);
2846 | for I := 0 to NumZeroCoefficients - 1 do
2847 | ToEncode[DataBytes + I] := 0;
2848 | Move(Coefficients[0], ToEncode[DataBytes + NumZeroCoefficients],
2849 | Length(Coefficients) * SizeOf(Integer));
2850 | end;
2851 | end;
2852 | end;
2853 |
2854 | { TGenericGFPoly }
2855 |
2856 | function TGenericGFPoly.AddOrSubtract(Other: TGenericGFPoly): TGenericGFPoly;
2857 | var
2858 | SmallerCoefficients: TIntegerArray;
2859 | LargerCoefficients: TIntegerArray;
2860 | Temp: TIntegerArray;
2861 | SumDiff: TIntegerArray;
2862 | LengthDiff: Integer;
2863 | I: Integer;
2864 | begin
2865 | SetLength(SmallerCoefficients, 0);
2866 | SetLength(LargerCoefficients, 0);
2867 | SetLength(Temp, 0);
2868 | SetLength(SumDiff, 0);
2869 |
2870 | Result := nil;
2871 | if Assigned(Other) and (FField = Other.FField) then
2872 | begin
2873 | if IsZero then
2874 | begin
2875 | Result := Other;
2876 | Exit;
2877 | end;
2878 |
2879 | if Other.IsZero then
2880 | begin
2881 | Result := Self;
2882 | Exit;
2883 | end;
2884 |
2885 | SmallerCoefficients := FCoefficients;
2886 | LargerCoefficients := Other.Coefficients;
2887 | if Length(SmallerCoefficients) > Length(LargerCoefficients) then
2888 | begin
2889 | Temp := smallerCoefficients;
2890 | SmallerCoefficients := LargerCoefficients;
2891 | LargerCoefficients := temp;
2892 | end;
2893 | SetLength(SumDiff, Length(LargerCoefficients));
2894 | LengthDiff := Length(LargerCoefficients) - Length(SmallerCoefficients);
2895 |
2896 | // Copy high-order terms only found in higher-degree polynomial's coefficients
2897 | if LengthDiff > 0 then
2898 | //SumDiff := Copy(LargerCoefficients, 0, LengthDiff);
2899 | Move(LargerCoefficients[0], SumDiff[0], LengthDiff * SizeOf(Integer));
2900 |
2901 | for I := LengthDiff to Length(LargerCoefficients) - 1 do
2902 | SumDiff[I] := TGenericGF.AddOrSubtract(SmallerCoefficients[I -
2903 | LengthDiff], LargerCoefficients[I]);
2904 |
2905 | Result := TGenericGFPoly.Create(FField, SumDiff);
2906 | end;
2907 | end;
2908 |
2909 | function TGenericGFPoly.Coefficients: TIntegerArray;
2910 | begin
2911 | Result := FCoefficients;
2912 | end;
2913 |
2914 | constructor TGenericGFPoly.Create(AField: TGenericGF;
2915 | ACoefficients: TIntegerArray);
2916 | var
2917 | CoefficientsLength: Integer;
2918 | FirstNonZero: Integer;
2919 | begin
2920 | FField := AField;
2921 | SetLength(FField.FPolyList, Length(FField.FPolyList) + 1);
2922 | FField.FPolyList[Length(FField.FPolyList) - 1] := Self;
2923 | CoefficientsLength := Length(ACoefficients);
2924 | if (CoefficientsLength > 1) and (ACoefficients[0] = 0) then
2925 | begin
2926 | // Leading term must be non-zero for anything except the constant polynomial "0"
2927 | FirstNonZero := 1;
2928 | while (FirstNonZero < CoefficientsLength) and
2929 | (ACoefficients[FirstNonZero] = 0) do
2930 | Inc(FirstNonZero);
2931 |
2932 | if FirstNonZero = CoefficientsLength then
2933 | FCoefficients := AField.GetZero.Coefficients
2934 | else
2935 | begin
2936 | SetLength(FCoefficients, CoefficientsLength - FirstNonZero);
2937 | FCoefficients := Copy(ACoefficients, FirstNonZero, Length(FCoefficients));
2938 | end;
2939 | end else
2940 | FCoefficients := ACoefficients;
2941 | end;
2942 |
2943 | destructor TGenericGFPoly.Destroy;
2944 | begin
2945 | Self.FField := FField;
2946 | inherited;
2947 | end;
2948 |
2949 | function TGenericGFPoly.Divide(Other: TGenericGFPoly): TGenericGFPolyArray;
2950 | var
2951 | Quotient: TGenericGFPoly;
2952 | Remainder: TGenericGFPoly;
2953 | DenominatorLeadingTerm: Integer;
2954 | InverseDenominatorLeadingTerm: integer;
2955 | DegreeDifference: Integer;
2956 | Scale: Integer;
2957 | Term: TGenericGFPoly;
2958 | IterationQuotient: TGenericGFPoly;
2959 | begin
2960 | SetLength(Result, 0);
2961 | if (FField = Other.FField) and not Other.IsZero then
2962 | begin
2963 | Quotient := FField.GetZero;
2964 | Remainder := Self;
2965 |
2966 | DenominatorLeadingTerm := Other.GetCoefficient(Other.GetDegree);
2967 | InverseDenominatorLeadingTerm := FField.Inverse(DenominatorLeadingTerm);
2968 |
2969 | while (Remainder.GetDegree >= Other.GetDegree) and not Remainder.IsZero do
2970 | begin
2971 | DegreeDifference := Remainder.GetDegree - Other.GetDegree;
2972 | Scale := FField.Multiply(Remainder.GetCoefficient(Remainder.GetDegree),
2973 | InverseDenominatorLeadingTerm);
2974 | Term := Other.MultiplyByMonomial(DegreeDifference, Scale);
2975 | IterationQuotient := FField.BuildMonomial(degreeDifference, scale);
2976 | Quotient := Quotient.AddOrSubtract(IterationQuotient);
2977 | Remainder := Remainder.AddOrSubtract(Term);
2978 | end;
2979 |
2980 | SetLength(Result, 2);
2981 | Result[0] := Quotient;
2982 | Result[1] := Remainder;
2983 | end;
2984 | end;
2985 |
2986 | function TGenericGFPoly.GetCoefficient(Degree: Integer): Integer;
2987 | begin
2988 | Result := FCoefficients[Length(FCoefficients) - 1 - Degree];
2989 | end;
2990 |
2991 | function TGenericGFPoly.GetCoefficients: TIntegerArray;
2992 | begin
2993 | Result := FCoefficients;
2994 | end;
2995 |
2996 | function TGenericGFPoly.GetDegree: Integer;
2997 | begin
2998 | Result := Length(FCoefficients) - 1;
2999 | end;
3000 |
3001 | function TGenericGFPoly.IsZero: Boolean;
3002 | begin
3003 | Result := FCoefficients[0] = 0;
3004 | end;
3005 |
3006 | function TGenericGFPoly.Multiply(Other: TGenericGFPoly): TGenericGFPoly;
3007 | var
3008 | ACoefficients: TIntegerArray;
3009 | BCoefficients: TIntegerArray;
3010 | Product: TIntegerArray;
3011 | ALength: Integer;
3012 | BLength: Integer;
3013 | I: Integer;
3014 | J: Integer;
3015 | ACoeff: Integer;
3016 | begin
3017 | SetLength(ACoefficients, 0);
3018 | SetLength(BCoefficients, 0);
3019 | Result := nil;
3020 |
3021 | if FField = Other.FField then
3022 | begin
3023 | if IsZero or Other.IsZero then
3024 | Result := FField.GetZero
3025 | else
3026 | begin
3027 | ACoefficients := FCoefficients;
3028 | ALength := Length(ACoefficients);
3029 | BCoefficients := Other.Coefficients;
3030 | BLength := Length(BCoefficients);
3031 | SetLength(Product, aLength + bLength - 1);
3032 | for I := 0 to ALength - 1 do
3033 | begin
3034 | ACoeff := ACoefficients[I];
3035 | for J := 0 to BLength - 1 do
3036 | Product[I + J] := TGenericGF.AddOrSubtract(Product[I + J],
3037 | FField.Multiply(ACoeff, BCoefficients[J]));
3038 | end;
3039 | Result := TGenericGFPoly.Create(FField, Product);
3040 | end;
3041 | end;
3042 | end;
3043 |
3044 | function TGenericGFPoly.MultiplyByMonomial(Degree,
3045 | Coefficient: Integer): TGenericGFPoly;
3046 | var
3047 | I: Integer;
3048 | Size: Integer;
3049 | Product: TIntegerArray;
3050 | begin
3051 | Result := nil;
3052 | if Degree >= 0 then
3053 | begin
3054 | if Coefficient = 0 then
3055 | Result := FField.GetZero
3056 | else
3057 | begin
3058 | Size := Length(Coefficients);
3059 | SetLength(Product, Size + Degree);
3060 | for I := 0 to Size - 1 do
3061 | Product[I] := FField.Multiply(FCoefficients[I], Coefficient);
3062 | Result := TGenericGFPoly.Create(FField, Product);
3063 | end;
3064 | end;
3065 | end;
3066 |
3067 | { TGenericGF }
3068 |
3069 | class function TGenericGF.AddOrSubtract(A, B: Integer): Integer;
3070 | begin
3071 | Result := A xor B;
3072 | end;
3073 |
3074 | function TGenericGF.BuildMonomial(Degree, Coefficient: Integer): TGenericGFPoly;
3075 | var
3076 | Coefficients: TIntegerArray;
3077 | begin
3078 | CheckInit();
3079 |
3080 | if Degree >= 0 then
3081 | begin
3082 | if Coefficient = 0 then
3083 | Result := FZero
3084 | else
3085 | begin
3086 | SetLength(Coefficients, Degree + 1);
3087 | Coefficients[0] := Coefficient;
3088 | Result := TGenericGFPoly.Create(Self, Coefficients);
3089 | end;
3090 | end
3091 | else
3092 | Result := nil;
3093 | end;
3094 |
3095 | procedure TGenericGF.CheckInit;
3096 | begin
3097 | if not FInitialized then
3098 | Initialize;
3099 | end;
3100 |
3101 | constructor TGenericGF.Create(Primitive, Size, B: Integer);
3102 | begin
3103 | FInitialized := False;
3104 | FPrimitive := Primitive;
3105 | FSize := Size;
3106 | FGeneratorBase := B;
3107 | if FSize < 0 then
3108 | Initialize;
3109 | end;
3110 |
3111 | class function TGenericGF.CreateQRCodeField256: TGenericGF;
3112 | begin
3113 | Result := TGenericGF.Create($011D, 256, 0);
3114 | end;
3115 |
3116 | destructor TGenericGF.Destroy;
3117 | var
3118 | X: Integer;
3119 | Y: Integer;
3120 | begin
3121 | for X := 0 to Length(FPolyList) - 1 do
3122 | if Assigned(FPolyList[X]) then
3123 | begin
3124 | for Y := X + 1 to Length(FPolyList) - 1 do
3125 | if FPolyList[Y] = FPolyList[X] then
3126 | FPolyList[Y] := nil;
3127 | FPolyList[X].Free;
3128 | end;
3129 | inherited;
3130 | end;
3131 |
3132 | function TGenericGF.Exp(A: Integer): Integer;
3133 | begin
3134 | CheckInit;
3135 | Result := FExpTable[A];
3136 | end;
3137 |
3138 | function TGenericGF.GetGeneratorBase: Integer;
3139 | begin
3140 | Result := FGeneratorBase;
3141 | end;
3142 |
3143 | function TGenericGF.GetZero: TGenericGFPoly;
3144 | begin
3145 | CheckInit;
3146 | Result := FZero;
3147 | end;
3148 |
3149 | procedure TGenericGF.Initialize;
3150 | var
3151 | X: Integer;
3152 | I: Integer;
3153 | CA: TIntegerArray;
3154 | begin
3155 | SetLength(FExpTable, FSize);
3156 | SetLength(FLogTable, FSize);
3157 | X := 1;
3158 | for I := 0 to FSize - 1 do
3159 | begin
3160 | FExpTable[I] := x;
3161 | X := X shl 1; // x = x * 2; we're assuming the generator alpha is 2
3162 | if X >= FSize then
3163 | X := (X xor FPrimitive) and (FSize - 1);
3164 | end;
3165 |
3166 | for I := 0 to FSize - 2 do
3167 | FLogTable[FExpTable[I]] := I;
3168 |
3169 | // logTable[0] == 0 but this should never be used
3170 |
3171 | SetLength(CA, 1);
3172 | CA[0] := 0;
3173 | FZero := TGenericGFPoly.Create(Self, CA);
3174 |
3175 | SetLength(CA, 1);
3176 | CA[0] := 1;
3177 | FOne := TGenericGFPoly.Create(Self, CA);
3178 |
3179 | FInitialized := True;
3180 | end;
3181 |
3182 | function TGenericGF.Inverse(A: Integer): Integer;
3183 | begin
3184 | CheckInit;
3185 | if A <> 0 then
3186 | Result := FExpTable[FSize - FLogTable[A] - 1]
3187 | else
3188 | Result := 0;
3189 | end;
3190 |
3191 | function TGenericGF.Multiply(A, B: Integer): Integer;
3192 | begin
3193 | CheckInit;
3194 | if (A <> 0) and (B <> 0) then
3195 | Result := FExpTable[(FLogTable[A] + FLogTable[B]) mod (FSize - 1)]
3196 | else
3197 | Result := 0;
3198 | end;
3199 |
3200 | { TDelphiZXingQRCode }
3201 |
3202 | constructor TDelphiZXingQRCode.Create;
3203 | begin
3204 | FData := '';
3205 | FFilteredData := '';
3206 | FEncoding := ENCODING_AUTO;
3207 | FQuietZone := 4;
3208 | FRows := 0;
3209 | FColumns := 0;
3210 | FErrorCorrectionOrdinal := ecoL;
3211 | FEncoders := TClassList.Create;
3212 | FAfterUpdate := nil;
3213 | FBeforeUpdate := nil;
3214 | FUpdateLockCount := 0;
3215 | end;
3216 |
3217 | destructor TDelphiZXingQRCode.Destroy;
3218 | begin
3219 | FEncoders.Clear;
3220 | FEncoders.Free;
3221 | FAfterUpdate := nil;
3222 | FBeforeUpdate := nil;
3223 | inherited Destroy;
3224 | end;
3225 |
3226 | procedure TDelphiZXingQRCode.RegisterEncoder(NewEncoding: Integer;
3227 | NewEncoder: TEncoderClass);
3228 | begin
3229 | if NewEncoding >= FEncoders.Count then
3230 | begin
3231 | while FEncoders.Count < NewEncoding do
3232 | FEncoders.Add(nil);
3233 | FEncoders.Add(NewEncoder);
3234 | end else
3235 | FEncoders[NewEncoding] := NewEncoder
3236 | end;
3237 |
3238 | function TDelphiZXingQRCode.GetIsBlack(Row, Column: Integer): Boolean;
3239 | begin
3240 | Dec(Row, FQuietZone);
3241 | Dec(Column, FQuietZone);
3242 | if (Row >= 0) and (Column >= 0) and (Row < FRows - FQuietZone * 2) and
3243 | (Column < FColumns - FQuietZone * 2) then
3244 | Result := FElements[Column, Row]
3245 | else
3246 | Result := False;
3247 | end;
3248 |
3249 | function TDelphiZXingQRCode.GetEncoderClass: TEncoderClass;
3250 | begin
3251 | Result := TEncoder;
3252 | if (FEncoding < FEncoders.Count) and Assigned(FEncoders[FEncoding]) then
3253 | Result := TEncoderClass(FEncoders[FEncoding])
3254 | end;
3255 |
3256 | procedure TDelphiZXingQRCode.SetData(const NewData: WideString);
3257 | begin
3258 | if FData <> NewData then
3259 | begin
3260 | FData := NewData;
3261 | Update;
3262 | end;
3263 | end;
3264 |
3265 | procedure TDelphiZXingQRCode.SetEncoding(NewEncoding: Integer);
3266 | begin
3267 | if FEncoding <> NewEncoding then
3268 | begin
3269 | FEncoding := NewEncoding;
3270 | Update;
3271 | end;
3272 | end;
3273 |
3274 | procedure TDelphiZXingQRCode.SetQuietZone(NewQuietZone: Integer);
3275 | begin
3276 | if (FQuietZone <> NewQuietZone) and (NewQuietZone >= 0) and
3277 | (NewQuietZone <= 100) then
3278 | begin
3279 | FQuietZone := NewQuietZone;
3280 | Update;
3281 | end;
3282 | end;
3283 |
3284 | procedure TDelphiZXingQRCode.SetErrorCorrectionOrdinal(Value:
3285 | TErrorCorrectionOrdinal);
3286 | begin
3287 | if FErrorCorrectionOrdinal <> Value then
3288 | begin
3289 | FErrorCorrectionOrdinal := Value;
3290 | Update;
3291 | end;
3292 | end;
3293 |
3294 | procedure TDelphiZXingQRCode.Update;
3295 | var
3296 | Encoder: TEncoder;
3297 | Level: TErrorCorrectionLevel;
3298 | QRCode: TQRCode;
3299 | X: Integer;
3300 | Y: Integer;
3301 | begin
3302 | if FUpdateLockCount > 0 then
3303 | Exit;
3304 | if Assigned(FBeforeUpdate) then
3305 | begin
3306 | // BeforeUpdate can change other properties and make unwanted recursion
3307 | BeginUpdate;
3308 | FBeforeUpdate(Self);
3309 | EndUpdate;
3310 | end;
3311 | Level := TErrorCorrectionLevel.Create;
3312 | Level.Ordinal := FErrorCorrectionOrdinal;
3313 | Encoder := GetEncoderClass.Create;
3314 | QRCode := TQRCode.Create;
3315 | FFilteredData := '';
3316 | try
3317 | FFilteredData := Encoder.Encode(FData, FEncoding, Level, QRCode);
3318 | if Assigned(QRCode.FMatrix) then
3319 | begin
3320 | SetLength(FElements, QRCode.FMatrix.FHeight);
3321 | for Y := 0 to QRCode.FMatrix.FHeight - 1 do
3322 | begin
3323 | SetLength(FElements[Y], QRCode.FMatrix.FWidth);
3324 | for X := 0 to QRCode.FMatrix.FWidth - 1 do
3325 | FElements[Y][X] := QRCode.FMatrix.Get(Y, X) = 1;
3326 | end;
3327 | end;
3328 | finally
3329 | QRCode.Free;
3330 | Encoder.Free;
3331 | Level.Free;
3332 | end;
3333 | FRows := Length(FElements) + FQuietZone * 2;
3334 | FColumns := FRows;
3335 | if Assigned(FAfterUpdate) then
3336 | begin
3337 | BeginUpdate;
3338 | FAfterUpdate(Self);
3339 | EndUpdate;
3340 | end;
3341 | end;
3342 |
3343 | procedure TDelphiZXingQRCode.BeginUpdate;
3344 | begin
3345 | Inc(FUpdateLockCount);
3346 | end;
3347 |
3348 | procedure TDelphiZXingQRCode.EndUpdate(DoUpdate: Boolean = False);
3349 | begin
3350 | if FUpdateLockCount > 0 then
3351 | Dec(FUpdateLockCount);
3352 | if DoUpdate and (FUpdateLockCount = 0) then
3353 | Update;
3354 | end;
3355 |
3356 | end.
3357 |
--------------------------------------------------------------------------------
/Source/QRGraphics.pas:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/MichaelDemidov/DelphiZXingQRCodeEx/248d431cdf18972f09e65959160f608573dbe04f/Source/QRGraphics.pas
--------------------------------------------------------------------------------
/Source/QR_URL.pas:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/MichaelDemidov/DelphiZXingQRCodeEx/248d431cdf18972f09e65959160f608573dbe04f/Source/QR_URL.pas
--------------------------------------------------------------------------------
/Source/QR_Win1251.pas:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/MichaelDemidov/DelphiZXingQRCodeEx/248d431cdf18972f09e65959160f608573dbe04f/Source/QR_Win1251.pas
--------------------------------------------------------------------------------
/TestApp/DelphiZXingQRCodeTestApp.dpr:
--------------------------------------------------------------------------------
1 | program DelphiZXingQRCodeTestApp;
2 |
3 | uses
4 | Forms,
5 | DelphiZXingQRCodeTestAppMainForm in 'DelphiZXingQRCodeTestAppMainForm.pas' {frmMain},
6 | DelphiZXingQRCode in '..\Source\DelphiZXIngQRCode.pas',
7 | QRGraphics in '..\Source\QRGraphics.pas',
8 | QR_Win1251 in '..\Source\QR_Win1251.pas',
9 | QR_URL in '..\Source\QR_URL.pas';
10 |
11 | {$R *.res}
12 |
13 | begin
14 | Application.Initialize;
15 | Application.Title := 'DelphiZXing Demo Application';
16 | Application.CreateForm(TfrmMain, frmMain);
17 | Application.Run;
18 | end.
19 |
--------------------------------------------------------------------------------
/TestApp/DelphiZXingQRCodeTestApp.dproj:
--------------------------------------------------------------------------------
1 |
2 |
3 | {9B95C818-479B-45EB-917E-C5AC561D7C60}
4 | 14.3
5 | VCL
6 | DelphiZXingQRCodeTestApp.dpr
7 | True
8 | Debug
9 | Win32
10 | 1
11 | Application
12 |
13 |
14 | true
15 |
16 |
17 | true
18 | Base
19 | true
20 |
21 |
22 | true
23 | Base
24 | true
25 |
26 |
27 | true
28 | Base
29 | true
30 |
31 |
32 | true
33 | Cfg_1
34 | true
35 | true
36 |
37 |
38 | true
39 | Base
40 | true
41 |
42 |
43 | ..\Source\;$(DCC_UnitSearchPath)
44 | CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=
45 | None
46 | 7177
47 | bindcompfmx;dsnap;fmx;rtl;dbrtl;fmxase;bindcomp;fmxobj;xmlrtl;fmxdae;bindengine;$(DCC_UsePackage)
48 | $(BDS)\bin\delphi_PROJECTICON.ico
49 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)
50 | .\$(Platform)\$(Config)
51 | .\$(Platform)\$(Config)
52 | false
53 | false
54 | false
55 | false
56 | false
57 |
58 |
59 | bindcompvcl;vcltouch;vcldbx;VclSmp;vcl;IndyCore;IndySystem;dsnapcon;DelphiAdobeReaderActiveX;vclx;svnui;svn;vclimg;fmi;IndyProtocols;bdertl;vclactnband;vcldb;vcldsnap;$(DCC_UsePackage)
60 | true
61 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)
62 | 1033
63 | $(BDS)\bin\default_app.manifest
64 | CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=
65 |
66 |
67 | bindcompvcl;vcltouch;VclSmp;vcl;dsnapcon;vclx;vclimg;vclactnband;vcldb;vcldsnap;$(DCC_UsePackage)
68 |
69 |
70 | DEBUG;$(DCC_Define)
71 | false
72 | true
73 | true
74 | true
75 |
76 |
77 | true
78 | 1033
79 | false
80 |
81 |
82 | false
83 | RELEASE;$(DCC_Define)
84 | 0
85 | false
86 |
87 |
88 |
89 | MainSource
90 |
91 |
92 |
93 | dfm
94 |
95 |
96 |
97 |
98 |
99 |
100 | Cfg_2
101 | Base
102 |
103 |
104 | Base
105 |
106 |
107 | Cfg_1
108 | Base
109 |
110 |
111 |
112 | Delphi.Personality.12
113 |
114 |
115 |
116 |
117 | False
118 | False
119 | 1
120 | 0
121 | 0
122 | 0
123 | False
124 | False
125 | False
126 | False
127 | False
128 | 7177
129 | 1252
130 |
131 |
132 |
133 |
134 | 1.0.0.0
135 |
136 |
137 |
138 |
139 |
140 | 1.0.0.0
141 |
142 |
143 |
144 | DelphiZXingQRCodeTestApp.dpr
145 |
146 |
147 | CodeSite Express 5.1
148 |
149 |
150 |
151 |
152 |
153 |
154 |
155 |
156 | DelphiZXingQRCodeTestApp.rsm
157 |
158 |
159 |
160 |
161 | 1
162 | .dylib
163 |
164 |
165 | 0
166 | .bpl
167 |
168 |
169 | Contents\MacOS
170 | 1
171 | .dylib
172 |
173 |
174 | 1
175 | .dylib
176 |
177 |
178 |
179 |
180 | 1
181 | .dylib
182 |
183 |
184 | 0
185 | .dll;.bpl
186 |
187 |
188 | Contents\MacOS
189 | 1
190 | .dylib
191 |
192 |
193 | 1
194 | .dylib
195 |
196 |
197 |
198 |
199 | 1
200 |
201 |
202 | 1
203 |
204 |
205 |
206 |
207 | Contents
208 | 1
209 |
210 |
211 |
212 |
213 | 1
214 |
215 |
216 |
217 |
218 | 1
219 |
220 |
221 | 1
222 |
223 |
224 |
225 |
226 | 1
227 |
228 |
229 | 1
230 |
231 |
232 |
233 |
234 | 1
235 |
236 |
237 |
238 |
239 | Contents
240 | 1
241 |
242 |
243 |
244 |
245 | 1
246 |
247 |
248 | 1
249 |
250 |
251 |
252 |
253 | Contents\Resources
254 | 1
255 |
256 |
257 |
258 |
259 | 1
260 |
261 |
262 | 1
263 |
264 |
265 |
266 |
267 | 1
268 |
269 |
270 | 1
271 |
272 |
273 |
274 |
275 | 1
276 |
277 |
278 | 0
279 |
280 |
281 | Contents\MacOS
282 | 1
283 |
284 |
285 | 1
286 |
287 |
288 |
289 |
290 | 1
291 |
292 |
293 |
294 |
295 | 0
296 |
297 |
298 | 0
299 |
300 |
301 | Contents\MacOS
302 | 0
303 |
304 |
305 | 0
306 |
307 |
308 |
309 |
310 | 1
311 |
312 |
313 | 0
314 |
315 |
316 | Contents\MacOS
317 | 1
318 |
319 |
320 | 1
321 |
322 |
323 |
324 |
325 | Contents\MacOS
326 | 1
327 | .framework
328 |
329 |
330 | 0
331 |
332 |
333 |
334 |
335 | 1
336 |
337 |
338 |
339 |
340 | 1
341 |
342 |
343 | 1
344 |
345 |
346 |
347 |
348 | 1
349 |
350 |
351 | Contents\MacOS
352 | 0
353 |
354 |
355 | Contents\MacOS
356 | 1
357 |
358 |
359 | 1
360 |
361 |
362 |
363 |
364 |
365 |
366 |
367 |
368 |
369 | True
370 | False
371 |
372 |
373 | 12
374 |
375 |
376 |
377 |
378 |
379 |
--------------------------------------------------------------------------------
/TestApp/DelphiZXingQRCodeTestApp.exe:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/MichaelDemidov/DelphiZXingQRCodeEx/248d431cdf18972f09e65959160f608573dbe04f/TestApp/DelphiZXingQRCodeTestApp.exe
--------------------------------------------------------------------------------
/TestApp/DelphiZXingQRCodeTestApp.res:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/MichaelDemidov/DelphiZXingQRCodeEx/248d431cdf18972f09e65959160f608573dbe04f/TestApp/DelphiZXingQRCodeTestApp.res
--------------------------------------------------------------------------------
/TestApp/DelphiZXingQRCodeTestAppMainForm.dfm:
--------------------------------------------------------------------------------
1 | object frmMain: TfrmMain
2 | Left = 549
3 | Top = 353
4 | Width = 571
5 | Height = 500
6 | Caption = 'Delphi port of ZXing QRCode'
7 | Color = clBtnFace
8 | Constraints.MinHeight = 320
9 | Constraints.MinWidth = 550
10 | Font.Charset = DEFAULT_CHARSET
11 | Font.Color = clWindowText
12 | Font.Height = -11
13 | Font.Name = 'Tahoma'
14 | Font.Style = []
15 | KeyPreview = True
16 | OldCreateOrder = False
17 | OnCreate = FormCreate
18 | OnDestroy = FormDestroy
19 | OnKeyDown = FormKeyDown
20 | PixelsPerInch = 96
21 | TextHeight = 13
22 | object splTop: TSplitter
23 | Left = 0
24 | Top = 119
25 | Width = 555
26 | Height = 5
27 | Cursor = crVSplit
28 | Align = alBottom
29 | AutoSnap = False
30 | Beveled = True
31 | end
32 | object pnlTop: TPanel
33 | Left = 0
34 | Top = 0
35 | Width = 555
36 | Height = 119
37 | Align = alClient
38 | BevelOuter = bvNone
39 | BorderWidth = 8
40 | FullRepaint = False
41 | ParentBackground = True
42 | ParentColor = True
43 | TabOrder = 0
44 | object lblText: TLabel
45 | Left = 8
46 | Top = 8
47 | Width = 539
48 | Height = 13
49 | Align = alTop
50 | Caption = '&Text'
51 | FocusControl = mmoText
52 | Transparent = True
53 | end
54 | object mmoText: TMemo
55 | Left = 8
56 | Top = 21
57 | Width = 539
58 | Height = 90
59 | Align = alClient
60 | ScrollBars = ssVertical
61 | TabOrder = 0
62 | OnChange = mmoTextChange
63 | end
64 | end
65 | object pnlDetails: TPanel
66 | Left = 0
67 | Top = 124
68 | Width = 555
69 | Height = 338
70 | Align = alBottom
71 | BevelOuter = bvNone
72 | FullRepaint = False
73 | ParentBackground = True
74 | ParentColor = True
75 | TabOrder = 1
76 | object lblEncoding: TLabel
77 | Left = 8
78 | Top = 5
79 | Width = 43
80 | Height = 13
81 | Caption = '&Encoding'
82 | FocusControl = cmbEncoding
83 | Transparent = True
84 | end
85 | object lblQuietZone: TLabel
86 | Left = 8
87 | Top = 61
88 | Width = 52
89 | Height = 13
90 | Caption = '&Quiet zone'
91 | FocusControl = edtQuietZone
92 | Transparent = True
93 | end
94 | object lblErrorCorrectionLevel: TLabel
95 | Left = 128
96 | Top = 61
97 | Width = 100
98 | Height = 13
99 | Caption = 'Error &correction level'
100 | FocusControl = cbbErrorCorrectionLevel
101 | Transparent = True
102 | end
103 | object lblCorner: TLabel
104 | Left = 8
105 | Top = 176
106 | Width = 137
107 | Height = 13
108 | Caption = 'Corner &line thickness (pixels)'
109 | FocusControl = edtCornerThickness
110 | Transparent = True
111 | end
112 | object lblDrawingMode: TLabel
113 | Left = 8
114 | Top = 117
115 | Width = 68
116 | Height = 13
117 | Caption = '&Drawing mode'
118 | FocusControl = cbbDrawingMode
119 | Transparent = True
120 | end
121 | object cmbEncoding: TComboBox
122 | Left = 8
123 | Top = 24
124 | Width = 265
125 | Height = 21
126 | Style = csDropDownList
127 | ItemHeight = 13
128 | TabOrder = 1
129 | OnChange = cmbEncodingChange
130 | OnDrawItem = cmbEncodingDrawItem
131 | OnMeasureItem = cmbEncodingMeasureItem
132 | Items.Strings = (
133 | 'Auto'
134 | 'Numeric'
135 | 'Alphanumeric'
136 | 'ISO-8859-1'
137 | 'UTF-8 without BOM'
138 | 'UTF-8 with BOM'
139 | 'URL encoding'
140 | 'Windows-1251')
141 | end
142 | object edtQuietZone: TEdit
143 | Left = 8
144 | Top = 80
145 | Width = 73
146 | Height = 21
147 | TabOrder = 2
148 | Text = '4'
149 | OnChange = edtQuietZoneChange
150 | end
151 | object cbbErrorCorrectionLevel: TComboBox
152 | Left = 128
153 | Top = 80
154 | Width = 145
155 | Height = 21
156 | Style = csDropDownList
157 | ItemHeight = 13
158 | TabOrder = 4
159 | OnChange = cbbErrorCorrectionLevelChange
160 | Items.Strings = (
161 | 'L ~7% correction'
162 | 'M ~15% correction'
163 | 'Q ~25% correction'
164 | 'H ~30% correction')
165 | end
166 | object edtCornerThickness: TEdit
167 | Left = 168
168 | Top = 172
169 | Width = 49
170 | Height = 21
171 | TabOrder = 6
172 | Text = '0'
173 | OnChange = edtCornerThicknessChange
174 | end
175 | object udCornerThickness: TUpDown
176 | Left = 217
177 | Top = 172
178 | Width = 16
179 | Height = 21
180 | Associate = edtCornerThickness
181 | TabOrder = 7
182 | end
183 | object udQuietZone: TUpDown
184 | Left = 81
185 | Top = 80
186 | Width = 16
187 | Height = 21
188 | Associate = edtQuietZone
189 | Position = 4
190 | TabOrder = 3
191 | end
192 | object grpSaveToFile: TGroupBox
193 | Left = 8
194 | Top = 208
195 | Width = 265
196 | Height = 121
197 | Caption = '&Save / Copy'
198 | TabOrder = 8
199 | object lblScaleToSave: TLabel
200 | Left = 8
201 | Top = 24
202 | Width = 76
203 | Height = 13
204 | Caption = 'Dot size (pixels)'
205 | FocusControl = edtScaleToSave
206 | Transparent = True
207 | end
208 | object edtFileName: TEdit
209 | Left = 8
210 | Top = 56
211 | Width = 193
212 | Height = 21
213 | ReadOnly = True
214 | TabOrder = 2
215 | end
216 | object btnSaveToFile: TButton
217 | Left = 200
218 | Top = 56
219 | Width = 51
220 | Height = 21
221 | Caption = 'Save...'
222 | TabOrder = 3
223 | OnClick = btnSaveToFileClick
224 | end
225 | object edtScaleToSave: TEdit
226 | Left = 112
227 | Top = 20
228 | Width = 49
229 | Height = 21
230 | TabOrder = 0
231 | Text = '10'
232 | end
233 | object udScaleToSave: TUpDown
234 | Left = 161
235 | Top = 20
236 | Width = 16
237 | Height = 21
238 | Associate = edtScaleToSave
239 | Min = 1
240 | Position = 10
241 | TabOrder = 1
242 | end
243 | object btnCopy: TButton
244 | Left = 8
245 | Top = 88
246 | Width = 249
247 | Height = 25
248 | Caption = 'C&opy Bitmap to Clipboard'
249 | TabOrder = 4
250 | OnClick = btnCopyClick
251 | end
252 | end
253 | object cbbDrawingMode: TComboBox
254 | Left = 8
255 | Top = 136
256 | Width = 265
257 | Height = 21
258 | Style = csDropDownList
259 | ItemHeight = 13
260 | TabOrder = 5
261 | OnChange = cbbDrawingModeChange
262 | Items.Strings = (
263 | 'Bitmap proportional'
264 | 'Bitmap non-proportional'
265 | 'Vector: rectangles proportional'
266 | 'Vector: rectangles non-proportional'
267 | 'Vector: region proportional'
268 | 'Vector: region non-proportional')
269 | end
270 | object pgcQRDetails: TPageControl
271 | Left = 296
272 | Top = 5
273 | Width = 233
274 | Height = 289
275 | ActivePage = tsPreview
276 | TabOrder = 0
277 | object tsPreview: TTabSheet
278 | Caption = '&Preview'
279 | object pbPreview: TPaintBox
280 | Left = 0
281 | Top = 0
282 | Width = 225
283 | Height = 187
284 | Align = alClient
285 | OnPaint = pbPreviewPaint
286 | end
287 | object lblQRMetrics: TLabel
288 | Left = 0
289 | Top = 187
290 | Width = 225
291 | Height = 13
292 | Align = alBottom
293 | Alignment = taCenter
294 | Caption = 'lblQRMetrics'
295 | Transparent = True
296 | end
297 | object pnlColors: TPanel
298 | Left = 0
299 | Top = 200
300 | Width = 225
301 | Height = 61
302 | Align = alBottom
303 | BevelOuter = bvNone
304 | ParentBackground = True
305 | ParentColor = True
306 | TabOrder = 0
307 | object bvlColors: TBevel
308 | Left = 0
309 | Top = 0
310 | Width = 225
311 | Height = 9
312 | Align = alTop
313 | Shape = bsBottomLine
314 | end
315 | object lblBackground: TLabel
316 | Left = 8
317 | Top = 16
318 | Width = 56
319 | Height = 13
320 | Caption = '&Background'
321 | FocusControl = clrbxBackground
322 | end
323 | object lblForeground: TLabel
324 | Left = 8
325 | Top = 40
326 | Width = 56
327 | Height = 13
328 | Caption = '&Foreground'
329 | FocusControl = clrbxForeground
330 | end
331 | object clrbxBackground: TColorBox
332 | Left = 80
333 | Top = 11
334 | Width = 137
335 | Height = 22
336 | DefaultColorColor = clWhite
337 | Selected = clWhite
338 | Style = [cbStandardColors, cbExtendedColors, cbCustomColor, cbPrettyNames]
339 | ItemHeight = 16
340 | TabOrder = 0
341 | OnChange = clrbxBackgroundChange
342 | end
343 | object clrbxForeground: TColorBox
344 | Left = 80
345 | Top = 35
346 | Width = 137
347 | Height = 22
348 | Style = [cbStandardColors, cbExtendedColors, cbCustomColor, cbPrettyNames]
349 | ItemHeight = 16
350 | TabOrder = 1
351 | OnChange = clrbxForegroundChange
352 | end
353 | end
354 | end
355 | object tsEncodedData: TTabSheet
356 | Caption = 'E&ncoded Data'
357 | ImageIndex = 1
358 | object mmoEncodedData: TMemo
359 | Left = 0
360 | Top = 0
361 | Width = 225
362 | Height = 261
363 | Align = alClient
364 | BorderStyle = bsNone
365 | ReadOnly = True
366 | ScrollBars = ssVertical
367 | TabOrder = 0
368 | OnChange = mmoTextChange
369 | end
370 | end
371 | end
372 | end
373 | object dlgSaveToFile: TSaveDialog
374 | Filter =
375 | 'Bitmap (*.bmp)|*.bmp|Metfile (*.emf)|*.emf|JPEG (*.jpeg; *.jpg)|' +
376 | '*.jpeg;*.jpg'
377 | Options = [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofEnableSizing, ofDontAddToRecent]
378 | Left = 328
379 | Top = 288
380 | end
381 | end
382 |
--------------------------------------------------------------------------------
/TestApp/DelphiZXingQRCodeTestAppMainForm.pas:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/MichaelDemidov/DelphiZXingQRCodeEx/248d431cdf18972f09e65959160f608573dbe04f/TestApp/DelphiZXingQRCodeTestAppMainForm.pas
--------------------------------------------------------------------------------
/TestApp/Lazarus-src.zip:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/MichaelDemidov/DelphiZXingQRCodeEx/248d431cdf18972f09e65959160f608573dbe04f/TestApp/Lazarus-src.zip
--------------------------------------------------------------------------------
/TestApp/qr.ico:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/MichaelDemidov/DelphiZXingQRCodeEx/248d431cdf18972f09e65959160f608573dbe04f/TestApp/qr.ico
--------------------------------------------------------------------------------